Bodigrim pushed to branch wip/nubOrd at Glasgow Haskell Compiler / GHC

Commits:

19 changed files:

Changes:

  • compiler/GHC/Core/Utils.hs
    ... ... @@ -78,7 +78,7 @@ import GHC.Core.Type as Type
    78 78 
     import GHC.Core.Predicate( isEqPred )
    79 79 
     import GHC.Core.Predicate( isUnaryClass )
    80 80 
     import GHC.Core.FamInstEnv
    81 
    -import GHC.Core.TyCo.Compare( eqType, eqTypeX )
    81 
    +import GHC.Core.TyCo.Compare( eqType, eqTypeX, eqTypeIgnoringMultiplicity )
    82 82 
     import GHC.Core.Coercion
    83 83 
     import GHC.Core.Reduction
    84 84 
     import GHC.Core.TyCon
    ... ... @@ -275,7 +275,7 @@ mkCast expr co
    275 275 
       = assertPpr (coercionRole co == Representational)
    276 276 
                   (text "coercion" <+> ppr co <+> text "passed to mkCast"
    277 277 
                    <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $
    278 
    -    warnPprTrace (not (coercionLKind co `eqType` exprType expr)) "Bad cast"
    278 
    +    warnPprTrace (not (coercionLKind co `eqTypeIgnoringMultiplicity` exprType expr)) "Bad cast"
    279 279 
           (vcat [ text "Coercion LHS kind does not match enclosed expression type"
    280 280 
                 , text "co:" <+> ppr co
    281 281 
                 , text "coercionLKind:" <+> ppr (coercionLKind co)

  • compiler/GHC/HsToCore/Pmc/Solver/Types.hs
    ... ... @@ -2,6 +2,7 @@
    2 2 
     {-# LANGUAGE ScopedTypeVariables #-}
    3 3 
     {-# LANGUAGE ViewPatterns        #-}
    4 4 
     {-# LANGUAGE MultiWayIf          #-}
    5 
    +{-# LANGUAGE TypeFamilies        #-}
    5 6
    6 7 
     -- | Domain types used in "GHC.HsToCore.Pmc.Solver".
    7 8 
     -- The ultimate goal is to define 'Nabla', which models normalised refinement
    ... ... @@ -32,7 +33,7 @@ module GHC.HsToCore.Pmc.Solver.Types (
    32 33 
             PmEquality(..), eqPmAltCon,
    33 34
    34 35 
             -- *** Operations on 'PmLit'
    35 
    -        literalToPmLit, negatePmLit, overloadPmLit,
    36 
    +        literalToPmLit, negatePmLit,
    36 37 
             pmLitAsStringLit, coreExprAsPmLit
    37 38
    38 39 
         ) where
    ... ... @@ -51,13 +52,12 @@ import GHC.Core.ConLike
    51 52 
     import GHC.Utils.Outputable
    52 53 
     import GHC.Utils.Panic.Plain
    53 54 
     import GHC.Utils.Misc (lastMaybe)
    54 
    -import GHC.Data.List.SetOps (unionLists)
    55 55 
     import GHC.Data.Maybe
    56 56 
     import GHC.Core.Type
    57 57 
     import GHC.Core.TyCon
    58 58 
     import GHC.Types.Literal
    59 59 
     import GHC.Core
    60 
    -import GHC.Core.TyCo.Compare( eqType )
    60 
    +import GHC.Core.TyCo.Compare( eqType, nonDetCmpType )
    61 61 
     import GHC.Core.Map.Expr
    62 62 
     import GHC.Core.Utils (exprType)
    63 63 
     import GHC.Builtin.Names
    ... ... @@ -69,15 +69,14 @@ import GHC.Types.CompleteMatch
    69 69 
     import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit
    70 70 
                                 , fractionalLitFromRational
    71 71 
                                 , FractionalExponentBase(..))
    72 
    +
    72 73 
     import Numeric (fromRat)
    73 
    -import Data.Foldable (find)
    74 74 
     import Data.Ratio
    75 
    +import Data.List( find )
    76 
    +import qualified Data.Map as FM
    75 77 
     import GHC.Real (Ratio(..))
    76 
    -import qualified Data.Semigroup as Semi
    77 
    -
    78 
    --- import GHC.Driver.Ppr
    78 
    +import qualified Data.Semigroup as S
    79 79
    80 
    ---
    81 80 
     -- * Normalised refinement types
    82 81 
     --
    83 82
    ... ... @@ -358,6 +357,13 @@ lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of
    358 357 
         | Just sol <- find isDataConSolution pos -> Just sol
    359 358 
         | otherwise                              -> Just x
    360 359
    360 
    +
    361 
    +{- *********************************************************************
    362 
    +*                                                                      *
    363 
    +                 PmLit and PmLitValue
    364 
    +*                                                                      *
    365 
    +********************************************************************* -}
    366 
    +
    361 367 
     --------------------------------------------------------------------------------
    362 368 
     -- The rest is just providing an IR for (overloaded!) literals and AltCons that
    363 369 
     -- sits between Hs and Core. We need a reliable way to detect and determine
    ... ... @@ -376,13 +382,64 @@ data PmLitValue
    376 382 
       = PmLitInt Integer
    377 383 
       | PmLitRat Rational
    378 384 
       | PmLitChar Char
    379 
    -  -- We won't actually see PmLitString in the oracle since we desugar strings to
    380 
    -  -- lists
    381 385 
       | PmLitString FastString
    386 
    +       -- We won't actually see PmLitString in the oracle
    387 
    +       -- since we desugar strings to lists
    388 
    +
    389 
    +  -- Overloaded literals
    382 390 
       | PmLitOverInt Int {- How often Negated? -} Integer
    383 391 
       | PmLitOverRat Int {- How often Negated? -} FractionalLit
    384 392 
       | PmLitOverString FastString
    385 393
    394 
    +-- | Syntactic equality.
    395 
    +-- We want (Ord PmLit) so that we can use (Map PmLit x) in `PmAltConSet`
    396 
    +instance Eq PmLit where
    397 
    +  a == b = (a `compare` b) == EQ
    398 
    +instance Ord PmLit where
    399 
    +  compare = cmpPmLit
    400 
    +
    401 
    +cmpPmLit :: PmLit -> PmLit -> Ordering
    402 
    +-- This function does "syntactic comparison":
    403 
    +--   For overloaded literals, compare the type and value
    404 
    +--   For non-overloaded literals, just compare the values
    405 
    +-- But it treats (say)
    406 
    +--    (PmLit Bool (PmLitOverInt 1))
    407 
    +--    (PmLit Bool (PmLitOverInt 2))
    408 
    +-- as un-equal, even through (fromInteger @Bool 1)
    409 
    +-- could be the same as (fromInteger @Bool 2)
    410 
    +cmpPmLit (PmLit { pm_lit_ty = t1, pm_lit_val = val1 })
    411 
    +         (PmLit { pm_lit_ty = t2, pm_lit_val = val2 })
    412 
    +  = case (val1,val2) of
    413 
    +      (PmLitInt i1, PmLitInt i2) -> i1 `compare` i2
    414 
    +      (PmLitRat r1, PmLitRat r2) -> r1 `compare` r2
    415 
    +      (PmLitChar c1, PmLitChar c2) -> c1 `compare` c2
    416 
    +      (PmLitString s1, PmLitString s2) -> s1 `uniqCompareFS` s2
    417 
    +      (PmLitOverInt n1 i1, PmLitOverInt n2 i2) -> (n1 `compare` n2) S.<>
    418 
    +                                                  (i1 `compare` i2) S.<>
    419 
    +                                                  (t1 `nonDetCmpType` t2)
    420 
    +      (PmLitOverRat n1 r1, PmLitOverRat n2 r2) -> (n1 `compare` n2) S.<>
    421 
    +                                                  (r1 `compare` r2) S.<>
    422 
    +                                                  (t1 `nonDetCmpType` t2)
    423 
    +      (PmLitOverString s1, PmLitOverString s2) -> (s1 `uniqCompareFS` s2) S.<>
    424 
    +                                                  (t1 `nonDetCmpType` t2)
    425 
    +      (PmLitInt {},    _) -> LT
    426 
    +      (PmLitRat {},    PmLitInt {})  -> GT
    427 
    +      (PmLitRat {},    _)            -> LT
    428 
    +      (PmLitChar {},   PmLitInt {})  -> GT
    429 
    +      (PmLitChar {},   PmLitRat {})  -> GT
    430 
    +      (PmLitChar {},   _)            -> LT
    431 
    +      (PmLitString {}, PmLitInt {})  -> GT
    432 
    +      (PmLitString {}, PmLitRat {})  -> GT
    433 
    +      (PmLitString {}, PmLitChar {}) -> GT
    434 
    +      (PmLitString {}, _)            -> LT
    435 
    +
    436 
    +      (PmLitOverString {}, _)                 -> GT
    437 
    +      (PmLitOverRat {},    PmLitOverString{}) -> LT
    438 
    +      (PmLitOverRat {},    _)                 -> GT
    439 
    +      (PmLitOverInt {},    PmLitOverString{}) -> LT
    440 
    +      (PmLitOverInt {},    PmLitOverRat{})    -> LT
    441 
    +      (PmLitOverInt {},    _)                 -> GT
    442 
    +
    386 443 
     -- | Undecidable semantic equality result.
    387 444 
     -- See Note [Undecidable Equality for PmAltCons]
    388 445 
     data PmEquality
    ... ... @@ -406,7 +463,10 @@ eqPmLit :: PmLit -> PmLit -> PmEquality
    406 463 
     eqPmLit (PmLit t1 v1) (PmLit t2 v2)
    407 464 
       -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined
    408 465 
       | not (t1 `eqType` t2) = Disjoint
    409 
    -  | otherwise            = go v1 v2
    466 
    +  | otherwise            = eqPmLitValue v1 v2
    467 
    +
    468 
    +eqPmLitValue :: PmLitValue -> PmLitValue -> PmEquality
    469 
    +eqPmLitValue v1 v2 = go v1 v2
    410 470 
       where
    411 471 
         go (PmLitInt i1)        (PmLitInt i2)        = decEquality (i1 == i2)
    412 472 
         go (PmLitRat r1)        (PmLitRat r2)        = decEquality (r1 == r2)
    ... ... @@ -420,10 +480,6 @@ eqPmLit (PmLit t1 v1) (PmLit t2 v2)
    420 480 
           | s1 == s2                                 = Equal
    421 481 
         go _                    _                    = PossiblyOverlap
    422 482
    423 
    --- | Syntactic equality.
    424 
    -instance Eq PmLit where
    425 
    -  a == b = eqPmLit a b == Equal
    426 
    -
    427 483 
     -- | Type of a 'PmLit'
    428 484 
     pmLitType :: PmLit -> Type
    429 485 
     pmLitType (PmLit ty _) = ty
    ... ... @@ -445,34 +501,47 @@ eqConLike (PatSynCon psc1) (PatSynCon psc2)
    445 501 
       = Equal
    446 502 
     eqConLike _                 _                 = PossiblyOverlap
    447 503
    504 
    +
    505 
    +{- *********************************************************************
    506 
    +*                                                                      *
    507 
    +                 PmAltCon and PmAltConSet
    508 
    +*                                                                      *
    509 
    +********************************************************************* -}
    510 
    +
    448 511 
     -- | Represents the head of a match against a 'ConLike' or literal.
    449 512 
     -- Really similar to 'GHC.Core.AltCon'.
    450 513 
     data PmAltCon = PmAltConLike ConLike
    451 514 
                   | PmAltLit     PmLit
    452 515
    453 
    -data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit]
    516 
    +data PmAltConSet = PACS !(UniqDSet ConLike)
    517 
    +                        !(FM.Map PmLit PmLit)
    518 
    +-- We use a (FM.Map PmLit PmLit) here, at the cost of requiring an Ord
    519 
    +-- instance for PmLit, because in extreme cases the set of PmLits can be
    520 
    +-- very large.  See #26514.
    454 521
    455 522 
     emptyPmAltConSet :: PmAltConSet
    456 
    -emptyPmAltConSet = PACS emptyUniqDSet []
    523 
    +emptyPmAltConSet = PACS emptyUniqDSet FM.empty
    457 524
    458 525 
     isEmptyPmAltConSet :: PmAltConSet -> Bool
    459 
    -isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits
    526 
    +isEmptyPmAltConSet (PACS cls lits)
    527 
    +  = isEmptyUniqDSet cls && FM.null lits
    460 528
    461 529 
     -- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to
    462 530 
     -- the given 'PmAltCon' according to 'eqPmAltCon'.
    463 531 
     elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool
    464 532 
     elemPmAltConSet (PmAltConLike cl) (PACS cls _   ) = elementOfUniqDSet cl cls
    465 
    -elemPmAltConSet (PmAltLit lit)    (PACS _   lits) = elem lit lits
    533 
    +elemPmAltConSet (PmAltLit lit)    (PACS _   lits) = isJust (FM.lookup lit lits)
    466 534
    467 535 
     extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet
    468 536 
     extendPmAltConSet (PACS cls lits) (PmAltConLike cl)
    469 537 
       = PACS (addOneToUniqDSet cls cl) lits
    470 538 
     extendPmAltConSet (PACS cls lits) (PmAltLit lit)
    471 
    -  = PACS cls (unionLists lits [lit])
    539 
    +  = PACS cls (FM.insert lit lit lits)
    472 540
    473 541 
     pmAltConSetElems :: PmAltConSet -> [PmAltCon]
    474 542 
     pmAltConSetElems (PACS cls lits)
    475 
    -  = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits
    543 
    +  = map PmAltConLike (uniqDSetToList cls) ++
    544 
    +    FM.foldr ((:) . PmAltLit) [] lits
    476 545
    477 546 
     instance Outputable PmAltConSet where
    478 547 
       ppr = ppr . pmAltConSetElems

  • compiler/GHC/Types/SourceText.hs
    ... ... @@ -188,6 +188,7 @@ data FractionalLit = FL
    188 188 
         }
    189 189 
         deriving (Data, Show)
    190 190 
       -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on
    191 
    +  -- Eq and Ord instances are done explicitly
    191 192
    192 193 
     -- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal
    193 194 
     data FractionalExponentBase

  • libraries/base/base.cabal.in
    ... ... @@ -303,6 +303,7 @@ Library
    303 303 
                 , GHC.JS.Foreign.Callback
    304 304
    305 305 
         other-modules:
    306 
    +        Data.List.NubOrdSet
    306 307 
             System.CPUTime.Unsupported
    307 308 
             System.CPUTime.Utils
    308 309 
         if os(windows)

  • libraries/base/changelog.md
    ... ... @@ -10,6 +10,7 @@
    10 10 
       * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350))
    11 11 
       * Remove extra laziness from `Data.Bifunctor.Bifunctor` instances for all tuples to have the same laziness as their `Data.Functor.Functor` counterparts (i.e. they became more strict than before) ([CLC proposal #339](https://github.com/haskell/core-libraries-committee/issues/339))
    12 12 
       * Adjust the strictness of `Data.List.iterate'` to be more reasonable: every element of the output list is forced to WHNF when the `(:)` containing it is forced. ([CLC proposal #335)](https://github.com/haskell/core-libraries-committee/issues/335)
    13 
    +  * Add `nubOrd` / `nubOrdBy` to `Data.List` and `Data.List.NonEmpty`. ([CLC proposal #336](https://github.com/haskell/core-libraries-committee/issues/336))
    13 14
    14 15 
     ## 4.22.0.0 *TBA*
    15 16 
       * Shipped with GHC 9.14.1

  • libraries/base/src/Data/List.hs
    ... ... @@ -137,6 +137,7 @@ module Data.List
    137 137 
          unwords,
    138 138 
          -- **  \"Set\" operations
    139 139 
          nub,
    140 
    +     nubOrd,
    140 141 
          delete,
    141 142 
          (\\),
    142 143 
          union,
    ... ... @@ -157,6 +158,7 @@ module Data.List
    157 158 
          -- ***  User-supplied equality (replacing an @Eq@ context)
    158 159 
          -- |  The predicate is assumed to define an equivalence.
    159 160 
          nubBy,
    161 
    +     nubOrdBy,
    160 162 
          deleteBy,
    161 163 
          deleteFirstsBy,
    162 164 
          unionBy,
    ... ... @@ -180,12 +182,14 @@ module Data.List
    180 182 
          ) where
    181 183
    182 184 
     import GHC.Internal.Data.Bool (otherwise)
    185 
    +import GHC.Internal.Data.Function (const)
    183 186 
     import GHC.Internal.Data.List
    184 187 
     import GHC.Internal.Data.List.NonEmpty (NonEmpty(..))
    185 
    -import GHC.Internal.Data.Ord (Ordering(..), (<), (>))
    188 
    +import GHC.Internal.Data.Ord (Ord, compare, Ordering(..), (<), (>))
    186 189 
     import GHC.Internal.Int (Int)
    187 190 
     import GHC.Internal.Num ((-))
    188 191 
     import GHC.List (build)
    192 
    +import qualified Data.List.NubOrdSet as NubOrdSet
    189 193
    190 194 
     inits1, tails1 :: [a] -> [NonEmpty a]
    191 195
    ... ... @@ -282,3 +286,24 @@ compareLength xs n
    282 286 
         (\m -> if m > 0 then LT else EQ)
    283 287 
         xs
    284 288 
         n
    289 
    +
    290 
    +-- | Same as 'nub', but asymptotically faster, taking only /O/(/n/ log /n/) time.
    291 
    +--
    292 
    +-- @since 4.23.0.0
    293 
    +nubOrd :: Ord a => [a] -> [a]
    294 
    +nubOrd = nubOrdBy compare
    295 
    +{-# INLINE nubOrd #-}
    296 
    +
    297 
    +-- | Overloaded version of 'Data.List.nubOrd'.
    298 
    +--
    299 
    +-- The supplied comparison relation is supposed to be reflexive, transitive
    300 
    +-- and antisymmetric, same as for 'sortBy'.
    301 
    +--
    302 
    +-- @since 4.23.0.0
    303 
    +nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a]
    304 
    +nubOrdBy cmp xs = foldr
    305 
    +  (\x acc seen -> if NubOrdSet.member cmp x seen then acc seen else x : acc (NubOrdSet.insert cmp x seen))
    306 
    +  (const [])
    307 
    +  xs
    308 
    +  NubOrdSet.empty
    309 
    +{-# INLINE nubOrdBy #-}

  • libraries/base/src/Data/List/NonEmpty.hs
    ... ... @@ -94,7 +94,9 @@ module Data.List.NonEmpty (
    94 94 
        , isPrefixOf  -- :: Eq a => [a] -> NonEmpty a -> Bool
    95 95 
        -- * \"Set\" operations
    96 96 
        , nub         -- :: Eq a => NonEmpty a -> NonEmpty a
    97 
    +   , nubOrd      -- :: Ord a => NonEmpty a -> NonEmpty a
    97 98 
        , nubBy       -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a
    99 
    +   , nubOrdBy    -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
    98 100 
        -- * Indexing streams
    99 101 
        , (!!)        -- :: NonEmpty a -> Int -> a
    100 102 
        -- * Zipping and unzipping streams
    ... ... @@ -119,6 +121,7 @@ import qualified Prelude
    119 121
    120 122 
     import           Control.Applicative (Applicative (..), Alternative (many))
    121 123 
     import qualified Data.List                        as List
    124 
    +import qualified Data.List.NubOrdSet              as NubOrdSet
    122 125 
     import qualified Data.Maybe                       as List (mapMaybe)
    123 126 
     import           GHC.Internal.Data.Foldable       hiding (length, toList)
    124 127 
     import qualified GHC.Internal.Data.Foldable       as Foldable
    ... ... @@ -577,6 +580,24 @@ nub = nubBy (==)
    577 580 
     nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a
    578 581 
     nubBy eq (a :| as) = a :| List.nubBy eq (List.filter (\b -> not (eq a b)) as)
    579 582
    583 
    +-- | Same as 'nub', but asymptotically faster, taking only /O/(/n/ log /n/) time.
    584 
    +--
    585 
    +-- @since 4.23.0.0
    586 
    +nubOrd :: Ord a => NonEmpty a -> NonEmpty a
    587 
    +nubOrd = nubOrdBy compare
    588 
    +{-# INLINE nubOrd #-}
    589 
    +
    590 
    +-- | Overloaded version of 'Data.List.NonEmpty.nubOrd'.
    591 
    +--
    592 
    +-- @since 4.23.0.0
    593 
    +nubOrdBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
    594 
    +nubOrdBy cmp (y :| ys) = y :| foldr
    595 
    +  (\x acc seen -> if NubOrdSet.member cmp x seen then acc seen else x : acc (NubOrdSet.insert cmp x seen))
    596 
    +  (const [])
    597 
    +  ys
    598 
    +  (NubOrdSet.insert cmp y NubOrdSet.empty)
    599 
    +{-# INLINE nubOrdBy #-}
    600 
    +
    580 601 
     -- | 'transpose' for 'NonEmpty', behaves the same as 'GHC.Internal.Data.List.transpose'
    581 602 
     -- The rows/columns need not be the same length, in which case
    582 603 
     -- > transpose . transpose /= id

  • libraries/base/src/Data/List/NubOrdSet.hs
    1 
    +-- This is an internal module with a naive set implementation,
    2 
    +-- solely for the purposes of `Data.List.{,NonEmpty.}nubOrd{,By}`.
    3 
    +
    4 
    +{-# LANGUAGE BangPatterns #-}
    5 
    +{-# LANGUAGE LambdaCase #-}
    6 
    +
    7 
    +module Data.List.NubOrdSet (
    8 
    +  NubOrdSet,
    9 
    +  empty,
    10 
    +  member,
    11 
    +  insert,
    12 
    +) where
    13 
    +
    14 
    +import GHC.Internal.Data.Bool (Bool(..))
    15 
    +import GHC.Internal.Data.Function ((.))
    16 
    +import GHC.Internal.Data.Ord (Ordering(..))
    17 
    +
    18 
    +-- | Implemented as a red-black tree, a la Okasaki.
    19 
    +data NubOrdSet a
    20 
    +  = Empty
    21 
    +  | NodeRed !(NubOrdSet a) !a !(NubOrdSet a)
    22 
    +  | NodeBlack !(NubOrdSet a) !a !(NubOrdSet a)
    23 
    +
    24 
    +empty :: NubOrdSet a
    25 
    +empty = Empty
    26 
    +
    27 
    +member :: (a -> a -> Ordering) -> a -> NubOrdSet a -> Bool
    28 
    +member cmp = member'
    29 
    +  where
    30 
    +    member' !x = go
    31 
    +      where
    32 
    +        go = \case
    33 
    +          Empty -> False
    34 
    +          NodeRed left center right -> chooseWay left center right
    35 
    +          NodeBlack left center right -> chooseWay left center right
    36 
    +
    37 
    +        chooseWay left center right = case cmp x center of
    38 
    +            LT -> go left
    39 
    +            EQ -> True
    40 
    +            GT -> go right
    41 
    +{-# INLINE member #-}
    42 
    +
    43 
    +insert :: (a -> a -> Ordering) -> a -> NubOrdSet a -> NubOrdSet a
    44 
    +insert cmp = insert'
    45 
    +  where
    46 
    +    insert' !x = blacken . go
    47 
    +      where
    48 
    +        go node = case node of
    49 
    +          Empty -> NodeRed Empty x Empty
    50 
    +          NodeRed left center right -> case cmp x center of
    51 
    +            LT -> NodeRed (go left) center right
    52 
    +            EQ -> node
    53 
    +            GT -> NodeRed left center (go right)
    54 
    +          NodeBlack left center right -> case cmp x center of
    55 
    +            LT -> balanceBlackLeft (go left) center right
    56 
    +            EQ -> node
    57 
    +            GT -> balanceBlackRight left center (go right)
    58 
    +
    59 
    +    blacken node = case node of
    60 
    +      Empty -> Empty
    61 
    +      NodeRed left center right -> NodeBlack left center right
    62 
    +      NodeBlack{} -> node
    63 
    +{-# INLINE insert #-}
    64 
    +
    65 
    +balanceBlackLeft :: NubOrdSet a -> a -> NubOrdSet a -> NubOrdSet a
    66 
    +balanceBlackLeft (NodeRed (NodeRed a b c) d e) f g =
    67 
    +  NodeRed (NodeBlack a b c) d (NodeBlack e f g)
    68 
    +balanceBlackLeft (NodeRed a b (NodeRed c d e)) f g =
    69 
    +  NodeRed (NodeBlack a b c) d (NodeBlack e f g)
    70 
    +balanceBlackLeft left center right =
    71 
    +  NodeBlack left center right
    72 
    +{-# INLINE balanceBlackLeft #-}
    73 
    +
    74 
    +balanceBlackRight :: NubOrdSet a -> a -> NubOrdSet a -> NubOrdSet a
    75 
    +balanceBlackRight a b (NodeRed (NodeRed c d e) f g) =
    76 
    +  NodeRed (NodeBlack a b c) d (NodeBlack e f g)
    77 
    +balanceBlackRight a b (NodeRed c d (NodeRed e f g)) =
    78 
    +  NodeRed (NodeBlack a b c) d (NodeBlack e f g)
    79 
    +balanceBlackRight left center right =
    80 
    +  NodeBlack left center right
    81 
    +{-# INLINE balanceBlackRight #-}

  • libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs
    ... ... @@ -499,16 +499,7 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
    499 499 
     -- name 'nub' means \`essence\'.) It is a special case of 'nubBy', which allows
    500 500 
     -- the programmer to supply their own equality test.
    501 501 
     --
    502 
    ---
    503 
    --- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package
    504 
    --- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)),
    505 
    --- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of
    506 
    --- distinct elements in the list.
    507 
    ---
    508 
    --- Another approach to speed up 'nub' is to use
    509 
    --- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort',
    510 
    --- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't
    511 
    --- preserve the order.
    502 
    +-- If there exists @instance Ord a@, it's faster to use 'Data.List.nubOrd'.
    512 503 
     --
    513 504 
     -- ==== __Examples__
    514 505 
     --

  • testsuite/tests/interface-stability/base-exports.stdout
    ... ... @@ -1379,6 +1379,8 @@ module Data.List where
    1379 1379 
       notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool
    1380 1380 
       nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a]
    1381 1381 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a]
    1382 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a]
    1383 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a]
    1382 1384 
       null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool
    1383 1385 
       or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
    1384 1386 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a])
    ... ... @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where
    1473 1475 
       nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
    1474 1476 
       nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
    1475 1477 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
    1478 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a
    1479 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a
    1476 1480 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a])
    1477 1481 
       permutations :: forall a. [a] -> NonEmpty [a]
    1478 1482 
       permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a)

  • testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
    ... ... @@ -1379,6 +1379,8 @@ module Data.List where
    1379 1379 
       notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool
    1380 1380 
       nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a]
    1381 1381 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a]
    1382 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a]
    1383 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a]
    1382 1384 
       null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool
    1383 1385 
       or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
    1384 1386 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a])
    ... ... @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where
    1473 1475 
       nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
    1474 1476 
       nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
    1475 1477 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
    1478 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a
    1479 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a
    1476 1480 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a])
    1477 1481 
       permutations :: forall a. [a] -> NonEmpty [a]
    1478 1482 
       permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a)

  • testsuite/tests/interface-stability/base-exports.stdout-mingw32
    ... ... @@ -1379,6 +1379,8 @@ module Data.List where
    1379 1379 
       notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool
    1380 1380 
       nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a]
    1381 1381 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a]
    1382 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a]
    1383 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a]
    1382 1384 
       null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool
    1383 1385 
       or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
    1384 1386 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a])
    ... ... @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where
    1473 1475 
       nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
    1474 1476 
       nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
    1475 1477 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
    1478 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a
    1479 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a
    1476 1480 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a])
    1477 1481 
       permutations :: forall a. [a] -> NonEmpty [a]
    1478 1482 
       permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a)

  • testsuite/tests/interface-stability/base-exports.stdout-ws-32
    ... ... @@ -1379,6 +1379,8 @@ module Data.List where
    1379 1379 
       notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool
    1380 1380 
       nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a]
    1381 1381 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a]
    1382 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a]
    1383 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a]
    1382 1384 
       null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool
    1383 1385 
       or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
    1384 1386 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a])
    ... ... @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where
    1473 1475 
       nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
    1474 1476 
       nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
    1475 1477 
       nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
    1478 
    +  nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a
    1479 
    +  nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a
    1476 1480 
       partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a])
    1477 1481 
       permutations :: forall a. [a] -> NonEmpty [a]
    1478 1482 
       permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a)

  • testsuite/tests/linear/should_run/T26311.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +
    3 
    +module Main where
    4 
    +
    5 
    +import GHC.Exts ( Int# )
    6 
    +
    7 
    +expensive :: Int -> Int#
    8 
    +expensive 0 = 2#
    9 
    +expensive i = expensive (i-1)
    10 
    +
    11 
    +data D = MkD Int# Int
    12 
    +
    13 
    +f :: a -> Bool
    14 
    +f _ = False
    15 
    +{-# NOINLINE f #-}
    16 
    +
    17 
    +{-# RULES "f/MkD" forall x. f (MkD x) = True #-}
    18 
    +
    19 
    +bar :: Bool
    20 
    +bar = f (MkD (expensive 10))
    21 
    +
    22 
    +main :: IO ()
    23 
    +main = print bar

  • testsuite/tests/linear/should_run/T26311.stdout
    1 
    +True

  • testsuite/tests/linear/should_run/all.T
    1 1 
     test('LinearTypeable', normal, compile_and_run, [''])
    2 
    +test('T26311', normal, compile_and_run, ['-O1'])
    2 3 
     test('LinearGhci', normal, ghci_script, ['LinearGhci.script'])

  • testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
    1 
    -
    2 1 
     pmcOrPats.hs:10:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
    3 2 
         Pattern match(es) are non-exhaustive
    4 3 
         In an equation for ‘g’: Patterns of type ‘T’, ‘U’ not matched: A W
    ... ... @@ -18,7 +17,7 @@ pmcOrPats.hs:15:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
    18 17 
     pmcOrPats.hs:17:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
    19 18 
         Pattern match(es) are non-exhaustive
    20 19 
         In an equation for ‘z’:
    21 
    -        Patterns of type ‘a’ not matched: p where p is not one of {3, 1, 2}
    20 
    +        Patterns of type ‘a’ not matched: p where p is not one of {1, 2, 3}
    22 21
    23 22 
     pmcOrPats.hs:19:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
    24 23 
         Pattern match is redundant
    ... ... @@ -43,3 +42,4 @@ pmcOrPats.hs:21:1: warning: [GHC-61505]
    43 42 
           • Patterns reported as unmatched might actually be matched
    44 43 
         Suggested fix:
    45 44 
           Increase the limit or resolve the warnings to suppress this message.
    45 
    +

  • testsuite/tests/rep-poly/T26072b.hs
    1 
    +{-# LANGUAGE AllowAmbiguousTypes #-}
    2 
    +{-# LANGUAGE BangPatterns #-}
    3 
    +{-# LANGUAGE BlockArguments #-}
    4 
    +{-# LANGUAGE DataKinds #-}
    5 
    +{-# LANGUAGE MagicHash #-}
    6 
    +{-# LANGUAGE PolyKinds #-}
    7 
    +{-# LANGUAGE ScopedTypeVariables #-}
    8 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    9 
    +{-# LANGUAGE TypeApplications #-}
    10 
    +{-# LANGUAGE TypeFamilies #-}
    11 
    +{-# LANGUAGE UnboxedTuples #-}
    12 
    +
    13 
    +module T26072b where
    14 
    +
    15 
    +-- base
    16 
    +import Data.Kind
    17 
    +import GHC.TypeNats
    18 
    +import GHC.Exts
    19 
    +  ( TYPE, RuntimeRep(..), LiftedRep
    20 
    +  , proxy#
    21 
    +  )
    22 
    +
    23 
    +--------------------------------------------------------------------------------
    24 
    +
    25 
    +-- Stub for functions in 'primitive' (to avoid dependency)
    26 
    +type PrimArray :: Type -> Type
    27 
    +data PrimArray a = MkPrimArray
    28 
    +
    29 
    +indexPrimArray :: PrimArray a -> Int -> a
    30 
    +indexPrimArray _ _ = error "unimplemented"
    31 
    +{-# NOINLINE indexPrimArray #-}
    32 
    +
    33 
    +--------------------------------------------------------------------------------
    34 
    +
    35 
    +int :: forall n. KnownNat n => Int
    36 
    +int = fromIntegral ( natVal' @n proxy# )
    37 
    +
    38 
    +type Fin :: Nat -> Type
    39 
    +newtype Fin n = Fin { getFin :: Int }
    40 
    +
    41 
    +-- Vector
    42 
    +type V :: Nat -> Type -> Type
    43 
    +newtype V n a = V ( PrimArray a )
    44 
    +
    45 
    +-- Matrix
    46 
    +type M :: Nat -> Type -> Type
    47 
    +newtype M n a = M ( PrimArray a )
    48 
    +
    49 
    +type IndexRep :: (Type -> Type) -> RuntimeRep
    50 
    +type family IndexRep f
    51 
    +class Ix f where
    52 
    +  type Index f :: TYPE (IndexRep f)
    53 
    +  (!) :: f a -> Index f -> a
    54 
    +  infixl 9 !
    55 
    +
    56 
    +type instance IndexRep ( V n ) = LiftedRep
    57 
    +instance Ix ( V n ) where
    58 
    +  type Index ( V n ) = Fin n
    59 
    +  V v ! Fin !i = indexPrimArray v i
    60 
    +  {-# INLINE (!) #-}
    61 
    +
    62 
    +type instance IndexRep ( M m ) = TupleRep [ LiftedRep, LiftedRep ]
    63 
    +
    64 
    +instance KnownNat n => Ix ( M n ) where
    65 
    +  type Index ( M n ) = (# Fin n, Fin n #)
    66 
    +  M m ! (# Fin !i, Fin !j #) = indexPrimArray m ( i + j * int @n )
    67 
    +  {-# INLINE (!) #-}
    68 
    +
    69 
    +rowCol :: forall n a. ( KnownNat n, Num a ) => Fin n -> M n a -> V n a -> a
    70 
    +rowCol i m v = go 0 ( Fin 0 )
    71 
    +  where
    72 
    +    n = int @n
    73 
    +    go :: a -> Fin n -> a
    74 
    +    go !acc j@( Fin !j_ )
    75 
    +      | j_ >= n
    76 
    +      = acc
    77 
    +      | otherwise
    78 
    +      = go ( acc + m ! (# i , j #) * v ! j ) ( Fin ( j_ + 1 ) )

  • testsuite/tests/rep-poly/all.T
    ... ... @@ -127,6 +127,7 @@ test('T17536b', normal, compile, ['']) ##
    127 127 
     test('T21650_a', js_broken(26578), compile, ['-Wno-deprecated-flags'])       ##
    128 128 
     test('T21650_b', js_broken(26578), compile, ['-Wno-deprecated-flags'])       ##
    129 129 
     test('T26072', js_broken(26578), compile, [''])                              ##
    130 
    +test('T26072b', js_broken(26578), compile, [''])                             ##
    130 131 
     test('RepPolyArgument2', normal, compile, [''])                              ##
    131 132 
     test('RepPolyCase2', js_broken(26578), compile, [''])                        ##
    132 133 
     test('RepPolyRule3', normal, compile, [''])                                  ##

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help