base 4.10.1.0 → 4.11.0.0

raw patch · 132 files changed

+4080/−2492 lines, 132 filesdep ~ghc-primdep ~integer-gmpdep ~integer-simplePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-prim, integer-gmp, integer-simple, rts

API changes (from Hackage documentation)

Files

• Control/Applicative.hs +7/−2
• Control/Category.hs +7/−2
• Control/Concurrent.hs +9/−11
• Control/Concurrent/Chan.hs +2/−23
• Control/Concurrent/MVar.hs +3/−3
• Control/Exception.hs +1/−1
• Control/Exception/Base.hs +1/−0
• Control/Monad.hs +56/−17
• Control/Monad/Fix.hs +9/−1
• Control/Monad/ST.hs +1/−1
• Control/Monad/ST/Lazy/Imp.hs +1/−1
• Control/Monad/Zip.hs +7/−0
• Data/Bifoldable.hs +1/−1
• Data/Bifunctor.hs +36/−1
• Data/Bits.hs +3/−7
• Data/Char.hs +2/−0
• Data/Complex.hs +2/−1
• Data/Data.hs +30/−7
• Data/Either.hs +12/−9
• Data/Foldable.hs +15/−0
• Data/Function.hs +23/−2
• Data/Functor.hs +26/−0
• Data/Functor/Classes.hs +22/−0
• Data/Functor/Const.hs +2/−2
• Data/Functor/Identity.hs +2/−2
• Data/Functor/Utils.hs +20/−16
• Data/List.hs +1/−0
• Data/List/NonEmpty.hs +3/−84
• Data/Maybe.hs +6/−3
• Data/Monoid.hs +22/−127
• Data/OldList.hs +169/−43
• Data/Ord.hs +24/−3
• Data/Proxy.hs +47/−7
• Data/Ratio.hs +27/−22
• Data/STRef.hs +20/−6
• Data/Semigroup.hs +15/−270
• Data/Semigroup/Internal.hs +264/−0
• Data/Semigroup/Internal.hs-boot +12/−0
• Data/Traversable.hs +7/−3
• Data/Tuple.hs +20/−1
• Data/Type/Coercion.hs +1/−2
• Data/Type/Equality.hs +46/−165
• Data/Typeable.hs +0/−18
• Data/Typeable/Internal.hs +331/−57
• Data/Unique.hs +10/−1
• Data/Void.hs +26/−21
• Data/Word.hs +3/−2
• Debug/Trace.hs +45/−20
• Debug/Trace.hs-boot +76/−0
• Foreign/C/String.hs +1/−1
• Foreign/ForeignPtr.hs +3/−0
• Foreign/Marshal/Alloc.hs +0/−17
• GHC/Base.hs +230/−70
• GHC/Base.hs-boot +10/−0
• GHC/ByteOrder.hs +31/−0
• GHC/Clock.hsc +25/−0
• GHC/Conc.hs +4/−4
• GHC/Conc/IO.hs +11/−11
• GHC/Conc/Sync.hs +48/−34
• GHC/Conc/Windows.hs +1/−1
• GHC/Environment.hs +10/−37
• GHC/Event/Clock.hsc +0/−17
• GHC/Event/EPoll.hsc +4/−2
• GHC/Event/Internal.hs +18/−5
• GHC/Event/KQueue.hsc +28/−32
• GHC/Event/PSQ.hs +346/−378
• GHC/Event/Poll.hsc +5/−3
• GHC/Event/TimerManager.hs +23/−12
• GHC/Exception.hs +6/−6
• GHC/Exts.hs +9/−0
• GHC/Float.hs +90/−1
• GHC/Foreign.hs +0/−1
• GHC/Generics.hs +60/−34
• GHC/IO/Buffer.hs +9/−8
• GHC/IO/Encoding.hs +12/−0
• GHC/IO/Encoding/CodePage.hs +1/−1
• GHC/IO/Encoding/CodePage/API.hs +7/−7
• GHC/IO/Encoding/Iconv.hs +1/−1
• GHC/IO/Exception.hs +10/−0
• GHC/IO/FD.hs +21/−25
• GHC/IO/Handle.hs +1/−1
• GHC/IO/Handle/FD.hs +3/−3
• GHC/IO/Handle/Lock.hsc +32/−3
• GHC/IO/Handle/Text.hs +1/−1
• GHC/IO/Handle/Types.hs +3/−3
• GHC/IORef.hs +4/−5
• GHC/List.hs +52/−26
• GHC/MVar.hs +1/−1
• GHC/Natural.hs +26/−19
• GHC/RTS/Flags.hsc +83/−37
• GHC/Read.hs +72/−1
• GHC/Real.hs +12/−9
• GHC/Real.hs-boot +7/−0
• GHC/ST.hs +13/−0
• GHC/STRef.hs +15/−2
• GHC/Show.hs +40/−1
• GHC/Stack.hs +4/−1
• GHC/Stack/CCS.hsc +17/−0
• GHC/Stack/Types.hs +16/−15
• GHC/StaticPtr.hs +5/−0
• GHC/Stats.hsc +18/−135
• GHC/TopHandler.hs +4/−4
• GHC/TypeLits.hs +3/−8
• GHC/TypeNats.hs +30/−9
• GHC/Word.hs +0/−21
• Numeric.hs +57/−0
• Prelude.hs +2/−1
• System/Environment.hs +23/−103
• System/Environment/Blank.hsc +196/−0
• System/Environment/ExecutablePath.hsc +80/−5
• System/IO.hs +81/−40
• System/Posix/Internals.hs +3/−3
• System/Timeout.hs +8/−3
• Text/ParserCombinators/ReadP.hs +55/−74
• Text/Printf.hs +47/−53
• Text/Read.hs +21/−1
• Type/Reflection/Unsafe.hs +10/−1
• base.cabal +15/−9
• cbits/SetEnv.c +2/−2
• cbits/Win32Utils.c +44/−1
• cbits/iconv.c +1/−1
• cbits/inputReady.c +345/−150
• cbits/primFloat.c +2/−2
• changelog.md +79/−0
• configure +4/−2
• configure.ac +3/−3
• include/CTypes.h +1/−4
• include/HsBase.h +29/−33
• include/WCsubst.h +1/−6
• include/consUtils.h +2/−3
• include/ieee-flpt.h +7/−7
• include/md5.h +1/−7

@@ -59,7 +59,7 @@  import GHC.Base import GHC.Generics-import GHC.List (repeat, zipWith)+import GHC.List (repeat, zipWith, drop) import GHC.Read (Read) import GHC.Show (Show) @@ -107,7 +107,7 @@  -- | -- > f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsN---       = 'ZipList' (zipWithN f xs1 ... xsN)+-- >     = 'ZipList' (zipWithN f xs1 ... xsN) -- -- where @zipWithN@ refers to the @zipWith@ function of the appropriate arity -- (@zipWith@, @zipWith3@, @zipWith4@, ...). For example:@@ -120,6 +120,11 @@ instance Applicative ZipList where     pure x = ZipList (repeat x)     liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)++-- | @since 4.11.0.0+instance Alternative ZipList where+   empty = ZipList []+   ZipList xs <|> ZipList ys = ZipList (xs ++ drop (length xs) ys)  -- extra functions 

@@ -28,8 +28,13 @@ infixr 9 . infixr 1 >>>, <<< --- | A class for categories.---   id and (.) must form a monoid.+-- | A class for categories. Instances should satisfy the laws+--+-- @+-- f '.' 'id'  =  f  -- (right identity)+-- 'id' '.' f  =  f  -- (left identity)+-- f '.' (g '.' h)  =  (f '.' g) '.' h  -- (associativity)+-- @ class Category cat where     -- | the identity morphism     id :: cat a a

@@ -117,10 +117,11 @@ import Foreign.StablePtr import Foreign.C.Types -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) import Foreign.C import System.IO import Data.Functor ( void )+import Data.Int ( Int64 ) #else import qualified GHC.Conc #endif@@ -401,7 +402,7 @@ -- 'GHC.Conc.closeFdWith'. threadWaitRead :: Fd -> IO () threadWaitRead fd-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   -- we have no IO manager implementing threadWaitRead on Windows.   -- fdReady does the right thing, but we have to call it in a   -- separate thread, otherwise threadWaitRead won't be interruptible,@@ -426,7 +427,7 @@ -- 'GHC.Conc.closeFdWith'. threadWaitWrite :: Fd -> IO () threadWaitWrite fd-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   | threaded  = withThread (waitFd fd 1)   | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" #else@@ -441,7 +442,7 @@ -- @since 4.7.0.0 threadWaitReadSTM :: Fd -> IO (STM (), IO ()) threadWaitReadSTM fd-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   | threaded = do v <- newTVarIO Nothing                   mask_ $ void $ forkIO $ do result <- try (waitFd fd 0)                                              atomically (writeTVar v $ Just result)@@ -465,7 +466,7 @@ -- @since 4.7.0.0 threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) threadWaitWriteSTM fd-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   | threaded = do v <- newTVarIO Nothing                   mask_ $ void $ forkIO $ do result <- try (waitFd fd 1)                                              atomically (writeTVar v $ Just result)@@ -481,7 +482,7 @@   = GHC.Conc.threadWaitWriteSTM fd #endif -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool  withThread :: IO a -> IO a@@ -496,13 +497,10 @@ waitFd :: Fd -> CInt -> IO () waitFd fd write = do    throwErrnoIfMinus1_ "fdReady" $-        fdReady (fromIntegral fd) write iNFINITE 0--iNFINITE :: CInt-iNFINITE = 0xFFFFFFFF -- urgh+        fdReady (fromIntegral fd) write (-1) 0  foreign import ccall safe "fdReady"-  fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt+  fdReady :: CInt -> CInt -> Int64 -> CInt -> IO CInt #endif  -- ---------------------------------------------------------------------------

@@ -1,13 +1,12 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Control.Concurrent.Chan -- Copyright   :  (c) The University of Glasgow 2001 -- License     :  BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer  :  libraries@haskell.org -- Stability   :  experimental -- Portability :  non-portable (concurrency)@@ -22,7 +21,7 @@ -----------------------------------------------------------------------------  module Control.Concurrent.Chan-  ( +  (           -- * The 'Chan' type         Chan,                   -- abstract @@ -31,8 +30,6 @@         writeChan,         readChan,         dupChan,-        unGetChan,-        isEmptyChan,            -- * Stream interface         getChanContents,@@ -136,24 +133,6 @@    hole       <- readMVar writeVar    newReadVar <- newMVar hole    return (Chan newReadVar writeVar)---- |Put a data item back onto a channel, where it will be the next item read.-unGetChan :: Chan a -> a -> IO ()-unGetChan (Chan readVar _) val = do-   new_read_end <- newEmptyMVar-   modifyMVar_ readVar $ \read_end -> do-     putMVar new_read_end (ChItem val read_end)-     return new_read_end-{-# DEPRECATED unGetChan "if you need this operation, use Control.Concurrent.STM.TChan instead.  See <http://ghc.haskell.org/trac/ghc/ticket/4154> for details" #-} -- deprecated in 7.0---- |Returns 'True' if the supplied 'Chan' is empty.-isEmptyChan :: Chan a -> IO Bool-isEmptyChan (Chan readVar writeVar) = do-   withMVar readVar $ \r -> do-     w <- readMVar writeVar-     let eq = r == w-     eq `seq` return eq-{-# DEPRECATED isEmptyChan "if you need this operation, use Control.Concurrent.STM.TChan instead.  See <http://ghc.haskell.org/trac/ghc/ticket/4154> for details" #-} -- deprecated in 7.0  -- Operators for interfacing with functional streams. 

@@ -25,7 +25,7 @@ --      wait and signal. -- -- They were introduced in the paper--- <http://research.microsoft.com/~simonpj/papers/concurrent-haskell.ps.gz "Concurrent Haskell">+-- <https://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz "Concurrent Haskell"> -- by Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne, though -- some details of their implementation have since then changed (in -- particular, a put on a full 'MVar' used to error, but now merely@@ -41,8 +41,8 @@ -- atomic operations such as reading from multiple variables: use 'STM' -- instead. ----- In particular, the "bigger" functions in this module ('readMVar',--- 'swapMVar', 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply+-- In particular, the "bigger" functions in this module ('swapMVar',+-- 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply -- the composition of a 'takeMVar' followed by a 'putMVar' with -- exception safety. -- These only have atomicity guarantees if all other threads

@@ -376,7 +376,7 @@ > e <- tryJust (guard . isDoesNotExistError) (readFile f) > let str = either (const "") id e -There are occassions when you really do need to catch any sort of+There are occasions when you really do need to catch any sort of exception. However, in most cases this is just so you can do some cleaning up; you aren't actually interested in the exception itself. For example, if you open a file then you want to close it again,

@@ -30,6 +30,7 @@         NonTermination(..),         NestedAtomically(..),         BlockedIndefinitelyOnMVar(..),+        FixIOException (..),         BlockedIndefinitelyOnSTM(..),         AllocationLimitExceeded(..),         CompactionFailed(..),

@@ -86,8 +86,47 @@ -- ----------------------------------------------------------------------------- -- Functions mandated by the Prelude --- | @'guard' b@ is @'pure' ()@ if @b@ is 'True',--- and 'empty' if @b@ is 'False'.+-- | Conditional failure of 'Alternative' computations. Defined by+--+-- @+-- guard True  = 'pure' ()+-- guard False = 'empty'+-- @+--+-- ==== __Examples__+--+-- Common uses of 'guard' include conditionally signaling an error in+-- an error monad and conditionally rejecting the current choice in an+-- 'Alternative'-based parser.+--+-- As an example of signaling an error in the error monad 'Maybe',+-- consider a safe division function @safeDiv x y@ that returns+-- 'Nothing' when the denominator @y@ is zero and @'Just' (x \`div\`+-- y)@ otherwise. For example:+--+-- @+-- >>> safeDiv 4 0+-- Nothing+-- >>> safeDiv 4 2+-- Just 2+-- @+--+-- A definition of @safeDiv@ using guards, but not 'guard':+--+-- @+-- safeDiv :: Int -> Int -> Maybe Int+-- safeDiv x y | y /= 0    = Just (x \`div\` y)+--             | otherwise = Nothing+-- @+--+-- A definition of @safeDiv@ using 'guard' and 'Monad' @do@-notation:+--+-- @+-- safeDiv :: Int -> Int -> Maybe Int+-- safeDiv x y = do+--   guard (y /= 0)+--   return (x \`div\` y)+-- @ guard           :: (Alternative f) => Bool -> f () guard True      =  pure () guard False     =  empty@@ -146,15 +185,15 @@ function' are not commutative.  ->       foldM f a1 [x1, x2, ..., xm]--==-->       do->         a2 <- f a1 x1->         a3 <- f a2 x2->         ...->         f am xm+> foldM f a1 [x1, x2, ..., xm]+>+> ==+>+> do+>   a2 <- f a1 x1+>   a3 <- f a2 x2+>   ...+>   f am xm  If right-to-left evaluation is required, the input list should be reversed. @@ -264,19 +303,19 @@   The monad type constructor @m@ is added to function results   (modulo currying) and nowhere else.  So, for example, ->  filter  ::              (a ->   Bool) -> [a] ->   [a]->  filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+> filter  ::              (a ->   Bool) -> [a] ->   [a]+> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]  * A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@.   Thus, for example: ->  sequence  :: Monad m => [m a] -> m [a]->  sequence_ :: Monad m => [m a] -> m ()+> sequence  :: Monad m => [m a] -> m [a]+> sequence_ :: Monad m => [m a] -> m ()  * A prefix \'@m@\' generalizes an existing function to a monadic form.   Thus, for example: ->  sum  :: Num a       => [a]   -> a->  msum :: MonadPlus m => [m a] -> m a+> filter  ::                (a -> Bool) -> [a] -> [a]+> mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a  -}

@@ -29,7 +29,7 @@ import Data.Maybe import Data.Monoid ( Dual(..), Sum(..), Product(..)                    , First(..), Last(..), Alt(..) )-import GHC.Base ( Monad, errorWithoutStackTrace, (.) )+import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) ) import GHC.Generics import GHC.List ( head, tail ) import GHC.ST@@ -73,6 +73,14 @@     mfix f = case fix (f . head) of                []    -> []                (x:_) -> x : mfix (tail . f)++-- | @since 4.9.0.0+instance MonadFix NonEmpty where+  mfix f = case fix (f . neHead) of+             ~(x :| _) -> x :| mfix (neTail . f)+    where+      neHead ~(a :| _) = a+      neTail ~(_ :| as) = as  -- | @since 2.01 instance MonadFix IO where

@@ -16,7 +16,7 @@ -- -- References (variables) that can be used within the @ST@ monad are -- provided by "Data.STRef", and arrays are provided by--- "Data.Array.ST".+-- [Data.Array.ST](https://hackage.haskell.org/package/array/docs/Data-Array-ST.html).  ----------------------------------------------------------------------------- 

@@ -51,7 +51,7 @@ -- by @s@, and returns a value of type @a@. -- The @s@ parameter is either ----- * an unstantiated type variable (inside invocations of 'runST'), or+-- * an uninstantiated type variable (inside invocations of 'runST'), or -- -- * 'RealWorld' (inside invocations of 'stToIO'). --

@@ -22,6 +22,7 @@ import Data.Functor.Identity import Data.Monoid import Data.Proxy+import qualified Data.List.NonEmpty as NE import GHC.Generics  -- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith`@@ -58,6 +59,12 @@     mzip     = zip     mzipWith = zipWith     munzip   = unzip++-- | @since 4.9.0.0+instance MonadZip NE.NonEmpty where+  mzip     = NE.zip+  mzipWith = NE.zipWith+  munzip   = NE.unzip  -- | @since 4.8.0.0 instance MonadZip Identity where

@@ -117,7 +117,7 @@   bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c   bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z -  -- | Combines the elments of a structure in a left associative manner. Given+  -- | Combines the elements of a structure in a left associative manner. Given   -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a   -- list of all elements of a structure in order, the following would hold:   --

@@ -20,7 +20,15 @@ import Control.Applicative  ( Const(..) ) import GHC.Generics ( K1(..) ) --- | Formally, the class 'Bifunctor' represents a bifunctor+-- | A bifunctor is a type constructor that takes+-- two type arguments and is a functor in /both/ arguments. That+-- is, unlike with 'Functor', a type constructor such as 'Either'+-- does not need to be partially applied for a 'Bifunctor'+-- instance, and the methods in this class permit mapping+-- functions over the 'Left' value or the 'Right' value,+-- or both at the same time.+--+-- Formally, the class 'Bifunctor' represents a bifunctor -- from @Hask@ -> @Hask@. -- -- Intuitively it is a bifunctor where both the first and second@@ -59,20 +67,47 @@     -- | Map over both arguments at the same time.     --     -- @'bimap' f g ≡ 'first' f '.' 'second' g@+    --+    -- ==== __Examples__+    -- >>> bimap toUpper (+1) ('j', 3)+    -- ('J',4)+    --+    -- >>> bimap toUpper (+1) (Left 'j')+    -- Left 'J'+    --+    -- >>> bimap toUpper (+1) (Right 3)+    -- Right 4     bimap :: (a -> b) -> (c -> d) -> p a c -> p b d     bimap f g = first f . second g +     -- | Map covariantly over the first argument.     --     -- @'first' f ≡ 'bimap' f 'id'@+    --+    -- ==== __Examples__+    -- >>> first toUpper ('j', 3)+    -- ('J',3)+    --+    -- >>> first toUpper (Left 'j')+    -- Left 'J'     first :: (a -> b) -> p a c -> p b c     first f = bimap f id +     -- | Map covariantly over the second argument.     --     -- @'second' ≡ 'bimap' 'id'@+    --+    -- ==== __Examples__+    -- >>> second (+1) ('j', 3)+    -- ('j',4)+    --+    -- >>> second (+1) (Right 3)+    -- Right 4     second :: (b -> c) -> p a b -> p a c     second = bimap id+   -- | @since 4.8.0.0

@@ -57,17 +57,13 @@  #include "MachDeps.h" -#ifdef MIN_VERSION_integer_gmp-# define HAVE_INTEGER_GMP1 MIN_VERSION_integer_gmp(1,0,0)-#endif- import Data.Maybe import GHC.Enum import GHC.Num import GHC.Base import GHC.Real -#if HAVE_INTEGER_GMP1+#if defined(MIN_VERSION_integer_gmp) import GHC.Integer.GMP.Internals (bitInteger, popCountInteger) #endif @@ -245,7 +241,7 @@     x `shiftR`  i = x `shift`  (-i)      {-| Shift the first argument right by the specified number of bits, which-        must be non-negative an smaller than the number of bits in the type.+        must be non-negative and smaller than the number of bits in the type.          Right shifts perform sign extension on signed number types;         i.e. they fill the top bits with 1 if the @x@ is negative@@ -526,7 +522,7 @@    testBit x (I# i) = testBitInteger x i    zeroBits   = 0 -#if HAVE_INTEGER_GMP1+#if defined(MIN_VERSION_integer_gmp)    bit (I# i#) = bitInteger i#    popCount x  = I# (popCountInteger x) #else

@@ -132,6 +132,8 @@ -- True -- >>> isLetter 'A' -- True+-- >>> isLetter 'λ'+-- True -- >>> isLetter '0' -- False -- >>> isLetter '%'

@@ -197,7 +197,8 @@                       where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))      asinh z        =  log (z + sqrt (1+z*z))-    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+    -- Take care to allow (-1)::Complex, fixing #8532+    acosh z        =  log (z + (sqrt $ z+1) * (sqrt $ z-1))     atanh z        =  0.5 * log ((1.0+z) / (1.0-z))      log1p x@(a :+ b)

@@ -140,6 +140,8 @@ --import GHC.IOBase            -- So we can give Data instance for IO, Handle import GHC.Ptr               -- So we can give Data instance for Ptr import GHC.ForeignPtr        -- So we can give Data instance for ForeignPtr+import Foreign.Ptr (IntPtr(..), WordPtr(..))+                             -- So we can give Data instance for IntPtr and WordPtr --import GHC.Stable            -- So we can give Data instance for StablePtr --import GHC.ST                -- So we can give Data instance for ST --import GHC.Conc              -- So we can give Data instance for MVar & Co.@@ -277,22 +279,34 @@ ------------------------------------------------------------------------------    -- | Mediate types and unary type constructors.-  -- In 'Data' instances of the form @T a@, 'dataCast1' should be defined-  -- as 'gcast1'.   --+  -- In 'Data' instances of the form+  --+  -- @+  --     instance (Data a, ...) => Data (T a)+  -- @+  --+  -- 'dataCast1' should be defined as 'gcast1'.+  --   -- The default definition is @'const' 'Nothing'@, which is appropriate-  -- for non-unary type constructors.+  -- for instances of other forms.   dataCast1 :: Typeable t             => (forall d. Data d => c (t d))             -> Maybe (c a)   dataCast1 _ = Nothing    -- | Mediate types and binary type constructors.-  -- In 'Data' instances of the form @T a b@, 'dataCast2' should be-  -- defined as 'gcast2'.   --+  -- In 'Data' instances of the form+  --+  -- @+  --     instance (Data a, Data b, ...) => Data (T a b)+  -- @+  --+  -- 'dataCast2' should be defined as 'gcast2'.+  --   -- The default definition is @'const' 'Nothing'@, which is appropriate-  -- for non-binary type constructors.+  -- for instances of other forms.   dataCast2 :: Typeable t             => (forall d e. (Data d, Data e) => c (t d e))             -> Maybe (c a)@@ -779,7 +793,7 @@                     FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f))                     _ -> errorWithoutStackTrace $ "Data.Data.mkRealConstr is not supported for "                                  ++ dataTypeName dt ++-                                 ", as it is not an Real data type."+                                 ", as it is not a Real data type."  -- | Makes a constructor for 'Char'. mkCharConstr :: DataType -> Char -> Constr@@ -1137,6 +1151,9 @@  ------------------------------------------------------------------------------ +-- | @since 4.9.0.0+deriving instance Data a => Data (NonEmpty a)+ -- | @since 4.0.0.0 deriving instance Data a => Data (Maybe a) @@ -1188,6 +1205,12 @@   gunfold _ _  = errorWithoutStackTrace "Data.Data.gunfold(ForeignPtr)"   dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr"   dataCast1 x  = gcast1 x++-- | @since 4.11.0.0+deriving instance Data IntPtr++-- | @since 4.11.0.0+deriving instance Data WordPtr  ------------------------------------------------------------------------------ -- The Data instance for Array preserves data abstraction at the cost of

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE StandaloneDeriving #-}@@ -33,8 +34,6 @@ import GHC.Show import GHC.Read -import Data.Type.Equality- -- $setup -- Allow the use of some Prelude functions in doctests. -- >>> import Prelude ( (+), (*), length, putStrLn )@@ -131,6 +130,17 @@     fmap _ (Left x) = Left x     fmap f (Right y) = Right (f y) +-- | @since 4.9.0.0+instance Semigroup (Either a b) where+    Left _ <> b = b+    a      <> _ = a+#if !defined(__HADDOCK_VERSION__)+    -- workaround https://github.com/haskell/haddock/issues/680+    stimes n x+      | n <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected"+      | otherwise = x+#endif+ -- | @since 3.0 instance Applicative (Either e) where     pure          = Right@@ -317,13 +327,6 @@ fromRight :: b -> Either a b -> b fromRight _ (Right b) = b fromRight b _         = b---- instance for the == Boolean type-level equality operator-type family EqEither a b where-  EqEither ('Left x)  ('Left y)  = x == y-  EqEither ('Right x) ('Right y) = x == y-  EqEither a          b          = 'False-type instance a == b = EqEither a b  {- {--------------------------------------------------------------------

@@ -99,6 +99,8 @@ -- -- > fold = foldMap id --+-- > length = getSum . foldMap (Sum . const  1)+-- -- @sum@, @product@, @maximum@, and @minimum@ should all be essentially -- equivalent to @foldMap@ forms, such as --@@ -294,6 +296,16 @@     sum     = List.sum     toList  = id +-- | @since 4.9.0.0+instance Foldable NonEmpty where+  foldr f z ~(a :| as) = f a (List.foldr f z as)+  foldl f z ~(a :| as) = List.foldl f (f z a) as+  foldl1 f ~(a :| as) = List.foldl f a as+  foldMap f ~(a :| as) = f a `mappend` foldMap f as+  fold ~(m :| ms) = m `mappend` fold ms+  length (_ :| as) = 1 + List.length as+  toList ~(a :| as) = a : as+ -- | @since 4.7.0.0 instance Foldable (Either a) where     foldMap _ (Left _) = mempty@@ -506,6 +518,9 @@ sequence_ = foldr (>>) (return ())  -- | The sum of a collection of actions, generalizing 'concat'.+--+-- asum [Just "Hello", Nothing, Just "World"]+-- Just "Hello" asum :: (Foldable t, Alternative f) => t (f a) -> f a {-# INLINE asum #-} asum = foldr (<|>) empty

@@ -32,13 +32,28 @@  -- | @'fix' f@ is the least fixed point of the function @f@, -- i.e. the least defined @x@ such that @f x = x@.+--+-- For example, we can write the factorial function using direct recursion as+--+-- >>> let fac n = if n <= 1 then 1 else n * fac (n-1) in fac 5+-- 120+--+-- This uses the fact that Haskell’s @let@ introduces recursive bindings. We can+-- rewrite this definition using 'fix',+--+-- >>> fix (\rec n -> if n <= 1 then 1 else n * rec (n-1)) 5+-- 120+--+-- Instead of making a recursive call, we introduce a dummy parameter @rec@;+-- when used within 'fix', this parameter then refers to 'fix'' argument, hence+-- the recursion is reintroduced. fix :: (a -> a) -> a fix f = let x = f x in x --- | @(*) \`on\` f = \\x y -> f x * f y@.+-- | @((==) \`on\` f) x y = f x == f y@ -- -- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@.---+ -- Algebraic properties: -- -- * @(*) \`on\` 'id' = (*)@ (if @(*) &#x2209; {&#x22a5;, 'const' &#x22a5;}@)@@ -95,6 +110,12 @@ -- convenience.  Its precedence is one higher than that of the forward -- application operator '$', which allows '&' to be nested in '$'. --+-- >>> 5 & (+1) & show+-- "6"+-- -- @since 4.8.0.0 (&) :: a -> (a -> b) -> b x & f = f x++-- $setup+-- >>> import Prelude

@@ -20,6 +20,7 @@       (<$),       ($>),       (<$>),+      (<&>),       void,     ) where @@ -73,6 +74,31 @@ (<$>) = fmap  infixl 4 $>++-- | Flipped version of '<$>'.+--+-- @+-- ('<&>') = 'flip' 'fmap'+-- @+--+-- @since 4.11.0.0+--+-- ==== __Examples__+-- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right':+--+-- >>> Just 2 <&> (+1)+-- Just 3+--+-- >>> [1,2,3] <&> (+1)+-- [2,3,4]+--+-- >>> Right 3 <&> (+1)+-- Right 4+--+(<&>) :: Functor f => f a -> (a -> b) -> f b+as <&> f = f <$> as++infixl 1 <&>  -- | Flipped version of '<$'. --

@@ -68,6 +68,7 @@  import Data.Functor.Identity (Identity(Identity)) import Data.Proxy (Proxy(Proxy))+import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (mappend)  import GHC.Read (expectP, list, paren)@@ -451,6 +452,27 @@ -- | @since 4.9.0.0 instance Show1 [] where     liftShowsPrec _ sl _ = sl++-- | @since 4.10.0.0+instance Eq1 NonEmpty where+  liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs++-- | @since 4.10.0.0+instance Ord1 NonEmpty where+  liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs++-- | @since 4.10.0.0+instance Read1 NonEmpty where+  liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do+    (a, s'') <- rdP 6 s'+    (":|", s''') <- lex s''+    (as, s'''') <- rdL s'''+    return (a :| as, s'''')) s++-- | @since 4.10.0.0+instance Show1 NonEmpty where+  liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $+    shwP 6 a . showString " :| " . shwL as  -- | @since 4.9.0.0 instance Eq2 (,) where

@@ -38,8 +38,8 @@ -- | The 'Const' functor. newtype Const a b = Const { getConst :: a }     deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional-             , Generic, Generic1, Integral, Ix, Monoid, Num, Ord, Real-             , RealFrac, RealFloat , Storable)+             , Generic, Generic1, Integral, Ix, Semigroup, Monoid, Num, Ord+             , Real, RealFrac, RealFloat, Storable)  -- | This instance would be equivalent to the derived instances of the -- 'Const' newtype if the 'runConst' field were removed

@@ -43,7 +43,7 @@ import Foreign.Storable (Storable) import GHC.Arr (Ix) import GHC.Base ( Applicative(..), Eq(..), Functor(..), Monad(..)-                , Monoid, Ord(..), ($), (.) )+                , Semigroup, Monoid, Ord(..), ($), (.) ) import GHC.Enum (Bounded, Enum) import GHC.Float (Floating, RealFloat) import GHC.Generics (Generic, Generic1)@@ -58,7 +58,7 @@ -- @since 4.8.0.0 newtype Identity a = Identity { runIdentity :: a }     deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional-             , Generic, Generic1, Integral, Ix, Monoid, Num, Ord+             , Generic, Generic1, Integral, Ix, Semigroup, Monoid, Num, Ord              , Real, RealFrac, RealFloat, Storable)  -- | This instance would be equivalent to the derived instances of the

@@ -11,7 +11,7 @@  import Data.Coerce (Coercible, coerce) import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monoid(..), Ord(..)-                , ($), otherwise )+                , Semigroup(..), ($), otherwise )  -- We don't expose Max and Min because, as Edward Kmett pointed out to me, -- there are two reasonable ways to define them. One way is to use Maybe, as we@@ -22,27 +22,31 @@ newtype Max a = Max {getMax :: Maybe a} newtype Min a = Min {getMin :: Maybe a} +-- | @since 4.11.0.0+instance Ord a => Semigroup (Max a) where+    {-# INLINE (<>) #-}+    m <> Max Nothing = m+    Max Nothing <> n = n+    (Max m@(Just x)) <> (Max n@(Just y))+      | x >= y    = Max m+      | otherwise = Max n+ -- | @since 4.8.0.0 instance Ord a => Monoid (Max a) where-  mempty = Max Nothing+    mempty = Max Nothing -  {-# INLINE mappend #-}-  m `mappend` Max Nothing = m-  Max Nothing `mappend` n = n-  (Max m@(Just x)) `mappend` (Max n@(Just y))-    | x >= y    = Max m-    | otherwise = Max n+-- | @since 4.11.0.0+instance Ord a => Semigroup (Min a) where+    {-# INLINE (<>) #-}+    m <> Min Nothing = m+    Min Nothing <> n = n+    (Min m@(Just x)) <> (Min n@(Just y))+      | x <= y    = Min m+      | otherwise = Min n  -- | @since 4.8.0.0 instance Ord a => Monoid (Min a) where-  mempty = Min Nothing--  {-# INLINE mappend #-}-  m `mappend` Min Nothing = m-  Min Nothing `mappend` n = n-  (Min m@(Just x)) `mappend` (Min n@(Just y))-    | x <= y    = Min m-    | otherwise = Min n+    mempty = Min Nothing  -- left-to-right state transformer newtype StateL s a = StateL { runStateL :: s -> (s, a) }

@@ -76,6 +76,7 @@     -- ** Infinite lists    , iterate+   , iterate'    , repeat    , replicate    , cycle

@@ -102,65 +102,14 @@ import qualified Prelude  import           Control.Applicative (Applicative (..), Alternative (many))-import           Control.Monad       (ap, liftM2)-import           Control.Monad.Fix-import           Control.Monad.Zip   (MonadZip(..))-import           Data.Data           (Data) import           Data.Foldable       hiding (length, toList) import qualified Data.Foldable       as Foldable import           Data.Function       (on)-import           Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) import qualified Data.List           as List-import           Data.Monoid         ((<>)) import           Data.Ord            (comparing)-import qualified GHC.Exts            as Exts (IsList(..))-import           GHC.Generics        (Generic, Generic1)--infixr 5 :|, <|---- | Non-empty (and non-strict) list type.------ @since 4.9.0.0-data NonEmpty a = a :| [a]-  deriving ( Eq, Ord, Show, Read, Data, Generic, Generic1 )---- | @since 4.10.0.0-instance Eq1 NonEmpty where-  liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs---- | @since 4.10.0.0-instance Ord1 NonEmpty where-  liftCompare cmp (a :| as) (b :| bs) = cmp a b <> liftCompare cmp as bs---- | @since 4.10.0.0-instance Read1 NonEmpty where-  liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do-    (a, s'') <- rdP 6 s'-    (":|", s''') <- lex s''-    (as, s'''') <- rdL s'''-    return (a :| as, s'''')) s---- | @since 4.10.0.0-instance Show1 NonEmpty where-  liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $-    shwP 6 a . showString " :| " . shwL as---- | @since 4.9.0.0-instance Exts.IsList (NonEmpty a) where-  type Item (NonEmpty a) = a-  fromList               = fromList-  toList                 = toList---- | @since 4.9.0.0-instance MonadFix NonEmpty where-  mfix f = case fix (f . head) of-             ~(x :| _) -> x :| mfix (tail . f)+import           GHC.Base            (NonEmpty(..)) --- | @since 4.9.0.0-instance MonadZip NonEmpty where-  mzip     = zip-  mzipWith = zipWith-  munzip   = unzip+infixr 5 <|  -- | Number of elements in 'NonEmpty' list. length :: NonEmpty a -> Int@@ -203,37 +152,6 @@     go c = case f c of       (d, me) -> d : maybe [] go me --- | @since 4.9.0.0-instance Functor NonEmpty where-  fmap f ~(a :| as) = f a :| fmap f as-  b <$ ~(_ :| as)   = b   :| (b <$ as)---- | @since 4.9.0.0-instance Applicative NonEmpty where-  pure a = a :| []-  (<*>) = ap-  liftA2 = liftM2---- | @since 4.9.0.0-instance Monad NonEmpty where-  ~(a :| as) >>= f = b :| (bs ++ bs')-    where b :| bs = f a-          bs' = as >>= toList . f---- | @since 4.9.0.0-instance Traversable NonEmpty where-  traverse f ~(a :| as) = liftA2 (:|) (f a) (traverse f as)---- | @since 4.9.0.0-instance Foldable NonEmpty where-  foldr f z ~(a :| as) = f a (foldr f z as)-  foldl f z ~(a :| as) = foldl f (f z a) as-  foldl1 f ~(a :| as) = foldl f a as-  foldMap f ~(a :| as) = f a `mappend` foldMap f as-  fold ~(m :| ms) = m `mappend` fold ms-  length = length-  toList = toList- -- | Extract the first element of the stream. head :: NonEmpty a -> a head ~(a :| _) = a@@ -477,6 +395,7 @@   | n == 0 = x   | n > 0  = xs List.!! (n - 1)   | otherwise = errorWithoutStackTrace "NonEmpty.!! negative argument"+infixl 9 !!  -- | The 'zip' function takes two streams and returns a stream of -- corresponding pairs.

@@ -228,9 +228,12 @@ -- >>> maybeToList $ listToMaybe [1,2,3] -- [1] ---listToMaybe           :: [a] -> Maybe a-listToMaybe []        =  Nothing-listToMaybe (a:_)     =  Just a+listToMaybe :: [a] -> Maybe a+listToMaybe = foldr (const . Just) Nothing+{-# INLINE listToMaybe #-}+-- We define listToMaybe using foldr so that it can fuse via the foldr/build+-- rule. See #14387+  -- | The 'catMaybes' function takes a list of 'Maybe's and returns -- a list of all the 'Just' values.

@@ -43,123 +43,11 @@  -- Push down the module in the dependency hierarchy. import GHC.Base hiding (Any)-import GHC.Enum-import GHC.Num import GHC.Read import GHC.Show import GHC.Generics -{---- just for testing-import Data.Maybe-import Test.QuickCheck--- -}--infixr 6 <>---- | An infix synonym for 'mappend'.------ @since 4.5.0.0-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}---- Monoid instances.---- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'.-newtype Dual a = Dual { getDual :: a }-        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)---- | @since 2.01-instance Monoid a => Monoid (Dual a) where-        mempty = Dual mempty-        Dual x `mappend` Dual y = Dual (y `mappend` x)---- | @since 4.8.0.0-instance Functor Dual where-    fmap     = coerce---- | @since 4.8.0.0-instance Applicative Dual where-    pure     = Dual-    (<*>)    = coerce---- | @since 4.8.0.0-instance Monad Dual where-    m >>= k  = k (getDual m)---- | The monoid of endomorphisms under composition.-newtype Endo a = Endo { appEndo :: a -> a }-               deriving (Generic)---- | @since 2.01-instance Monoid (Endo a) where-        mempty = Endo id-        Endo f `mappend` Endo g = Endo (f . g)---- | Boolean monoid under conjunction ('&&').-newtype All = All { getAll :: Bool }-        deriving (Eq, Ord, Read, Show, Bounded, Generic)---- | @since 2.01-instance Monoid All where-        mempty = All True-        All x `mappend` All y = All (x && y)---- | Boolean monoid under disjunction ('||').-newtype Any = Any { getAny :: Bool }-        deriving (Eq, Ord, Read, Show, Bounded, Generic)---- | @since 2.01-instance Monoid Any where-        mempty = Any False-        Any x `mappend` Any y = Any (x || y)---- | Monoid under addition.-newtype Sum a = Sum { getSum :: a }-        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)---- | @since 2.01-instance Num a => Monoid (Sum a) where-        mempty = Sum 0-        mappend = coerce ((+) :: a -> a -> a)---        Sum x `mappend` Sum y = Sum (x + y)---- | @since 4.8.0.0-instance Functor Sum where-    fmap     = coerce---- | @since 4.8.0.0-instance Applicative Sum where-    pure     = Sum-    (<*>)    = coerce---- | @since 4.8.0.0-instance Monad Sum where-    m >>= k  = k (getSum m)---- | Monoid under multiplication.-newtype Product a = Product { getProduct :: a }-        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)---- | @since 2.01-instance Num a => Monoid (Product a) where-        mempty = Product 1-        mappend = coerce ((*) :: a -> a -> a)---        Product x `mappend` Product y = Product (x * y)---- | @since 4.8.0.0-instance Functor Product where-    fmap     = coerce---- | @since 4.8.0.0-instance Applicative Product where-    pure     = Product-    (<*>)    = coerce---- | @since 4.8.0.0-instance Monad Product where-    m >>= k  = k (getProduct m)+import Data.Semigroup.Internal  -- $MaybeExamples -- To implement @find@ or @findLast@ on any 'Foldable':@@ -197,41 +85,45 @@ -- -- @'First' a@ is isomorphic to @'Alt' 'Maybe' a@, but precedes it -- historically.+--+-- >>> getFirst (First (Just "hello") <> First Nothing <> First (Just "world"))+-- Just "hello" newtype First a = First { getFirst :: Maybe a }         deriving (Eq, Ord, Read, Show, Generic, Generic1,                   Functor, Applicative, Monad) +-- | @since 4.9.0.0+instance Semigroup (First a) where+        First Nothing <> b = b+        a             <> _ = a+        stimes = stimesIdempotentMonoid+ -- | @since 2.01 instance Monoid (First a) where         mempty = First Nothing-        First Nothing `mappend` r = r-        l `mappend` _             = l  -- | Maybe monoid returning the rightmost non-Nothing value. -- -- @'Last' a@ is isomorphic to @'Dual' ('First' a)@, and thus to -- @'Dual' ('Alt' 'Maybe' a)@+--+-- >>> getLast (Last (Just "hello") <> Last Nothing <> Last (Just "world"))+-- Just "world" newtype Last a = Last { getLast :: Maybe a }         deriving (Eq, Ord, Read, Show, Generic, Generic1,                   Functor, Applicative, Monad) +-- | @since 4.9.0.0+instance Semigroup (Last a) where+        a <> Last Nothing = a+        _ <> b                   = b+        stimes = stimesIdempotentMonoid+ -- | @since 2.01 instance Monoid (Last a) where         mempty = Last Nothing-        l `mappend` Last Nothing = l-        _ `mappend` r            = r --- | Monoid under '<|>'.------ @since 4.8.0.0-newtype Alt f a = Alt {getAlt :: f a}-  deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum,-            Monad, MonadPlus, Applicative, Alternative, Functor) --- | @since 4.8.0.0-instance Alternative f => Monoid (Alt f a) where-        mempty = Alt empty-        mappend = coerce ((<|>) :: f a -> f a -> f a)  {- {--------------------------------------------------------------------@@ -253,3 +145,6 @@         where listLastToMaybe [] = Nothing               listLastToMaybe lst = Just (last lst) -- -}++-- $setup+-- >>> import Prelude

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-}+{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables,+             MagicHash, BangPatterns #-}  ----------------------------------------------------------------------------- -- |@@ -76,6 +77,7 @@     -- ** Infinite lists    , iterate+   , iterate'    , repeat    , replicate    , cycle@@ -227,8 +229,12 @@ -- | The 'dropWhileEnd' function drops the largest suffix of a list -- in which the given predicate holds for all elements.  For example: ----- > dropWhileEnd isSpace "foo\n" == "foo"--- > dropWhileEnd isSpace "foo bar" == "foo bar"+-- >>> dropWhileEnd isSpace "foo\n"+-- "foo"+--+-- >>> dropWhileEnd isSpace "foo bar"+-- "foo bar"+-- -- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined -- -- @since 4.5.0.0@@ -239,10 +245,17 @@ -- It returns 'Nothing' if the list did not start with the prefix -- given, or 'Just' the list after the prefix, if it does. ----- > stripPrefix "foo" "foobar" == Just "bar"--- > stripPrefix "foo" "foo" == Just ""--- > stripPrefix "foo" "barfoo" == Nothing--- > stripPrefix "foo" "barfoobaz" == Nothing+-- >>> stripPrefix "foo" "foobar"+-- Just "bar"+--+-- >>> stripPrefix "foo" "foo"+-- Just ""+--+-- >>> stripPrefix "foo" "barfoo"+-- Nothing+--+-- >>> stripPrefix "foo" "barfoobaz"+-- Nothing stripPrefix :: Eq a => [a] -> [a] -> Maybe [a] stripPrefix [] ys = Just ys stripPrefix (x:xs) (y:ys)@@ -252,30 +265,48 @@ -- | The 'elemIndex' function returns the index of the first element -- in the given list which is equal (by '==') to the query element, -- or 'Nothing' if there is no such element.+--+-- >>> elemIndex 4 [0..]+-- Just 4 elemIndex       :: Eq a => a -> [a] -> Maybe Int elemIndex x     = findIndex (x==)  -- | The 'elemIndices' function extends 'elemIndex', by returning the -- indices of all elements equal to the query element, in ascending order.+--+-- >>> elemIndices 'o' "Hello World"+-- [4,7] elemIndices     :: Eq a => a -> [a] -> [Int] elemIndices x   = findIndices (x==)  -- | The 'find' function takes a predicate and a list and returns the -- first element in the list matching the predicate, or 'Nothing' if -- there is no such element.+--+-- >>> find (> 4) [1..]+-- Just 5+--+-- >>> find (< 0) [1..10]+-- Nothing find            :: (a -> Bool) -> [a] -> Maybe a find p          = listToMaybe . filter p  -- | The 'findIndex' function takes a predicate and a list and returns -- the index of the first element in the list satisfying the predicate, -- or 'Nothing' if there is no such element.+--+-- >>> findIndex isSpace "Hello World!"+-- Just 5 findIndex       :: (a -> Bool) -> [a] -> Maybe Int findIndex p     = listToMaybe . findIndices p  -- | The 'findIndices' function extends 'findIndex', by returning the -- indices of all elements satisfying the predicate, in ascending order.+--+-- >>> findIndices (`elem` "aeiou") "Hello World!"+-- [1,4,7] findIndices      :: (a -> Bool) -> [a] -> [Int]-#ifdef USE_REPORT_PRELUDE+#if defined(USE_REPORT_PRELUDE) findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] #else -- Efficient definition, adapted from Data.Sequence@@ -288,6 +319,12 @@  -- | The 'isPrefixOf' function takes two lists and returns 'True' -- iff the first list is a prefix of the second.+--+-- >>> "Hello" `isPrefixOf` "Hello World!"+-- True+--+-- >>> "Hello" `isPrefixOf` "Wello Horld!"+-- False isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool isPrefixOf [] _         =  True isPrefixOf _  []        =  False@@ -296,6 +333,12 @@ -- | The 'isSuffixOf' function takes two lists and returns 'True' iff -- the first list is a suffix of the second. The second list must be -- finite.+--+-- >>> "ld!" `isSuffixOf` "Hello World!"+-- True+--+-- >>> "World" `isSuffixOf` "Hello World!"+-- False isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool ns `isSuffixOf` hs      = maybe False id $ do       delta <- dropLengthMaybe ns hs@@ -310,6 +353,12 @@ -- entirety.  dropLength is also generally faster than (drop . length) -- Both this and dropLengthMaybe could be written as folds over their first -- arguments, but this reduces clarity with no benefit to isSuffixOf.+--+-- >>> dropLength "Hello" "Holla world"+-- " world"+--+-- >>> dropLength [1..] [1,2,3]+-- [] dropLength :: [a] -> [b] -> [b] dropLength [] y = y dropLength _ [] = []@@ -317,6 +366,9 @@  -- A version of dropLength that returns Nothing if the second list runs out of -- elements before the first.+--+-- >>> dropLengthMaybe [1..] [1,2,3]+-- Nothing dropLengthMaybe :: [a] -> [b] -> Maybe [b] dropLengthMaybe [] y = Just y dropLengthMaybe _ [] = Nothing@@ -326,10 +378,11 @@ -- iff the first list is contained, wholly and intact, -- anywhere within the second. ----- Example:+-- >>> isInfixOf "Haskell" "I really like Haskell."+-- True ----- >isInfixOf "Haskell" "I really like Haskell." == True--- >isInfixOf "Ial" "I really like Haskell." == False+-- >>> isInfixOf "Ial" "I really like Haskell."+-- False isInfixOf               :: (Eq a) => [a] -> [a] -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) @@ -338,14 +391,20 @@ -- (The name 'nub' means \`essence\'.) -- It is a special case of 'nubBy', which allows the programmer to supply -- their own equality test.+--+-- >>> nub [1,2,3,4,3,2,1,2,4,3,5]+-- [1,2,3,4,5] nub                     :: (Eq a) => [a] -> [a] nub                     =  nubBy (==)  -- | The 'nubBy' function behaves just like 'nub', except it uses a -- user-supplied equality predicate instead of the overloaded '==' -- function.+--+-- >>> nubBy (\x y -> mod x 3 == mod y 3) [1,2,4,5,6]+-- [1,2,6] nubBy                   :: (a -> a -> Bool) -> [a] -> [a]-#ifdef USE_REPORT_PRELUDE+#if defined(USE_REPORT_PRELUDE) nubBy eq []             =  [] nubBy eq (x:xs)         =  x : nubBy eq (filter (\ y -> not (eq x y)) xs) #else@@ -373,16 +432,19 @@ -- | 'delete' @x@ removes the first occurrence of @x@ from its list argument. -- For example, ----- > delete 'a' "banana" == "bnana"+-- >>> delete 'a' "banana"+-- "bnana" -- -- It is a special case of 'deleteBy', which allows the programmer to -- supply their own equality test.- delete                  :: (Eq a) => a -> [a] -> [a] delete                  =  deleteBy (==)  -- | The 'deleteBy' function behaves like 'delete', but takes a -- user-supplied equality predicate.+--+-- >>> deleteBy (<=) 4 [1..10]+-- [1,2,3,5,6,7,8,9,10] deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a] deleteBy _  _ []        = [] deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys@@ -393,6 +455,9 @@ -- -- > (xs ++ ys) \\ xs == ys. --+-- >>> "Hello World!" \\ "ell W"+-- "Hoorld!"+-- -- It is a special case of 'deleteFirstsBy', which allows the programmer -- to supply their own equality test. @@ -402,7 +467,8 @@ -- | The 'union' function returns the list union of the two lists. -- For example, ----- > "dog" `union` "cow" == "dogcw"+-- >>> "dog" `union` "cow"+-- "dogcw" -- -- Duplicates, and elements of the first list, are removed from the -- the second list, but if the first list contains duplicates, so will@@ -420,11 +486,13 @@ -- | The 'intersect' function takes the list intersection of two lists. -- For example, ----- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4]+-- >>> [1,2,3,4] `intersect` [2,4,6,8]+-- [2,4] -- -- If the first list contains duplicates, so will the result. ----- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4]+-- >>> [1,2,2,3,4] `intersect` [6,4,4,2]+-- [2,2,4] -- -- It is a special case of 'intersectBy', which allows the programmer to -- supply their own equality test. If the element is found in both the first@@ -443,8 +511,8 @@ -- \`intersperses\' that element between the elements of the list. -- For example, ----- > intersperse ',' "abcde" == "a,b,c,d,e"-+-- >>> intersperse ',' "abcde"+-- "a,b,c,d,e" intersperse             :: a -> [a] -> [a] intersperse _   []      = [] intersperse sep (x:xs)  = x : prependToAll sep xs@@ -461,18 +529,22 @@ -- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@. -- It inserts the list @xs@ in between the lists in @xss@ and concatenates the -- result.+--+-- >>> intercalate ", " ["Lorem", "ipsum", "dolor"]+-- "Lorem, ipsum, dolor" intercalate :: [a] -> [[a]] -> [a] intercalate xs xss = concat (intersperse xs xss)  -- | The 'transpose' function transposes the rows and columns of its argument. -- For example, ----- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]]+-- >>> transpose [[1,2,3],[4,5,6]]+-- [[1,4],[2,5],[3,6]] -- -- If some of the rows are shorter than the following rows, their elements are skipped: ----- > transpose [[10,11],[20],[],[30,31,32]] == [[10,20,30],[11,31],[32]]-+-- >>> transpose [[10,11],[20],[],[30,31,32]]+-- [[10,20,30],[11,31],[32]] transpose               :: [[a]] -> [[a]] transpose []             = [] transpose ([]   : xss)   = transpose xss@@ -484,7 +556,9 @@ -- predicate, respectively; i.e., -- -- > partition p xs == (filter p xs, filter (not . p) xs)-+--+-- >>> partition (`elem` "aeiou") "Hello World!"+-- ("eoo","Hll Wrld!") partition               :: (a -> Bool) -> [a] -> ([a],[a]) {-# INLINE partition #-} partition p xs = foldr (select p) ([],[]) xs@@ -548,6 +622,9 @@ -- is sorted before the call, the result will also be sorted. -- It is a special case of 'insertBy', which allows the programmer to -- supply their own comparison function.+--+-- >>> insert 4 [1,2,3,5,6,7]+-- [1,2,3,4,5,6,7] insert :: Ord a => a -> [a] -> [a] insert e ls = insertBy (compare) e ls @@ -562,6 +639,11 @@ -- | The 'maximumBy' function takes a comparison function and a list -- and returns the greatest element of the list by the comparison function. -- The list must be finite and non-empty.+--+-- We can use this to find the longest entry of a list:+--+-- >>> maximumBy (\x y -> compare (length x) (length y)) ["Hello", "World", "!", "Longest", "bar"]+-- "Longest" maximumBy               :: (a -> a -> Ordering) -> [a] -> a maximumBy _ []          =  errorWithoutStackTrace "List.maximumBy: empty list" maximumBy cmp xs        =  foldl1 maxBy xs@@ -573,6 +655,11 @@ -- | The 'minimumBy' function takes a comparison function and a list -- and returns the least element of the list by the comparison function. -- The list must be finite and non-empty.+--+-- We can use this to find the shortest entry of a list:+--+-- >>> minimumBy (\x y -> compare (length x) (length y)) ["Hello", "World", "!", "Longest", "bar"]+-- "!" minimumBy               :: (a -> a -> Ordering) -> [a] -> a minimumBy _ []          =  errorWithoutStackTrace "List.minimumBy: empty list" minimumBy cmp xs        =  foldl1 minBy xs@@ -733,7 +820,8 @@ -- that the concatenation of the result is equal to the argument.  Moreover, -- each sublist in the result contains only equal elements.  For example, ----- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]+-- >>> group "Mississippi"+-- ["M","i","ss","i","ss","i","pp","i"] -- -- It is a special case of 'groupBy', which allows the programmer to supply -- their own equality test.@@ -749,7 +837,8 @@ -- | The 'inits' function returns all initial segments of the argument, -- shortest first.  For example, ----- > inits "abc" == ["","a","ab","abc"]+-- >>> inits "abc"+-- ["","a","ab","abc"] -- -- Note that 'inits' has the following strictness property: -- @inits (xs ++ _|_) = inits xs ++ _|_@@@ -767,7 +856,8 @@ -- | The 'tails' function returns all final segments of the argument, -- longest first.  For example, ----- > tails "abc" == ["abc", "bc", "c",""]+-- >>> tails "abc"+-- ["abc","bc","c",""] -- -- Note that 'tails' has the following strictness property: -- @tails _|_ = _|_ : _|_@@@ -781,14 +871,16 @@  -- | The 'subsequences' function returns the list of all subsequences of the argument. ----- > subsequences "abc" == ["","a","b","ab","c","ac","bc","abc"]+-- >>> subsequences "abc"+-- ["","a","b","ab","c","ac","bc","abc"] subsequences            :: [a] -> [[a]] subsequences xs         =  [] : nonEmptySubsequences xs  -- | The 'nonEmptySubsequences' function returns the list of all subsequences of the argument, --   except for the empty list. ----- > nonEmptySubsequences "abc" == ["a","b","ab","c","ac","bc","abc"]+-- >>> nonEmptySubsequences "abc"+-- ["a","b","ab","c","ac","bc","abc"] nonEmptySubsequences         :: [a] -> [[a]] nonEmptySubsequences []      =  [] nonEmptySubsequences (x:xs)  =  [x] : foldr f [] (nonEmptySubsequences xs)@@ -797,7 +889,8 @@  -- | The 'permutations' function returns the list of all permutations of the argument. ----- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"]+-- >>> permutations "abc"+-- ["abc","bac","cba","bca","cab","acb"] permutations            :: [a] -> [[a]] permutations xs0        =  xs0 : perms xs0 []   where@@ -818,12 +911,18 @@ -- -- Elements are arranged from from lowest to highest, keeping duplicates in -- the order they appeared in the input.+--+-- >>> sort [1,6,4,3,2,5]+-- [1,2,3,4,5,6] sort :: (Ord a) => [a] -> [a]  -- | The 'sortBy' function is the non-overloaded version of 'sort'.+--+-- >>> sortBy (\(a,_) (b,_) -> compare a b) [(2, "world"), (4, "!"), (1, "Hello")]+-- [(1,"Hello"),(2,"world"),(4,"!")] sortBy :: (a -> a -> Ordering) -> [a] -> [a] -#ifdef USE_REPORT_PRELUDE+#if defined(USE_REPORT_PRELUDE) sort = sortBy compare sortBy cmp = foldr (insertBy cmp) [] #else@@ -854,12 +953,14 @@      ascending a as (b:bs)       | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs-    ascending a as bs   = as [a]: sequences bs+    ascending a as bs   = let !x = as [a]+                          in x : sequences bs      mergeAll [x] = x     mergeAll xs  = mergeAll (mergePairs xs) -    mergePairs (a:b:xs) = merge a b: mergePairs xs+    mergePairs (a:b:xs) = let !x = merge a b+                          in x : mergePairs xs     mergePairs xs       = xs      merge as@(a:as') bs@(b:bs')@@ -984,6 +1085,9 @@ -- Elements are arranged from from lowest to highest, keeping duplicates in -- the order they appeared in the input. --+-- >>> sortOn fst [(2, "world"), (4, "!"), (1, "Hello")]+-- [(1,"Hello"),(2,"world"),(4,"!")]+-- -- @since 4.8.0.0 sortOn :: Ord b => (a -> b) -> [a] -> [a] sortOn f =@@ -1009,8 +1113,8 @@ -- -- A simple use of unfoldr: ----- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10--- >  [10,9,8,7,6,5,4,3,2,1]+-- >>> unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10+-- [10,9,8,7,6,5,4,3,2,1] --  -- Note [INLINE unfoldr]@@ -1055,14 +1159,27 @@ -- last part of the string is considered a line even if it doesn't end -- with a newline. For example, ----- > lines "" == []--- > lines "\n" == [""]--- > lines "one" == ["one"]--- > lines "one\n" == ["one"]--- > lines "one\n\n" == ["one",""]--- > lines "one\ntwo" == ["one","two"]--- > lines "one\ntwo\n" == ["one","two"]+-- >>> lines ""+-- [] --+-- >>> lines "\n"+-- [""]+--+-- >>> lines "one"+-- ["one"]+--+-- >>> lines "one\n"+-- ["one"]+--+-- >>> lines "one\n\n"+-- ["one",""]+--+-- >>> lines "one\ntwo"+-- ["one","two"]+--+-- >>> lines "one\ntwo\n"+-- ["one","two"]+-- -- Thus @'lines' s@ contains at least as many elements as newlines in @s@. lines                   :: String -> [String] lines ""                =  []@@ -1079,8 +1196,11 @@  -- | 'unlines' is an inverse operation to 'lines'. -- It joins lines, after appending a terminating newline to each.+--+-- >>> unlines ["Hello", "World", "!"]+-- "Hello\nWorld\n!\n" unlines                 :: [String] -> String-#ifdef USE_REPORT_PRELUDE+#if defined(USE_REPORT_PRELUDE) unlines                 =  concatMap (++ "\n") #else -- HBC version (stolen)@@ -1091,6 +1211,9 @@  -- | 'words' breaks a string up into a list of words, which were delimited -- by white space.+--+-- >>> words "Lorem ipsum\ndolor"+-- ["Lorem","ipsum","dolor"] words                   :: String -> [String] {-# NOINLINE [1] words #-} words s                 =  case dropWhile {-partain:Char.-}isSpace s of@@ -1114,8 +1237,11 @@  -- | 'unwords' is an inverse operation to 'words'. -- It joins words with separating spaces.+--+-- >>> unwords ["Lorem", "ipsum", "dolor"]+-- "Lorem ipsum dolor" unwords                 :: [String] -> String-#ifdef USE_REPORT_PRELUDE+#if defined(USE_REPORT_PRELUDE) unwords []              =  "" unwords ws              =  foldr1 (\w s -> w ++ ' ':s) ws #else

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  ----------------------------------------------------------------------------- -- |@@ -25,6 +26,7 @@ import GHC.Base import GHC.Show import GHC.Read+import GHC.Num  -- |  -- > comparing p x y = compare (p x) (p y)@@ -43,11 +45,30 @@ -- This is particularly useful when sorting in generalised list comprehensions, -- as in: @then sortWith by 'Down' x@ ----- Provides 'Show' and 'Read' instances (/since: 4.7.0.0/).--- -- @since 4.6.0.0-newtype Down a = Down a deriving (Eq, Show, Read)+newtype Down a = Down a+    deriving+      ( Eq+      , Show -- ^ @since 4.7.0.0+      , Read -- ^ @since 4.7.0.0+      , Num -- ^ @since 4.11.0.0+      , Semigroup -- ^ @since 4.11.0.0+      , Monoid -- ^ @since 4.11.0.0+      )  -- | @since 4.6.0.0 instance Ord a => Ord (Down a) where     compare (Down x) (Down y) = y `compare` x++-- | @since 4.11.0.0+instance Functor Down where+    fmap = coerce++-- | @since 4.11.0.0+instance Applicative Down where+    pure = Down+    (<*>) = coerce++-- | @since 4.11.0.0+instance Monad Down where+    Down a >>= k = k a

@@ -28,9 +28,35 @@ import GHC.Enum import GHC.Arr --- | A concrete, poly-kinded proxy type-data Proxy t = Proxy deriving Bounded+-- $setup+-- >>> import Data.Void+-- >>> import Prelude +-- | 'Proxy' is a type that holds no data, but has a phantom parameter of+-- arbitrary type (or even kind). Its use is to provide type information, even+-- though there is no value available of that type (or it may be too costly to+-- create one).+--+-- Historically, @'Proxy' :: 'Proxy' a@ is a safer alternative to the+-- @'undefined :: a'@ idiom.+--+-- >>> Proxy :: Proxy (Void, Int -> Int)+-- Proxy+--+-- Proxy can even hold types of higher kinds,+--+-- >>> Proxy :: Proxy Either+-- Proxy+--+-- >>> Proxy :: Proxy Functor+-- Proxy+--+-- >>> Proxy :: Proxy complicatedStructure+-- Proxy+data Proxy t = Proxy deriving ( Bounded+                              , Read -- ^ @since 4.7.0.0+                              )+ -- | A concrete, promotable proxy type, for use at the kind level -- There are no instances for this because it is intended at the kind level only data KProxy (t :: *) = KProxy@@ -52,10 +78,6 @@   showsPrec _ _ = showString "Proxy"  -- | @since 4.7.0.0-instance Read (Proxy s) where-  readsPrec d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])---- | @since 4.7.0.0 instance Enum (Proxy s) where     succ _               = errorWithoutStackTrace "Proxy.succ"     pred _               = errorWithoutStackTrace "Proxy.pred"@@ -76,10 +98,15 @@     unsafeIndex _ _   = 0     unsafeRangeSize _ = 1 +-- | @since 4.9.0.0+instance Semigroup (Proxy s) where+    _ <> _ = Proxy+    sconcat _ = Proxy+    stimes _ _ = Proxy+ -- | @since 4.7.0.0 instance Monoid (Proxy s) where     mempty = Proxy-    mappend _ _ = Proxy     mconcat _ = Proxy  -- | @since 4.7.0.0@@ -113,6 +140,19 @@ -- It is usually used as an infix operator, and its typing forces its first -- argument (which is usually overloaded) to have the same type as the tag -- of the second.+--+-- >>> import Data.Word+-- >>> :type asProxyTypeOf 123 (Proxy :: Proxy Word8)+-- asProxyTypeOf 123 (Proxy :: Proxy Word8) :: Word8+--+-- Note the lower-case @proxy@ in the definition. This allows any type+-- constructor with just one argument to be passed to the function, for example+-- we could also write+--+-- >>> import Data.Word+-- >>> :type asProxyTypeOf 123 (Just (undefined :: Word8))+-- asProxyTypeOf 123 (Just (undefined :: Word8)) :: Word8 asProxyTypeOf :: a -> proxy a -> a asProxyTypeOf = const {-# INLINE asProxyTypeOf #-}+

@@ -47,27 +47,32 @@ -- and abs r' < d', and the simplest rational is q%1 + the reciprocal of -- the simplest rational between d'%r' and d%r. -approxRational          :: (RealFrac a) => a -> a -> Rational-approxRational rat eps  =  simplest (rat-eps) (rat+eps)-        where simplest x y | y < x      =  simplest y x-                           | x == y     =  xr-                           | x > 0      =  simplest' n d n' d'-                           | y < 0      =  - simplest' (-n') d' (-n) d-                           | otherwise  =  0 :% 1-                                        where xr  = toRational x-                                              n   = numerator xr-                                              d   = denominator xr-                                              nd' = toRational y-                                              n'  = numerator nd'-                                              d'  = denominator nd'+approxRational :: (RealFrac a) => a -> a -> Rational+approxRational rat eps =+    -- We convert rat and eps to rational *before* subtracting/adding since+    -- otherwise we may overflow. This was the cause of #14425.+    simplest (toRational rat - toRational eps) (toRational rat + toRational eps)+  where+    simplest x y+      | y < x      =  simplest y x+      | x == y     =  xr+      | x > 0      =  simplest' n d n' d'+      | y < 0      =  - simplest' (-n') d' (-n) d+      | otherwise  =  0 :% 1+      where xr  = toRational x+            n   = numerator xr+            d   = denominator xr+            nd' = toRational y+            n'  = numerator nd'+            d'  = denominator nd' -              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'-                        | r == 0     =  q :% 1-                        | q /= q'    =  (q+1) :% 1-                        | otherwise  =  (q*n''+d'') :% n''-                                     where (q,r)      =  quotRem n d-                                           (q',r')    =  quotRem n' d'-                                           nd''       =  simplest' d' r' d r-                                           n''        =  numerator nd''-                                           d''        =  denominator nd''+    simplest' n d n' d'       -- assumes 0 < n%d < n'%d'+      | r == 0     =  q :% 1+      | q /= q'    =  (q+1) :% 1+      | otherwise  =  (q*n''+d'') :% n''+      where (q,r)      =  quotRem n d+            (q',r')    =  quotRem n' d'+            nd''       =  simplest' d' r' d r+            n''        =  numerator nd''+            d''        =  denominator nd'' 

@@ -5,7 +5,7 @@ -- Module      :  Data.STRef -- Copyright   :  (c) The University of Glasgow 2001 -- License     :  BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer  :  libraries@haskell.org -- Stability   :  experimental -- Portability :  non-portable (uses Control.Monad.ST)@@ -29,16 +29,30 @@  -- | Mutate the contents of an 'STRef'. --+-- >>> :{+-- runST (do+--     ref <- newSTRef ""+--     modifySTRef ref (const "world")+--     modifySTRef ref (++ "!")+--     modifySTRef ref ("Hello, " ++)+--     readSTRef ref )+-- :}+-- "Hello, world!"+-- -- Be warned that 'modifySTRef' does not apply the function strictly.  This -- means if the program calls 'modifySTRef' many times, but seldomly uses the -- value, thunks will pile up in memory resulting in a space leak.  This is a -- common mistake made when using an STRef as a counter.  For example, the--- following will leak memory and likely produce a stack overflow:+-- following will leak memory and may produce a stack overflow: ----- >print $ runST $ do--- >    ref <- newSTRef 0--- >    replicateM_ 1000000 $ modifySTRef ref (+1)--- >    readSTRef ref+-- >>> import Control.Monad (replicateM_)+-- >>> :{+-- print (runST (do+--     ref <- newSTRef 0+--     replicateM_ 1000 $ modifySTRef ref (+1)+--     readSTRef ref ))+-- :}+-- 1000 -- -- To avoid this problem, use 'modifySTRef'' instead. modifySTRef :: STRef s a -> (a -> a) -> ST s ()

@@ -48,7 +48,6 @@   , Last(..)   , WrappedMonoid(..)   -- * Re-exported monoids from Data.Monoid-  , Monoid(..)   , Dual(..)   , Endo(..)   , All(..)@@ -69,6 +68,10 @@  import           Prelude             hiding (foldr1) +import GHC.Base (Semigroup(..))++import           Data.Semigroup.Internal+ import           Control.Applicative import           Control.Monad import           Control.Monad.Fix@@ -77,252 +80,19 @@ import           Data.Bitraversable import           Data.Coerce import           Data.Data-import           Data.Functor.Identity-import           Data.List.NonEmpty import           Data.Monoid         (All (..), Any (..), Dual (..), Endo (..),                                       Product (..), Sum (..))-import           Data.Monoid         (Alt (..))-import qualified Data.Monoid         as Monoid-import           Data.Void-#ifndef mingw32_HOST_OS-import           GHC.Event           (Event, Lifetime)-#endif+-- import qualified Data.Monoid         as Monoid import           GHC.Generics -infixr 6 <>---- | The class of semigroups (types with an associative binary operation).------ @since 4.9.0.0-class Semigroup a where-  -- | An associative operation.-  ---  -- @-  -- (a '<>' b) '<>' c = a '<>' (b '<>' c)-  -- @-  ---  -- If @a@ is also a 'Monoid' we further require-  ---  -- @-  -- ('<>') = 'mappend'-  -- @-  (<>) :: a -> a -> a--  default (<>) :: Monoid a => a -> a -> a-  (<>) = mappend--  -- | Reduce a non-empty list with @\<\>@-  ---  -- The default definition should be sufficient, but this can be-  -- overridden for efficiency.-  ---  sconcat :: NonEmpty a -> a-  sconcat (a :| as) = go a as where-    go b (c:cs) = b <> go c cs-    go b []     = b--  -- | Repeat a value @n@ times.-  ---  -- Given that this works on a 'Semigroup' it is allowed to fail if-  -- you request 0 or fewer repetitions, and the default definition-  -- will do so.-  ---  -- By making this a member of the class, idempotent semigroups and monoids can-  -- upgrade this to execute in /O(1)/ by picking-  -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@-  -- respectively.-  stimes :: Integral b => b -> a -> a-  stimes y0 x0-    | y0 <= 0   = errorWithoutStackTrace "stimes: positive multiplier expected"-    | otherwise = f x0 y0-    where-      f x y-        | even y = f (x <> x) (y `quot` 2)-        | y == 1 = x-        | otherwise = g (x <> x) (pred y  `quot` 2) x-      g x y z-        | even y = g (x <> x) (y `quot` 2) z-        | y == 1 = x <> z-        | otherwise = g (x <> x) (pred y `quot` 2) (x <> z)- -- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. -- May fail to terminate for some values in some semigroups. cycle1 :: Semigroup m => m -> m cycle1 xs = xs' where xs' = xs <> xs' --- | @since 4.9.0.0-instance Semigroup () where-  _ <> _ = ()-  sconcat _ = ()-  stimes _ _ = ()---- | @since 4.9.0.0-instance Semigroup b => Semigroup (a -> b) where-  f <> g = \a -> f a <> g a-  stimes n f e = stimes n (f e)---- | @since 4.9.0.0-instance Semigroup [a] where-  (<>) = (++)-  stimes n x-    | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier"-    | otherwise = rep n-    where-      rep 0 = []-      rep i = x ++ rep (i - 1)---- | @since 4.9.0.0-instance Semigroup a => Semigroup (Maybe a) where-  Nothing <> b       = b-  a       <> Nothing = a-  Just a  <> Just b  = Just (a <> b)-  stimes _ Nothing  = Nothing-  stimes n (Just a) = case compare n 0 of-    LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"-    EQ -> Nothing-    GT -> Just (stimes n a)---- | @since 4.9.0.0-instance Semigroup (Either a b) where-  Left _ <> b = b-  a      <> _ = a-  stimes = stimesIdempotent---- | @since 4.9.0.0-instance (Semigroup a, Semigroup b) => Semigroup (a, b) where-  (a,b) <> (a',b') = (a<>a',b<>b')-  stimes n (a,b) = (stimes n a, stimes n b)---- | @since 4.9.0.0-instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where-  (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')-  stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)---- | @since 4.9.0.0-instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)-         => Semigroup (a, b, c, d) where-  (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')-  stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)---- | @since 4.9.0.0-instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)-         => Semigroup (a, b, c, d, e) where-  (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')-  stimes n (a,b,c,d,e) =-      (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)---- | @since 4.9.0.0-instance Semigroup Ordering where-  LT <> _ = LT-  EQ <> y = y-  GT <> _ = GT-  stimes = stimesIdempotentMonoid---- | @since 4.9.0.0-instance Semigroup a => Semigroup (Dual a) where-  Dual a <> Dual b = Dual (b <> a)-  stimes n (Dual a) = Dual (stimes n a)---- | @since 4.9.0.0-instance Semigroup (Endo a) where-  (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))-  stimes = stimesMonoid---- | @since 4.9.0.0-instance Semigroup All where-  (<>) = coerce (&&)-  stimes = stimesIdempotentMonoid---- | @since 4.9.0.0-instance Semigroup Any where-  (<>) = coerce (||)-  stimes = stimesIdempotentMonoid----- | @since 4.9.0.0-instance Num a => Semigroup (Sum a) where-  (<>) = coerce ((+) :: a -> a -> a)-  stimes n (Sum a) = Sum (fromIntegral n * a)---- | @since 4.9.0.0-instance Num a => Semigroup (Product a) where-  (<>) = coerce ((*) :: a -> a -> a)-  stimes n (Product a) = Product (a ^ n)---- | This is a valid definition of 'stimes' for a 'Monoid'.------ Unlike the default definition of 'stimes', it is defined for 0--- and so it should be preferred where possible.-stimesMonoid :: (Integral b, Monoid a) => b -> a -> a-stimesMonoid n x0 = case compare n 0 of-  LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier"-  EQ -> mempty-  GT -> f x0 n-    where-      f x y-        | even y = f (x `mappend` x) (y `quot` 2)-        | y == 1 = x-        | otherwise = g (x `mappend` x) (pred y  `quot` 2) x-      g x y z-        | even y = g (x `mappend` x) (y `quot` 2) z-        | y == 1 = x `mappend` z-        | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z)---- | This is a valid definition of 'stimes' for an idempotent 'Monoid'.------ When @mappend x x = x@, this definition should be preferred, because it--- works in /O(1)/ rather than /O(log n)/-stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a-stimesIdempotentMonoid n x = case compare n 0 of-  LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier"-  EQ -> mempty-  GT -> x---- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.------ When @x <> x = x@, this definition should be preferred, because it--- works in /O(1)/ rather than /O(log n)/.-stimesIdempotent :: Integral b => b -> a -> a-stimesIdempotent n x-  | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"-  | otherwise = x---- | @since 4.9.0.0-instance Semigroup a => Semigroup (Identity a) where-  (<>) = coerce ((<>) :: a -> a -> a)-  stimes n (Identity a) = Identity (stimes n a)---- | @since 4.9.0.0-instance Semigroup a => Semigroup (Const a b) where-  (<>) = coerce ((<>) :: a -> a -> a)-  stimes n (Const a) = Const (stimes n a)---- | @since 4.9.0.0-instance Semigroup (Monoid.First a) where-  Monoid.First Nothing <> b = b-  a                    <> _ = a-  stimes = stimesIdempotentMonoid---- | @since 4.9.0.0-instance Semigroup (Monoid.Last a) where-  a <> Monoid.Last Nothing = a-  _ <> b                   = b-  stimes = stimesIdempotentMonoid---- | @since 4.9.0.0-instance Alternative f => Semigroup (Alt f a) where-  (<>) = coerce ((<|>) :: f a -> f a -> f a)-  stimes = stimesMonoid---- | @since 4.9.0.0-instance Semigroup Void where-  a <> _ = a-  stimes = stimesIdempotent---- | @since 4.9.0.0-instance Semigroup (NonEmpty a) where-  (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs)-+-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'.+diff :: Semigroup m => m -> Endo m+diff = Endo . (<>)  newtype Min a = Min { getMin :: a }   deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)@@ -347,7 +117,6 @@ -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Min a) where   mempty = maxBound-  mappend = (<>)  -- | @since 4.9.0.0 instance Functor Min where@@ -410,7 +179,6 @@ -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Max a) where   mempty = minBound-  mappend = (<>)  -- | @since 4.9.0.0 instance Functor Max where@@ -491,7 +259,7 @@  -- | @since 4.10.0.0 instance Bifoldable Arg where-  bifoldMap f g (Arg a b) = f a `mappend` g b+  bifoldMap f g (Arg a b) = f a <> g b  -- | @since 4.10.0.0 instance Bitraversable Arg where@@ -599,6 +367,9 @@   mfix f = fix (f . getLast)  -- | Provide a Semigroup for an arbitrary Monoid.+--+-- __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of+-- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future. newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }   deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) @@ -609,7 +380,6 @@ -- | @since 4.9.0.0 instance Monoid m => Monoid (WrappedMonoid m) where   mempty = WrapMonoid mempty-  mappend = (<>)  -- | @since 4.9.0.0 instance Enum a => Enum (WrappedMonoid a) where@@ -693,40 +463,15 @@ -- | @since 4.9.0.0 instance Semigroup a => Semigroup (Option a) where   (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a)-+#if !defined(__HADDOCK_VERSION__)+    -- workaround https://github.com/haskell/haddock/issues/680   stimes _ (Option Nothing) = Option Nothing   stimes n (Option (Just a)) = case compare n 0 of     LT -> errorWithoutStackTrace "stimes: Option, negative multiplier"     EQ -> Option Nothing     GT -> Option (Just (stimes n a))+#endif  -- | @since 4.9.0.0 instance Semigroup a => Monoid (Option a) where   mempty = Option Nothing-  mappend = (<>)---- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'.-diff :: Semigroup m => m -> Endo m-diff = Endo . (<>)---- | @since 4.9.0.0-instance Semigroup (Proxy s) where-  _ <> _ = Proxy-  sconcat _ = Proxy-  stimes _ _ = Proxy---- | @since 4.10.0.0-instance Semigroup a => Semigroup (IO a) where-    (<>) = liftA2 (<>)--#ifndef mingw32_HOST_OS--- | @since 4.10.0.0-instance Semigroup Event where-    (<>) = mappend-    stimes = stimesMonoid---- | @since 4.10.0.0-instance Semigroup Lifetime where-    (<>) = mappend-    stimes = stimesMonoid-#endif

@@ -0,0 +1,264 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Auxilary definitions for 'Semigroup'+--+-- This module provides some @newtype@ wrappers and helpers which are+-- reexported from the "Data.Semigroup" module or imported directly+-- by some other modules.+--+-- This module also provides internal definitions related to the+-- 'Semigroup' class some.+--+-- This module exists mostly to simplify or workaround import-graph+-- issues; there is also a .hs-boot file to allow "GHC.Base" and other+-- modules to import method default implementations for 'stimes'+--+-- @since 4.11.0.0+module Data.Semigroup.Internal where++import GHC.Base hiding (Any)+import GHC.Enum+import GHC.Num+import GHC.Read+import GHC.Show+import GHC.Generics+import GHC.Real++-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.+--+-- When @x <> x = x@, this definition should be preferred, because it+-- works in /O(1)/ rather than /O(log n)/.+stimesIdempotent :: Integral b => b -> a -> a+stimesIdempotent n x+  | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"+  | otherwise = x++-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'.+--+-- When @mappend x x = x@, this definition should be preferred, because it+-- works in /O(1)/ rather than /O(log n)/+stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a+stimesIdempotentMonoid n x = case compare n 0 of+  LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier"+  EQ -> mempty+  GT -> x++-- | This is a valid definition of 'stimes' for a 'Monoid'.+--+-- Unlike the default definition of 'stimes', it is defined for 0+-- and so it should be preferred where possible.+stimesMonoid :: (Integral b, Monoid a) => b -> a -> a+stimesMonoid n x0 = case compare n 0 of+  LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier"+  EQ -> mempty+  GT -> f x0 n+    where+      f x y+        | even y = f (x `mappend` x) (y `quot` 2)+        | y == 1 = x+        | otherwise = g (x `mappend` x) (y `quot` 2) x               -- See Note [Half of y - 1]+      g x y z+        | even y = g (x `mappend` x) (y `quot` 2) z+        | y == 1 = x `mappend` z+        | otherwise = g (x `mappend` x) (y `quot` 2) (x `mappend` z) -- See Note [Half of y - 1]++-- this is used by the class definitionin GHC.Base;+-- it lives here to avoid cycles+stimesDefault :: (Integral b, Semigroup a) => b -> a -> a+stimesDefault y0 x0+  | y0 <= 0   = errorWithoutStackTrace "stimes: positive multiplier expected"+  | otherwise = f x0 y0+  where+    f x y+      | even y = f (x <> x) (y `quot` 2)+      | y == 1 = x+      | otherwise = g (x <> x) (y `quot` 2) x        -- See Note [Half of y - 1]+    g x y z+      | even y = g (x <> x) (y `quot` 2) z+      | y == 1 = x <> z+      | otherwise = g (x <> x) (y `quot` 2) (x <> z) -- See Note [Half of y - 1]++{- Note [Half of y - 1]+   ~~~~~~~~~~~~~~~~~~~~~+   Since y is guaranteed to be odd and positive here,+   half of y - 1 can be computed as y `quot` 2, optimising subtraction away.+-}++stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a+stimesMaybe _ Nothing = Nothing+stimesMaybe n (Just a) = case compare n 0 of+    LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"+    EQ -> Nothing+    GT -> Just (stimes n a)++stimesList  :: Integral b => b -> [a] -> [a]+stimesList n x+  | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier"+  | otherwise = rep n+  where+    rep 0 = []+    rep i = x ++ rep (i - 1)++-- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'.+--+-- >>> getDual (mappend (Dual "Hello") (Dual "World"))+-- "WorldHello"+newtype Dual a = Dual { getDual :: a }+        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)++-- | @since 4.9.0.0+instance Semigroup a => Semigroup (Dual a) where+        Dual a <> Dual b = Dual (b <> a)+        stimes n (Dual a) = Dual (stimes n a)++-- | @since 2.01+instance Monoid a => Monoid (Dual a) where+        mempty = Dual mempty++-- | @since 4.8.0.0+instance Functor Dual where+    fmap     = coerce++-- | @since 4.8.0.0+instance Applicative Dual where+    pure     = Dual+    (<*>)    = coerce++-- | @since 4.8.0.0+instance Monad Dual where+    m >>= k  = k (getDual m)++-- | The monoid of endomorphisms under composition.+--+-- >>> let computation = Endo ("Hello, " ++) <> Endo (++ "!")+-- >>> appEndo computation "Haskell"+-- "Hello, Haskell!"+newtype Endo a = Endo { appEndo :: a -> a }+               deriving (Generic)++-- | @since 4.9.0.0+instance Semigroup (Endo a) where+        (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))+        stimes = stimesMonoid++-- | @since 2.01+instance Monoid (Endo a) where+        mempty = Endo id++-- | Boolean monoid under conjunction ('&&').+--+-- >>> getAll (All True <> mempty <> All False)+-- False+--+-- >>> getAll (mconcat (map (\x -> All (even x)) [2,4,6,7,8]))+-- False+newtype All = All { getAll :: Bool }+        deriving (Eq, Ord, Read, Show, Bounded, Generic)++-- | @since 4.9.0.0+instance Semigroup All where+        (<>) = coerce (&&)+        stimes = stimesIdempotentMonoid++-- | @since 2.01+instance Monoid All where+        mempty = All True++-- | Boolean monoid under disjunction ('||').+--+-- >>> getAny (Any True <> mempty <> Any False)+-- True+--+-- >>> getAny (mconcat (map (\x -> Any (even x)) [2,4,6,7,8]))+-- True+newtype Any = Any { getAny :: Bool }+        deriving (Eq, Ord, Read, Show, Bounded, Generic)++-- | @since 4.9.0.0+instance Semigroup Any where+        (<>) = coerce (||)+        stimes = stimesIdempotentMonoid++-- | @since 2.01+instance Monoid Any where+        mempty = Any False++-- | Monoid under addition.+--+-- >>> getSum (Sum 1 <> Sum 2 <> mempty)+-- 3+newtype Sum a = Sum { getSum :: a }+        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)++-- | @since 4.9.0.0+instance Num a => Semigroup (Sum a) where+        (<>) = coerce ((+) :: a -> a -> a)+        stimes n (Sum a) = Sum (fromIntegral n * a)++-- | @since 2.01+instance Num a => Monoid (Sum a) where+        mempty = Sum 0++-- | @since 4.8.0.0+instance Functor Sum where+    fmap     = coerce++-- | @since 4.8.0.0+instance Applicative Sum where+    pure     = Sum+    (<*>)    = coerce++-- | @since 4.8.0.0+instance Monad Sum where+    m >>= k  = k (getSum m)++-- | Monoid under multiplication.+--+-- >>> getProduct (Product 3 <> Product 4 <> mempty)+-- 12+newtype Product a = Product { getProduct :: a }+        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)++-- | @since 4.9.0.0+instance Num a => Semigroup (Product a) where+        (<>) = coerce ((*) :: a -> a -> a)+        stimes n (Product a) = Product (a ^ n)+++-- | @since 2.01+instance Num a => Monoid (Product a) where+        mempty = Product 1++-- | @since 4.8.0.0+instance Functor Product where+    fmap     = coerce++-- | @since 4.8.0.0+instance Applicative Product where+    pure     = Product+    (<*>)    = coerce++-- | @since 4.8.0.0+instance Monad Product where+    m >>= k  = k (getProduct m)+++-- | Monoid under '<|>'.+--+-- @since 4.8.0.0+newtype Alt f a = Alt {getAlt :: f a}+  deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum,+            Monad, MonadPlus, Applicative, Alternative, Functor)++-- | @since 4.9.0.0+instance Alternative f => Semigroup (Alt f a) where+    (<>) = coerce ((<|>) :: f a -> f a -> f a)+    stimes = stimesMonoid++-- | @since 4.8.0.0+instance Alternative f => Monoid (Alt f a) where+    mempty = Alt empty

@@ -0,0 +1,12 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Semigroup.Internal where++import {-# SOURCE #-} GHC.Real (Integral)+import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe)++stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a++stimesDefault :: (Integral b, Semigroup a) => b -> a -> a+stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a+stimesList :: Integral b => b -> [a] -> [a]

@@ -64,7 +64,7 @@ import Data.Proxy ( Proxy(..) )  import GHC.Arr-import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..),+import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), NonEmpty(..),                   ($), (.), id, flip ) import GHC.Generics import qualified GHC.List as List ( foldr )@@ -198,8 +198,8 @@  This gives rise to a list-instance of mapM looking like this -  $fTraversable[]_$ctaverse = ...code for traverse on lists...-       {-# INLINE $fTraversable[]_$ctaverse #-}+  $fTraversable[]_$ctraverse = ...code for traverse on lists...+       {-# INLINE $fTraversable[]_$ctraverse #-}   $fTraversable[]_$cmapM    = $fTraversable[]_$ctraverse  Now the $ctraverse obediently inlines into the RHS of $cmapM, /but/@@ -236,6 +236,10 @@     {-# INLINE traverse #-} -- so that traverse can fuse     traverse f = List.foldr cons_f (pure [])       where cons_f x ys = liftA2 (:) (f x) ys++-- | @since 4.9.0.0+instance Traversable NonEmpty where+  traverse f ~(a :| as) = liftA2 (:|) (f a) (traverse f as)  -- | @since 4.7.0.0 instance Traversable (Either a) where

@@ -6,7 +6,7 @@ -- Module      :  Data.Tuple -- Copyright   :  (c) The University of Glasgow 2001 -- License     :  BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer  :  libraries@haskell.org -- Stability   :  experimental -- Portability :  portable@@ -39,13 +39,32 @@ snd (_,y)               =  y  -- | 'curry' converts an uncurried function to a curried function.+--+-- ==== __Examples__+--+-- >>> curry fst 1 2+-- 1 curry                   :: ((a, b) -> c) -> a -> b -> c curry f x y             =  f (x, y)  -- | 'uncurry' converts a curried function to a function on pairs.+--+-- ==== __Examples__+--+-- >>> uncurry (+) (1,2)+-- 3+--+-- >>> uncurry ($) (show, 1)+-- "1"+--+-- >>> map (uncurry max) [(1,2), (3,4), (6,8)]+-- [2,4,8] uncurry                 :: (a -> b -> c) -> ((a, b) -> c) uncurry f p             =  f (fst p) (snd p)  -- | Swap the components of a pair. swap                    :: (a,b) -> (b,a) swap (a,b)              = (b,a)++-- $setup+-- >>> import Prelude hiding (curry, uncurry, fst, snd)

@@ -81,8 +81,7 @@ deriving instance Ord  (Coercion a b)  -- | @since 4.7.0.0-instance Coercible a b => Read (Coercion a b) where-  readsPrec d = readParen (d > 10) (\r -> [(Coercion, s) | ("Coercion",s) <- lex r ])+deriving instance Coercible a b => Read (Coercion a b)  -- | @since 4.7.0.0 instance Coercible a b => Enum (Coercion a b) where

@@ -4,14 +4,14 @@ {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE StandaloneDeriving     #-} {-# LANGUAGE NoImplicitPrelude      #-}-{-# LANGUAGE PolyKinds              #-} {-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE TypeInType             #-} {-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE UndecidableInstances   #-} {-# LANGUAGE ExplicitNamespaces     #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeInType             #-} {-# LANGUAGE Trustworthy            #-}  -----------------------------------------------------------------------------@@ -125,8 +125,7 @@ deriving instance Ord  (a :~: b)  -- | @since 4.7.0.0-instance a ~ b => Read (a :~: b) where-  readsPrec d = readParen (d > 10) (\r -> [(Refl, s) | ("Refl",s) <- lex r ])+deriving instance a ~ b => Read (a :~: b)  -- | @since 4.7.0.0 instance a ~ b => Enum (a :~: b) where@@ -138,7 +137,7 @@ -- | @since 4.7.0.0 deriving instance a ~ b => Bounded (a :~: b) --- | Kind heterogeneous propositional equality. Like '(:~:)', @a :~~: b@ is+-- | Kind heterogeneous propositional equality. Like ':~:', @a :~~: b@ is -- inhabited by a terminating value if and only if @a@ is the same type as @b@. -- -- @since 4.10.0.0@@ -153,8 +152,7 @@ deriving instance Ord  (a :~~: b)  -- | @since 4.10.0.0-instance a ~~ b => Read (a :~~: b) where-  readsPrec d = readParen (d > 10) (\r -> [(HRefl, s) | ("HRefl",s) <- lex r ])+deriving instance a ~~ b => Read (a :~~: b)  -- | @since 4.10.0.0 instance a ~~ b => Enum (a :~~: b) where@@ -181,164 +179,47 @@ instance TestEquality ((:~~:) a) where   testEquality HRefl HRefl = Just Refl --- | A type family to compute Boolean equality. Instances are provided--- only for /open/ kinds, such as @*@ and function kinds. Instances are--- also provided for datatypes exported from base. A poly-kinded instance--- is /not/ provided, as a recursive definition for algebraic kinds is--- generally more useful.-type family (a :: k) == (b :: k) :: Bool infix 4 == -{--This comment explains more about why a poly-kinded instance for (==) is-not provided. To be concrete, here would be the poly-kinded instance:--type family EqPoly (a :: k) (b :: k) where- EqPoly a a = True- EqPoly a b = False-type instance (a :: k) == (b :: k) = EqPoly a b--Note that this overlaps with every other instance -- if this were defined,-it would be the only instance for (==).--Now, consider-data Nat = Zero | Succ Nat--Suppose I want-foo :: (Succ n == Succ m) ~ True => ((n == m) :~: True)-foo = Refl--This would not type-check with the poly-kinded instance. `Succ n == Succ m`-quickly becomes `EqPoly (Succ n) (Succ m)` but then is stuck. We don't know-enough about `n` and `m` to reduce further.--On the other hand, consider this:--type family EqNat (a :: Nat) (b :: Nat) where- EqNat Zero     Zero     = True- EqNat (Succ n) (Succ m) = EqNat n m- EqNat n        m        = False-type instance (a :: Nat) == (b :: Nat) = EqNat a b--With this instance, `foo` type-checks fine. `Succ n == Succ m` becomes `EqNat-(Succ n) (Succ m)` which becomes `EqNat n m`. Thus, we can conclude `(n == m)-~ True` as desired.--So, the Nat-specific instance allows strictly more reductions, and is thus-preferable to the poly-kinded instance. But, if we introduce the poly-kinded-instance, we are barred from writing the Nat-specific instance, due to-overlap.--Even better than the current instance for * would be one that does this sort-of recursion for all datatypes, something like this:--type family EqStar (a :: *) (b :: *) where- EqStar Bool Bool = True- EqStar (a,b) (c,d) = a == c && b == d- EqStar (Maybe a) (Maybe b) = a == b- ...- EqStar a b = False--The problem is the (...) is extensible -- we would want to add new cases for-all datatypes in scope. This is not currently possible for closed type-families.--}---- all of the following closed type families are local to this module-type family EqStar (a :: *) (b :: *) where-  EqStar a a = 'True-  EqStar a b = 'False---- This looks dangerous, but it isn't. This allows == to be defined--- over arbitrary type constructors.-type family EqArrow (a :: k1 -> k2) (b :: k1 -> k2) where-  EqArrow a a = 'True-  EqArrow a b = 'False--type family EqBool a b where-  EqBool 'True  'True  = 'True-  EqBool 'False 'False = 'True-  EqBool a      b      = 'False--type family EqOrdering a b where-  EqOrdering 'LT 'LT = 'True-  EqOrdering 'EQ 'EQ = 'True-  EqOrdering 'GT 'GT = 'True-  EqOrdering a   b   = 'False--type EqUnit (a :: ()) (b :: ()) = 'True--type family EqList a b where-  EqList '[]        '[]        = 'True-  EqList (h1 ': t1) (h2 ': t2) = (h1 == h2) && (t1 == t2)-  EqList a          b          = 'False--type family EqMaybe a b where-  EqMaybe 'Nothing   'Nothing  = 'True-  EqMaybe ('Just x) ('Just y)  = x == y-  EqMaybe a         b          = 'False--type family Eq2 a b where-  Eq2 '(a1, b1) '(a2, b2) = a1 == a2 && b1 == b2--type family Eq3 a b where-  Eq3 '(a1, b1, c1) '(a2, b2, c2) = a1 == a2 && b1 == b2 && c1 == c2--type family Eq4 a b where-  Eq4 '(a1, b1, c1, d1) '(a2, b2, c2, d2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2--type family Eq5 a b where-  Eq5 '(a1, b1, c1, d1, e1) '(a2, b2, c2, d2, e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2--type family Eq6 a b where-  Eq6 '(a1, b1, c1, d1, e1, f1) '(a2, b2, c2, d2, e2, f2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2--type family Eq7 a b where-  Eq7 '(a1, b1, c1, d1, e1, f1, g1) '(a2, b2, c2, d2, e2, f2, g2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2--type family Eq8 a b where-  Eq8 '(a1, b1, c1, d1, e1, f1, g1, h1) '(a2, b2, c2, d2, e2, f2, g2, h2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2--type family Eq9 a b where-  Eq9 '(a1, b1, c1, d1, e1, f1, g1, h1, i1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2--type family Eq10 a b where-  Eq10 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2--type family Eq11 a b where-  Eq11 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2--type family Eq12 a b where-  Eq12 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2--type family Eq13 a b where-  Eq13 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2--type family Eq14 a b where-  Eq14 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2--type family Eq15 a b where-  Eq15 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 && o1 == o2+-- | A type family to compute Boolean equality.+type family (a :: k) == (b :: k) :: Bool where+  f a == g b = f == g && a == b+  a == a = 'True+  _ == _ = 'False --- these all look to be overlapping, but they are differentiated by their kinds-type instance a == b = EqStar a b-type instance a == b = EqArrow a b-type instance a == b = EqBool a b-type instance a == b = EqOrdering a b-type instance a == b = EqUnit a b-type instance a == b = EqList a b-type instance a == b = EqMaybe a b-type instance a == b = Eq2 a b-type instance a == b = Eq3 a b-type instance a == b = Eq4 a b-type instance a == b = Eq5 a b-type instance a == b = Eq6 a b-type instance a == b = Eq7 a b-type instance a == b = Eq8 a b-type instance a == b = Eq9 a b-type instance a == b = Eq10 a b-type instance a == b = Eq11 a b-type instance a == b = Eq12 a b-type instance a == b = Eq13 a b-type instance a == b = Eq14 a b-type instance a == b = Eq15 a b+-- The idea here is to recognize equality of *applications* using+-- the first case, and of *constructors* using the second and third+-- ones. It would be wonderful if GHC recognized that the+-- first and second cases are compatible, which would allow us to+-- prove+--+-- a ~ b => a == b+--+-- but it (understandably) does not.+--+-- It is absolutely critical that the three cases occur in precisely+-- this order. In particular, if+--+-- a == a = 'True+--+-- came first, then the type application case would only be reached+-- (uselessly) when GHC discovered that the types were not equal.+--+-- One might reasonably ask what's wrong with a simpler version:+--+-- type family (a :: k) == (b :: k) where+--  a == a = True+--  a == b = False+--+-- Consider+-- data Nat = Zero | Succ Nat+--+-- Suppose I want+-- foo :: (Succ n == Succ m) ~ True => ((n == m) :~: True)+-- foo = Refl+--+-- This would not type-check with the simple version. `Succ n == Succ m`+-- is stuck. We don't know enough about `n` and `m` to reduce the family.+-- With the recursive version, `Succ n == Succ m` reduces to+-- `Succ == Succ && n == m`, which can reduce to `'True && n == m` and+-- finally to `n == m`.

@@ -86,8 +86,6 @@        -- * For backwards compatibility     , typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7-    , Typeable1, Typeable2, Typeable3, Typeable4-    , Typeable5, Typeable6, Typeable7     ) where  import qualified Data.Typeable.Internal as I@@ -225,19 +223,3 @@ typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)                 (g :: *). Typeable t => t a b c d e f g -> TypeRep typeOf7 _ = I.someTypeRep (Proxy :: Proxy t)--type Typeable1 (a :: * -> *)                               = Typeable a-type Typeable2 (a :: * -> * -> *)                          = Typeable a-type Typeable3 (a :: * -> * -> * -> *)                     = Typeable a-type Typeable4 (a :: * -> * -> * -> * -> *)                = Typeable a-type Typeable5 (a :: * -> * -> * -> * -> * -> *)           = Typeable a-type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *)      = Typeable a-type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a--{-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8-{-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8-{-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8-{-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8-{-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8-{-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8-{-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8

@@ -18,6 +18,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- -- |@@ -75,7 +76,7 @@      -- * Construction     -- | These are for internal use only-    mkTrCon, mkTrApp, mkTrFun,+    mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun,     mkTyCon, mkTyCon#,     typeSymbolTypeRep, typeNatTypeRep,   ) where@@ -87,7 +88,7 @@ import GHC.List ( splitAt, foldl' ) import GHC.Word import GHC.Show-import GHC.TypeLits ( KnownSymbol, symbolVal' )+import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol ) import GHC.TypeNats ( KnownNat, natVal' ) import Unsafe.Coerce ( unsafeCoerce ) @@ -97,6 +98,7 @@    -- Better to break the loop here, because we want non-SOURCE imports    -- of Data.Typeable as much as possible so we can optimise the derived    -- instances.+-- import {-# SOURCE #-} Debug.Trace (trace)  #include "MachDeps.h" @@ -178,20 +180,111 @@ -- | A concrete representation of a (monomorphic) type. -- 'TypeRep' supports reasonably efficient equality. data TypeRep (a :: k) where-    TrTyCon :: {-# UNPACK #-} !Fingerprint -> !TyCon -> [SomeTypeRep]+    -- The TypeRep of Type. See Note [Kind caching], Wrinkle 2+    TrType :: TypeRep Type+    TrTyCon :: { -- See Note [TypeRep fingerprints]+                 trTyConFingerprint :: {-# UNPACK #-} !Fingerprint++                 -- The TypeRep represents the application of trTyCon+                 -- to the kind arguments trKindVars. So for+                 -- 'Just :: Bool -> Maybe Bool, the trTyCon will be+                 -- 'Just and the trKindVars will be [Bool].+               , trTyCon :: !TyCon+               , trKindVars :: [SomeTypeRep]+               , trTyConKind :: !(TypeRep k) }  -- See Note [Kind caching]             -> TypeRep (a :: k)++    -- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@)+    -- are represented with @'TrFun' a b@, not @TrApp (TrApp funTyCon a) b@.     TrApp   :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-               {-# UNPACK #-} !Fingerprint-            -> TypeRep (a :: k1 -> k2)-            -> TypeRep (b :: k1)+               { -- See Note [TypeRep fingerprints]+                 trAppFingerprint :: {-# UNPACK #-} !Fingerprint++                 -- The TypeRep represents the application of trAppFun+                 -- to trAppArg. For Maybe Int, the trAppFun will be Maybe+                 -- and the trAppArg will be Int.+               , trAppFun :: !(TypeRep (a :: k1 -> k2))+               , trAppArg :: !(TypeRep (b :: k1))+               , trAppKind :: !(TypeRep k2) }   -- See Note [Kind caching]             -> TypeRep (a b)++    -- | @TrFun fpr a b@ represents a function type @a -> b@. We use this for+    -- the sake of efficiency as functions are quite ubiquitous.     TrFun   :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)                       (a :: TYPE r1) (b :: TYPE r2).-               {-# UNPACK #-} !Fingerprint-            -> TypeRep a-            -> TypeRep b+               { -- See Note [TypeRep fingerprints]+                 trFunFingerprint :: {-# UNPACK #-} !Fingerprint++                 -- The TypeRep represents a function from trFunArg to+                 -- trFunRes.+               , trFunArg :: !(TypeRep a)+               , trFunRes :: !(TypeRep b) }             -> TypeRep (a -> b) +{- Note [TypeRep fingerprints]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+We store a Fingerprint of each TypeRep in its constructor. This allows+us to test whether two TypeReps are equal in constant time, rather than+having to walk their full structures.+-}++{- Note [Kind caching]+   ~~~~~~~~~~~~~~~~~~~++We cache the kind of the TypeRep in each TrTyCon and TrApp constructor.+This is necessary to ensure that typeRepKind (which is used, at least, in+deserialization and dynApply) is cheap. There are two reasons for this:++1. Calculating the kind of a nest of type applications, such as++  F X Y Z W   (App (App (App (App F X) Y) Z) W)++is linear in the depth, which is already a bit pricy. In deserialization,+we build up such a nest from the inside out, so without caching, that ends+up taking quadratic time, and calculating the KindRep of the constructor,+F, a linear number of times. See #14254.++2. Calculating the kind of a type constructor, in instantiateTypeRep,+requires building (allocating) a TypeRep for the kind "from scratch".+This can get pricy. When combined with point (1), we can end up with+a large amount of extra allocation deserializing very deep nests.+See #14337.++It is quite possible to speed up deserialization by structuring that process+very carefully. Unfortunately, that doesn't help dynApply or anything else+that may use typeRepKind. Since caching the kind isn't terribly expensive, it+seems better to just do that and solve all the potential problems at once.++There are two things we need to be careful about when caching kinds.++Wrinkle 1:++We want to do it eagerly. Suppose we have++  tf :: TypeRep (f :: j -> k)+  ta :: TypeRep (a :: j)++Then the cached kind of App tf ta should be eagerly evaluated to k, rather+than being stored as a thunk that will strip the (j ->) off of j -> k if+and when it is forced.++Wrinkle 2:++We need to be able to represent TypeRep Type. This is a bit tricky because+typeRepKind (typeRep @Type) = typeRep @Type, so if we actually cache the+typerep of the kind of Type, we will have a loop. One simple way to do this+is to make the cached kind fields lazy and allow TypeRep Type to be cyclical.++But we *do not* want TypeReps to have cyclical structure! Most importantly,+a cyclical structure cannot be stored in a compact region. Secondarily,+using :force in GHCi on a cyclical structure will lead to non-termination.++To avoid this trouble, we use a separate constructor for TypeRep Type.+mkTrApp is responsible for recognizing that TYPE is being applied to+'LiftedRep and produce trType; other functions must recognize that TrType+represents an application.+-}+ -- Compare keys for equality  -- | @since 2.01@@ -229,6 +322,7 @@ -- | The function type constructor. -- -- For instance,+-- -- @ -- typeRep \@(Int -> Char) === Fun (typeRep \@Int) (typeRep \@Char) -- @@@ -240,90 +334,217 @@             => TypeRep arg             -> TypeRep res             -> TypeRep fun-pattern Fun arg res <- TrFun _ arg res+pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res}   where Fun arg res = mkTrFun arg res  -- | Observe the 'Fingerprint' of a type representation -- -- @since 4.8.0.0 typeRepFingerprint :: TypeRep a -> Fingerprint-typeRepFingerprint (TrTyCon fpr _ _) = fpr-typeRepFingerprint (TrApp fpr _ _) = fpr-typeRepFingerprint (TrFun fpr _ _) = fpr+typeRepFingerprint TrType = fpTYPELiftedRep+typeRepFingerprint (TrTyCon {trTyConFingerprint = fpr}) = fpr+typeRepFingerprint (TrApp {trAppFingerprint = fpr}) = fpr+typeRepFingerprint (TrFun {trFunFingerprint = fpr}) = fpr +-- For compiler use+mkTrType :: TypeRep Type+mkTrType = TrType+ -- | Construct a representation for a type constructor -- applied at a monomorphic kind. -- -- Note that this is unsafe as it allows you to construct -- ill-kinded types. mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a-mkTrCon tc kind_vars = TrTyCon fpr tc kind_vars+mkTrCon tc kind_vars = TrTyCon+    { trTyConFingerprint = fpr+    , trTyCon = tc+    , trKindVars = kind_vars+    , trTyConKind = kind }   where     fpr_tc  = tyConFingerprint tc     fpr_kvs = map someTypeRepFingerprint kind_vars     fpr     = fingerprintFingerprints (fpr_tc:fpr_kvs)+    kind    = unsafeCoerceRep $ tyConKind tc kind_vars --- | Construct a representation for a type application.---+-- The fingerprint of Type. We don't store this in the TrType+-- constructor, so we need to build it here.+fpTYPELiftedRep :: Fingerprint+fpTYPELiftedRep = fingerprintFingerprints+      [tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep]+-- There is absolutely nothing to gain and everything to lose+-- by inlining the worker. The wrapper should inline anyway.+{-# NOINLINE fpTYPELiftedRep #-}++trTYPE :: TypeRep TYPE+trTYPE = typeRep++trLiftedRep :: TypeRep 'LiftedRep+trLiftedRep = typeRep++-- | Construct a representation for a type application that is+-- NOT a saturated arrow type. This is not checked!+ -- Note that this is known-key to the compiler, which uses it in desugar -- 'Typeable' evidence. mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).            TypeRep (a :: k1 -> k2)         -> TypeRep (b :: k1)         -> TypeRep (a b)-mkTrApp a b = TrApp fpr a b+mkTrApp a b -- See Note [Kind caching], Wrinkle 2+  | Just HRefl <- a `eqTypeRep` trTYPE+  , Just HRefl <- b `eqTypeRep` trLiftedRep+  = TrType++  | TrFun {trFunRes = res_kind} <- typeRepKind a+  = TrApp+    { trAppFingerprint = fpr+    , trAppFun = a+    , trAppArg = b+    , trAppKind = res_kind }++  | otherwise = error ("Ill-kinded type application: "+                           ++ show (typeRepKind a))   where     fpr_a = typeRepFingerprint a     fpr_b = typeRepFingerprint b     fpr   = fingerprintFingerprints [fpr_a, fpr_b] +-- | Construct a representation for a type application that+-- may be a saturated arrow type. This is renamed to mkTrApp in+-- Type.Reflection.Unsafe+mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).+                  TypeRep (a :: k1 -> k2)+               -> TypeRep (b :: k1)+               -> TypeRep (a b)+mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x})+               (y :: TypeRep y)+  | TrTyCon {trTyCon=con} <- p+  , con == funTyCon  -- cheap check first+  , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)+  , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)+  , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry+                  $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep+  = mkTrFun x y+mkTrAppChecked a b = mkTrApp a b+ -- | A type application. -- -- For instance,+-- -- @ -- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int) -- @--- Note that this will never match a function type (e.g. @Int -> Char@). --+-- Note that this will also match a function type,+--+-- @+-- typeRep \@(Int# -> Char)+--   ===+-- App (App arrow (typeRep \@Int#)) (typeRep \@Char)+-- @+--+-- where @arrow :: TypeRep ((->) :: TYPE IntRep -> Type -> Type)@.+-- pattern App :: forall k2 (t :: k2). ()             => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)             => TypeRep a -> TypeRep b -> TypeRep t-pattern App f x <- TrApp _ f x-  where App f x = mkTrApp f x+pattern App f x <- (splitApp -> IsApp f x)+  where App f x = mkTrAppChecked f x +data AppOrCon (a :: k) where+    IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()+          => TypeRep f -> TypeRep x -> AppOrCon (f x)+    -- See Note [Con evidence]+    IsCon :: IsApplication a ~ "" => TyCon -> [SomeTypeRep] -> AppOrCon a++type family IsApplication (x :: k) :: Symbol where+  IsApplication (_ _) = "An error message about this unifying with \"\" "+     `AppendSymbol` "means that you tried to match a TypeRep with Con or "+     `AppendSymbol` "Con' when the represented type was known to be an "+     `AppendSymbol` "application."+  IsApplication _ = ""++splitApp :: forall k (a :: k). ()+         => TypeRep a+         -> AppOrCon a+splitApp TrType = IsApp trTYPE trLiftedRep+splitApp (TrApp {trAppFun = f, trAppArg = x}) = IsApp f x+splitApp rep@(TrFun {trFunArg=a, trFunRes=b}) = IsApp (mkTrApp arr a) b+  where arr = bareArrow rep+splitApp (TrTyCon{trTyCon = con, trKindVars = kinds})+  = case unsafeCoerce Refl :: IsApplication a :~: "" of+      Refl -> IsCon con kinds+ -- | Use a 'TypeRep' as 'Typeable' evidence.-withTypeable :: forall a r. TypeRep a -> (Typeable a => r) -> r+withTypeable :: forall (a :: k) (r :: TYPE rep). ()+             => TypeRep a -> (Typeable a => r) -> r withTypeable rep k = unsafeCoerce k' rep   where k' :: Gift a r         k' = Gift k  -- | A helper to satisfy the type checker in 'withTypeable'.-newtype Gift a r = Gift (Typeable a => r)+newtype Gift a (r :: TYPE rep) = Gift (Typeable a => r)  -- | Pattern match on a type constructor-pattern Con :: forall k (a :: k). TyCon -> TypeRep a-pattern Con con <- TrTyCon _ con _+pattern Con :: forall k (a :: k). ()+            => IsApplication a ~ "" -- See Note [Con evidence]+            => TyCon -> TypeRep a+pattern Con con <- (splitApp -> IsCon con _)  -- | Pattern match on a type constructor including its instantiated kind -- variables. -- -- For instance,+-- -- @ -- App (Con' proxyTyCon ks) intRep = typeRep @(Proxy \@Int) -- @+-- -- will bring into scope,+-- -- @ -- proxyTyCon :: TyCon -- ks         == [someTypeRep @Type] :: [SomeTypeRep] -- intRep     == typeRep @Int -- @ ---pattern Con' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a-pattern Con' con ks <- TrTyCon _ con ks+pattern Con' :: forall k (a :: k). ()+             => IsApplication a ~ "" -- See Note [Con evidence]+             => TyCon -> [SomeTypeRep] -> TypeRep a+pattern Con' con ks <- (splitApp -> IsCon con ks) +-- TODO: Remove Fun when #14253 is fixed {-# COMPLETE Fun, App, Con  #-} {-# COMPLETE Fun, App, Con' #-} +{- Note [Con evidence]+    ~~~~~~~~~~~~~~~~~~~++Matching TypeRep t on Con or Con' fakes up evidence that++  IsApplication t ~ "".++Why should anyone care about the value of strange internal type family?+Well, almost nobody cares about it, but the pattern checker does!+For example, suppose we have TypeRep (f x) and we want to get+TypeRep f and TypeRep x. There is no chance that the Con constructor+will match, because (f x) is not a constructor, but without the+IsApplication evidence, omitting it will lead to an incomplete pattern+warning. With the evidence, the pattern checker will see that+Con wouldn't typecheck, so everything works out as it should.++Why do we use Symbols? We would really like to use something like++  type family NotApplication (t :: k) :: Constraint where+    NotApplication (f a) = TypeError ...+    NotApplication _ = ()++Unfortunately, #11503 means that the pattern checker and type checker+will fail to actually reject the mistaken patterns. So we describe the+error in the result type. It's a horrible hack.+-}+ ----------------- Observation ---------------------  -- | Observe the type constructor of a quantified type representation.@@ -332,9 +553,10 @@  -- | Observe the type constructor of a type representation typeRepTyCon :: TypeRep a -> TyCon-typeRepTyCon (TrTyCon _ tc _) = tc-typeRepTyCon (TrApp _ a _)    = typeRepTyCon a-typeRepTyCon (TrFun _ _ _)    = typeRepTyCon $ typeRep @(->)+typeRepTyCon TrType = tyConTYPE+typeRepTyCon (TrTyCon {trTyCon = tc}) = tc+typeRepTyCon (TrApp {trAppFun = a})   = typeRepTyCon a+typeRepTyCon (TrFun {})               = typeRepTyCon $ typeRep @(->)  -- | Type equality --@@ -354,14 +576,10 @@  -- | Observe the kind of a type. typeRepKind :: TypeRep (a :: k) -> TypeRep k-typeRepKind (TrTyCon _ tc args)-  = unsafeCoerceRep $ tyConKind tc args-typeRepKind (TrApp _ f _)-  | Fun _ res <- typeRepKind f-  = res-  | otherwise-  = error ("Ill-kinded type application: " ++ show (typeRepKind f))-typeRepKind (TrFun _ _ _) = typeRep @Type+typeRepKind TrType = TrType+typeRepKind (TrTyCon {trTyConKind = kind}) = kind+typeRepKind (TrApp {trAppKind = kind}) = kind+typeRepKind (TrFun {}) = typeRep @Type  tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep tyConKind (TyCon _ _ _ _ nKindVars# kindRep) kindVars =@@ -382,14 +600,15 @@             applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep             applyTy (SomeTypeRep acc) ty               | SomeTypeRep ty' <- go ty-              = SomeTypeRep $ mkTrApp (unsafeCoerce acc) (unsafeCoerce ty')+              = SomeTypeRep $ mkTrApp (unsafeCoerce acc) ty'         in foldl' applyTy tycon_app ty_args     go (KindRepVar var)       = vars A.! var     go (KindRepApp f a)-      = SomeTypeRep $ App (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)+      = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)     go (KindRepFun a b)-      = SomeTypeRep $ Fun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)+      = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)+    go (KindRepTYPE LiftedRep) = SomeTypeRep TrType     go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r     go (KindRepTypeLitS sort s)       = mkTypeLitFromString sort (unpackCStringUtf8# s)@@ -412,7 +631,7 @@      -> SomeKindedTypeRep k      -> SomeKindedTypeRep k' kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) =-    SomeKindedTypeRep (App f a)+    SomeKindedTypeRep (mkTrApp f a)  kindedTypeRep :: forall (a :: k). Typeable a => SomeKindedTypeRep k kindedTypeRep = SomeKindedTypeRep (typeRep @a)@@ -478,6 +697,34 @@     rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem     rep = kindedTypeRep @VecElem @a +bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                    (a :: TYPE r1) (b :: TYPE r2). ()+          => TypeRep (a -> b)+          -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type)+bareArrow (TrFun _ a b) =+    mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2]+  where+    rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1+    rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2+bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible"++data IsTYPE (a :: Type) where+    IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r)++-- | Is a type of the form @TYPE rep@?+isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)+isTYPE TrType = Just (IsTYPE trLiftedRep)+isTYPE (TrApp {trAppFun=f, trAppArg=r})+  | Just HRefl <- f `eqTypeRep` typeRep @TYPE+  = Just (IsTYPE r)+isTYPE _ = Nothing++getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r+getRuntimeRep TrType = trLiftedRep+getRuntimeRep (TrApp {trAppArg=r}) = r+getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible"++ ------------------------------------------------------------- -- --      The Typeable class and friends@@ -515,25 +762,24 @@   showTypeable :: Int -> TypeRep (a :: k) -> ShowS+showTypeable _ TrType = showChar '*' showTypeable _ rep-  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) =-    showChar '*'   | isListTyCon tc, [ty] <- tys =     showChar '[' . shows ty . showChar ']'   | isTupleTyCon tc =     showChar '(' . showArgs (showChar ',') tys . showChar ')'   where (tc, tys) = splitApps rep-showTypeable p (TrTyCon _ tycon [])+showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = []})   = showsPrec p tycon-showTypeable p (TrTyCon _ tycon args)+showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args})   = showParen (p > 9) $     showsPrec p tycon .     showChar ' ' .     showArgs (showChar ' ') args-showTypeable p (TrFun _ x r)+showTypeable p (TrFun {trFunArg = x, trFunRes = r})   = showParen (p > 8) $     showsPrec 9 x . showString " -> " . showsPrec 8 r-showTypeable p (TrApp _ f x)+showTypeable p (TrApp {trAppFun = f, trAppArg = x})   = showParen (p > 9) $     showsPrec 8 f .     showChar ' ' .@@ -547,17 +793,40 @@ splitApps = go []   where     go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])-    go xs (TrTyCon _ tc _) = (tc, xs)-    go xs (TrApp _ f x)    = go (SomeTypeRep x : xs) f-    go [] (TrFun _ a b)    = (funTyCon, [SomeTypeRep a, SomeTypeRep b])-    go _  (TrFun _ _ _)    =-        errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible"+    go xs (TrTyCon {trTyCon = tc})+      = (tc, xs)+    go xs (TrApp {trAppFun = f, trAppArg = x})+      = go (SomeTypeRep x : xs) f+    go [] (TrFun {trFunArg = a, trFunRes = b})+      = (funTyCon, [SomeTypeRep a, SomeTypeRep b])+    go _  (TrFun {})+      = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"+    go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])+    go _ TrType+      = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2" +-- This is incredibly shady! We don't really want to do this here; we+-- should really have the compiler reveal the TYPE TyCon directly+-- somehow. We need to construct this by hand because otherwise+-- we end up with horrible and somewhat mysterious loops trying to calculate+-- typeRep @TYPE. For the moment, we use the fact that we can get the proper+-- name of the ghc-prim package from the TyCon of LiftedRep (which we can+-- produce a TypeRep for without difficulty), and then just substitute in the+-- appropriate module and constructor names.+--+-- The ticket to find a better way to deal with this is+-- Trac #14480.+tyConTYPE :: TyCon+tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0+       (KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep))+  where+    liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep)+ funTyCon :: TyCon funTyCon = typeRepTyCon (typeRep @(->))  isListTyCon :: TyCon -> Bool-isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [Int])+isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [])  isTupleTyCon :: TyCon -> Bool isTupleTyCon tc@@ -573,9 +842,11 @@ -- -- @since 4.8.0.0 rnfTypeRep :: TypeRep a -> ()-rnfTypeRep (TrTyCon _ tyc _) = rnfTyCon tyc-rnfTypeRep (TrApp _ f x)     = rnfTypeRep f `seq` rnfTypeRep x-rnfTypeRep (TrFun _ x y)     = rnfTypeRep x `seq` rnfTypeRep y+-- The TypeRep structure is almost entirely strict by definition. The+-- fingerprinting and strict kind caching ensure that everything+-- else is forced anyway. So we don't need to do anything special+-- to reduce to normal form.+rnfTypeRep !_ = ()  -- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@ -- implementation@@ -687,7 +958,10 @@ mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)                   (a :: TYPE r1) (b :: TYPE r2).            TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type)-mkTrFun arg res = TrFun fpr arg res+mkTrFun arg res = TrFun+    { trFunFingerprint = fpr+    , trFunArg = arg+    , trFunRes = res }   where fpr = fingerprintFingerprints [ typeRepFingerprint arg                                       , typeRepFingerprint res] 

@@ -6,7 +6,7 @@ -- Module      :  Data.Unique -- Copyright   :  (c) The University of Glasgow 2001 -- License     :  BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer  :  libraries@haskell.org -- Stability   :  experimental -- Portability :  non-portable@@ -30,6 +30,15 @@  -- | An abstract unique object.  Objects of type 'Unique' may be -- compared for equality and ordering and hashed into 'Int'.+--+-- >>> :{+-- do x <- newUnique+--    print (x == x)+--    y <- newUnique+--    print (x == y)+-- :}+-- True+-- False newtype Unique = Unique Integer deriving (Eq,Ord)  uniqSource :: IORef Integer

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} @@ -28,31 +29,22 @@ import Data.Data import Data.Ix import GHC.Generics+import Data.Semigroup (Semigroup(..), stimesIdempotent)  -- | Uninhabited data type -- -- @since 4.8.0.0-data Void deriving (Generic)--deriving instance Data Void---- | @since 4.8.0.0-instance Eq Void where-    _ == _ = True---- | @since 4.8.0.0-instance Ord Void where-    compare _ _ = EQ---- | Reading a 'Void' value is always a parse error, considering--- 'Void' as a data type with no constructors.--- | @since 4.8.0.0-instance Read Void where-    readsPrec _ _ = []---- | @since 4.8.0.0-instance Show Void where-    showsPrec _ = absurd+data Void deriving+  ( Eq      -- ^ @since 4.8.0.0+  , Data    -- ^ @since 4.8.0.0+  , Generic -- ^ @since 4.8.0.0+  , Ord     -- ^ @since 4.8.0.0+  , Read    -- ^ Reading a 'Void' value is always a parse error, considering+            -- 'Void' as a data type with no constructors.+            --+            -- @since 4.8.0.0+  , Show    -- ^ @since 4.8.0.0+  )  -- | @since 4.8.0.0 instance Ix Void where@@ -64,8 +56,21 @@ -- | @since 4.8.0.0 instance Exception Void +-- | @since 4.9.0.0+instance Semigroup Void where+    a <> _ = a+    stimes = stimesIdempotent+ -- | Since 'Void' values logically don't exist, this witnesses the -- logical reasoning tool of \"ex falso quodlibet\".+--+-- >>> let x :: Either Void Int; x = Right 5+-- >>> :{+-- case x of+--     Right r -> r+--     Left l  -> absurd l+-- :}+-- 5 -- -- @since 4.8.0.0 absurd :: Void -> a

@@ -6,7 +6,7 @@ -- Module      :  Data.Word -- Copyright   :  (c) The University of Glasgow 2001 -- License     :  BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer  :  libraries@haskell.org -- Stability   :  experimental -- Portability :  portable@@ -31,6 +31,7 @@         ) where  import GHC.Word+import GHC.Read () -- Need the `Read` instance for types defined in `GHC.Word`.  {- $notes @@ -55,6 +56,6 @@   of the type result in a zero result.  This is contrary to the   behaviour in C, which is undefined; a common interpretation is to   truncate the shift count to the width of the type, for example @1 \<\<-  32 == 1@ in some C implementations. +  32 == 1@ in some C implementations. -} 

@@ -55,6 +55,9 @@ import GHC.Stack import Data.List +-- $setup+-- >>> import Prelude+ -- $tracing -- -- The 'trace', 'traceShow' and 'traceIO' functions print messages to an output@@ -104,7 +107,10 @@  For example, this returns the value of @f x@ but first outputs the message. -> trace ("calling f with x = " ++ show x) (f x)+>>> let x = 123; f = show+>>> trace ("calling f with x = " ++ show x) (f x)+"calling f with x = 123+123"  The 'trace' function should /only/ be used for debugging, or for monitoring execution. The function is not referentially transparent: its type indicates@@ -119,6 +125,10 @@ {-| Like 'trace' but returns the message instead of a third value. +>>> traceId "hello"+"hello+hello"+ @since 4.7.0.0 -} traceId :: String -> String@@ -129,23 +139,26 @@  This makes it convenient for printing the values of interesting variables or expressions inside a function. For example here we print the value of the-variables @x@ and @z@:+variables @x@ and @y@: -> f x y =->     traceShow (x, z) $ result->   where->     z = ...->     ...+>>> let f x y = traceShow (x,y) (x + y) in f (1+2) 5+(3,5)+8+ -}-traceShow :: (Show a) => a -> b -> b+traceShow :: Show a => a -> b -> b traceShow = trace . show  {-| Like 'traceShow' but returns the shown value instead of a third value. +>>> traceShowId (1+2+3, "hello" ++ "world")+(6,"helloworld")+(6,"helloworld")+ @since 4.7.0.0 -}-traceShowId :: (Show a) => a -> a+traceShowId :: Show a => a -> a traceShowId a = trace (show a) a  {-|@@ -159,25 +172,37 @@ and the message would only be printed once.  If your monad is in 'MonadIO', @liftIO . traceIO@ may be a better option. -> ... = do->   x <- ...->   traceM $ "x: " ++ show x->   y <- ...->   traceM $ "y: " ++ show y+>>> :{+do+    x <- Just 3+    traceM ("x: " ++ show x)+    y <- pure 12+    traceM ("y: " ++ show y)+    pure (x*2 + y)+:}+x: 3+y: 12+Just 18  @since 4.7.0.0 -}-traceM :: (Applicative f) => String -> f ()+traceM :: Applicative f => String -> f () traceM string = trace string $ pure ()  {-| Like 'traceM', but uses 'show' on the argument to convert it to a 'String'. -> ... = do->   x <- ...->   traceShowM $ x->   y <- ...->   traceShowM $ x + y+>>> :{+do+    x <- Just 3+    traceShowM x+    y <- pure 12+    traceShowM y+    pure (x*2 + y)+:}+3+12+Just 18  @since 4.7.0.0 -}

@@ -0,0 +1,76 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UnboxedTuples #-}++-- This boot file is necessary to allow GHC developers to+-- use trace facilities in those (relatively few) modules that Debug.Trace+-- itself depends on. It is also necessary to make DsMonad.pprRuntimeTrace+-- trace injections work in those modules.++-----------------------------------------------------------------------------+-- |+-- Module      :  Debug.Trace+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for tracing and monitoring execution.+--+-- These can be useful for investigating bugs or performance problems.+-- They should /not/ be used in production code.+--+-----------------------------------------------------------------------------++module Debug.Trace (+        -- * Tracing+        -- $tracing+        trace,+        traceId,+        traceShow,+        traceShowId,+        traceStack,+        traceIO,+        traceM,+        traceShowM,++        -- * Eventlog tracing+        -- $eventlog_tracing+        traceEvent,+        traceEventIO,++        -- * Execution phase markers+        -- $markers+        traceMarker,+        traceMarkerIO,+  ) where++import GHC.Base+import GHC.Show++traceIO :: String -> IO ()++trace :: String -> a -> a++traceId :: String -> String++traceShow :: Show a => a -> b -> b++traceShowId :: Show a => a -> a++traceM :: Applicative f => String -> f ()++traceShowM :: (Show a, Applicative f) => a -> f ()++traceStack :: String -> a -> a++traceEvent :: String -> a -> a++traceEventIO :: String -> IO ()++traceMarker :: String -> a -> a++traceMarkerIO :: String -> IO ()

@@ -420,7 +420,7 @@ cWcharsToChars :: [CWchar] -> [Char] charsToCWchars :: [Char] -> [CWchar] -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)  -- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding. 

@@ -15,6 +15,9 @@ -- Foreign Function Interface (FFI) and will usually be imported via -- the "Foreign" module. --+-- For non-portable support of Haskell finalizers, see the+-- "Foreign.Concurrent" module.+-- -----------------------------------------------------------------------------  module Foreign.ForeignPtr ( 

@@ -123,19 +123,6 @@     doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'     doAlloca dummy  = allocaBytesAligned (sizeOf dummy) (alignment dummy) --- Note [NOINLINE for touch#]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~--- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously--- fragile in the presence of simplification (see #14346). In particular, the--- simplifier may drop the continuation containing the touch# if it can prove--- that the action passed to allocaBytes will not return. The hack introduced to--- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the--- simplifier can't see the divergence.------ These can be removed once #14375 is fixed, which suggests that we instead do--- away with touch# in favor of a primitive that will capture the scoping left--- implicit in the case of touch#.- -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument -- a pointer to a temporarily allocated block of memory of @n@ bytes. -- The block of memory is sufficiently aligned for any of the basic@@ -154,8 +141,6 @@      case touch# barr# s3 of { s4 ->      (# s4, r #)   }}}}}--- See Note [NOINLINE for touch#]-{-# NOINLINE allocaBytes #-}  allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->@@ -167,8 +152,6 @@      case touch# barr# s3 of { s4 ->      (# s4, r #)   }}}}}--- See Note [NOINLINE for touch#]-{-# NOINLINE allocaBytesAligned #-}  -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' -- to the size needed to store values of type @b@.  The returned pointer

@@ -129,6 +129,14 @@ import GHC.Tuple ()     -- Note [Depend on GHC.Tuple] import GHC.Integer ()   -- Note [Depend on GHC.Integer] +-- for 'class Semigroup'+import {-# SOURCE #-} GHC.Real (Integral)+import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault+                                              , stimesMaybe+                                              , stimesList+                                              , stimesIdempotentMonoid+                                              )+ infixr 9  . infixr 5  ++ infixl 4  <$@@ -204,16 +212,53 @@ data  Maybe a  =  Nothing | Just a   deriving (Eq, Ord) +infixr 6 <>++-- | The class of semigroups (types with an associative binary operation).+--+-- Instances should satisfy the associativity law:+--+--  * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@+--+-- @since 4.9.0.0+class Semigroup a where+        -- | An associative operation.+        (<>) :: a -> a -> a++        -- | Reduce a non-empty list with @\<\>@+        --+        -- The default definition should be sufficient, but this can be+        -- overridden for efficiency.+        --+        sconcat :: NonEmpty a -> a+        sconcat (a :| as) = go a as where+          go b (c:cs) = b <> go c cs+          go b []     = b++        -- | Repeat a value @n@ times.+        --+        -- Given that this works on a 'Semigroup' it is allowed to fail if+        -- you request 0 or fewer repetitions, and the default definition+        -- will do so.+        --+        -- By making this a member of the class, idempotent semigroups+        -- and monoids can upgrade this to execute in /O(1)/ by+        -- picking @stimes = 'stimesIdempotent'@ or @stimes =+        -- 'stimesIdempotentMonoid'@ respectively.+        stimes :: Integral b => b -> a -> a+        stimes = stimesDefault++ -- | The class of monoids (types with an associative binary operation that -- has an identity).  Instances should satisfy the following laws: -----  * @mappend mempty x = x@+--  * @x '<>' 'mempty' = x@ -----  * @mappend x mempty = x@+--  * @'mempty' '<>' x = x@ -----  * @mappend x (mappend y z) = mappend (mappend x y) z@+--  * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law) -----  * @mconcat = 'foldr' mappend mempty@+--  * @'mconcat' = 'foldr' '(<>)' 'mempty'@ -- -- The method names refer to the monoid of lists under concatenation, -- but there are many other instances.@@ -222,27 +267,39 @@ -- e.g. both addition and multiplication on numbers. -- In such cases we often define @newtype@s and make those instances -- of 'Monoid', e.g. 'Sum' and 'Product'.--class Monoid a where+--+-- __NOTE__: 'Semigroup' is a superclass of 'Monoid' since /base-4.11.0.0/.+class Semigroup a => Monoid a where+        -- | Identity of 'mappend'         mempty  :: a-        -- ^ Identity of 'mappend'++        -- | An associative operation+        --+        -- __NOTE__: This method is redundant and has the default+        -- implementation @'mappend' = '(<>)'@ since /base-4.11.0.0/.         mappend :: a -> a -> a-        -- ^ An associative operation-        mconcat :: [a] -> a+        mappend = (<>)+        {-# INLINE mappend #-} -        -- ^ Fold a list using the monoid.+        -- | Fold a list using the monoid.+        --         -- For most types, the default definition for 'mconcat' will be         -- used, but the function is included in the class definition so         -- that an optimized version can be provided for specific types.-+        mconcat :: [a] -> a         mconcat = foldr mappend mempty +-- | @since 4.9.0.0+instance Semigroup [a] where+        (<>) = (++)+        {-# INLINE (<>) #-}++        stimes = stimesList+ -- | @since 2.01 instance Monoid [a] where         {-# INLINE mempty #-}         mempty  = []-        {-# INLINE mappend #-}-        mappend = (++)         {-# INLINE mconcat #-}         mconcat xss = [x | xs <- xss, x <- xs] -- See Note: [List comprehensions and inlining]@@ -266,66 +323,104 @@ efficient translations anyway. -} +-- | @since 4.9.0.0+instance Semigroup (NonEmpty a) where+        (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs)++-- | @since 4.9.0.0+instance Semigroup b => Semigroup (a -> b) where+        f <> g = \x -> f x <> g x+        stimes n f e = stimes n (f e)+ -- | @since 2.01 instance Monoid b => Monoid (a -> b) where         mempty _ = mempty-        mappend f g x = f x `mappend` g x +-- | @since 4.9.0.0+instance Semigroup () where+        _ <> _      = ()+        sconcat _   = ()+        stimes  _ _ = ()+ -- | @since 2.01 instance Monoid () where         -- Should it be strict?         mempty        = ()-        _ `mappend` _ = ()         mconcat _     = () +-- | @since 4.9.0.0+instance (Semigroup a, Semigroup b) => Semigroup (a, b) where+        (a,b) <> (a',b') = (a<>a',b<>b')+        stimes n (a,b) = (stimes n a, stimes n b)+ -- | @since 2.01 instance (Monoid a, Monoid b) => Monoid (a,b) where         mempty = (mempty, mempty)-        (a1,b1) `mappend` (a2,b2) =-                (a1 `mappend` a2, b1 `mappend` b2) +-- | @since 4.9.0.0+instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where+        (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')+        stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)+ -- | @since 2.01 instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where         mempty = (mempty, mempty, mempty)-        (a1,b1,c1) `mappend` (a2,b2,c2) =-                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2) +-- | @since 4.9.0.0+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)+         => Semigroup (a, b, c, d) where+        (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')+        stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)+ -- | @since 2.01 instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where         mempty = (mempty, mempty, mempty, mempty)-        (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =-                (a1 `mappend` a2, b1 `mappend` b2,-                 c1 `mappend` c2, d1 `mappend` d2) +-- | @since 4.9.0.0+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)+         => Semigroup (a, b, c, d, e) where+        (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')+        stimes n (a,b,c,d,e) =+            (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)+ -- | @since 2.01 instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>                 Monoid (a,b,c,d,e) where         mempty = (mempty, mempty, mempty, mempty, mempty)-        (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =-                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,-                 d1 `mappend` d2, e1 `mappend` e2) ++-- | @since 4.9.0.0+instance Semigroup Ordering where+    LT <> _ = LT+    EQ <> y = y+    GT <> _ = GT++    stimes = stimesIdempotentMonoid+ -- lexicographical ordering -- | @since 2.01 instance Monoid Ordering where-        mempty         = EQ-        LT `mappend` _ = LT-        EQ `mappend` y = y-        GT `mappend` _ = GT+    mempty             = EQ +-- | @since 4.9.0.0+instance Semigroup a => Semigroup (Maybe a) where+    Nothing <> b       = b+    a       <> Nothing = a+    Just a  <> Just b  = Just (a <> b)++    stimes = stimesMaybe+ -- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to -- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be -- turned into a monoid simply by adjoining an element @e@ not in @S@--- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since--- there used to be no \"Semigroup\" typeclass providing just 'mappend',--- we use 'Monoid' instead.+-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" --+-- /Since 4.11.0/: constraint on inner @a@ value generalised from+-- 'Monoid' to 'Semigroup'.+-- -- @since 2.01-instance Monoid a => Monoid (Maybe a) where-  mempty = Nothing-  Nothing `mappend` m = m-  m `mappend` Nothing = m-  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)+instance Semigroup a => Monoid (Maybe a) where+    mempty = Nothing  -- | For tuples, the 'Monoid' constraint on @a@ determines -- how the first values merge.@@ -337,17 +432,20 @@ -- @since 2.01 instance Monoid a => Applicative ((,) a) where     pure x = (mempty, x)-    (u, f) <*> (v, x) = (u `mappend` v, f x)-    liftA2 f (u, x) (v, y) = (u `mappend` v, f x y)+    (u, f) <*> (v, x) = (u <> v, f x)+    liftA2 f (u, x) (v, y) = (u <> v, f x y)  -- | @since 4.9.0.0 instance Monoid a => Monad ((,) a) where-    (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b)+    (u, a) >>= k = case k a of (v, b) -> (u <> v, b) +-- | @since 4.10.0.0+instance Semigroup a => Semigroup (IO a) where+    (<>) = liftA2 (<>)+ -- | @since 4.9.0.0 instance Monoid a => Monoid (IO a) where     mempty = pure mempty-    mappend = liftA2 mappend  {- | The 'Functor' class is used for types that can be mapped over. Instances of 'Functor' should satisfy the following laws:@@ -379,6 +477,7 @@ -- the same as their default definitions: -- --      @('<*>') = 'liftA2' 'id'@+-- --      @'liftA2' f x y = f '<$>' x '<*>' y@ -- -- Further, any definition must satisfy the following:@@ -427,6 +526,8 @@ -- --   * @('<*>') = 'ap'@ --+--   * @('*>') = ('>>')@+-- -- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).  class Functor f => Applicative f where@@ -629,8 +730,8 @@ -- | Promote a function to a monad, scanning the monadic arguments from -- left to right.  For example, ----- >    liftM2 (+) [0,1] [0,2] = [0,2,1,3]--- >    liftM2 (+) (Just 1) Nothing = Nothing+-- > liftM2 (+) [0,1] [0,2] = [0,2,1,3]+-- > liftM2 (+) (Just 1) Nothing = Nothing -- liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }@@ -671,11 +772,11 @@ {- | In many situations, the 'liftM' operations can be replaced by uses of 'ap', which promotes function application. ->       return f `ap` x1 `ap` ... `ap` xn+> return f `ap` x1 `ap` ... `ap` xn  is equivalent to ->       liftMn f x1 x2 ... xn+> liftMn f x1 x2 ... xn  -} @@ -744,9 +845,9 @@ -- If defined, 'some' and 'many' should be the least solutions -- of the equations: ----- * @some v = (:) '<$>' v '<*>' many v@+-- * @'some' v = (:) '<$>' v '<*>' 'many' v@ ----- * @many v = some v '<|>' 'pure' []@+-- * @'many' v = 'some' v '<|>' 'pure' []@ class Applicative f => Alternative f where     -- | The identity of '<|>'     empty :: f a@@ -779,21 +880,59 @@  -- | Monads that also support choice and failure. class (Alternative m, Monad m) => MonadPlus m where-   -- | the identity of 'mplus'.  It should also satisfy the equations+   -- | The identity of 'mplus'.  It should also satisfy the equations    --    -- > mzero >>= f  =  mzero    -- > v >> mzero   =  mzero    --+   -- The default definition is+   --+   -- @+   -- mzero = 'empty'+   -- @    mzero :: m a    mzero = empty -   -- | an associative operation+   -- | An associative operation. The default definition is+   --+   -- @+   -- mplus = ('<|>')+   -- @    mplus :: m a -> m a -> m a    mplus = (<|>)  -- | @since 2.01 instance MonadPlus Maybe +---------------------------------------------+-- The non-empty list type++infixr 5 :|++-- | Non-empty (and non-strict) list type.+--+-- @since 4.9.0.0+data NonEmpty a = a :| [a]+  deriving (Eq, Ord)++-- | @since 4.9.0.0+instance Functor NonEmpty where+  fmap f ~(a :| as) = f a :| fmap f as+  b <$ ~(_ :| as)   = b   :| (b <$ as)++-- | @since 4.9.0.0+instance Applicative NonEmpty where+  pure a = a :| []+  (<*>) = ap+  liftA2 = liftM2++-- | @since 4.9.0.0+instance Monad NonEmpty where+  ~(a :| as) >>= f = b :| (bs ++ bs')+    where b :| bs = f a+          bs' = as >>= toList . f+          toList ~(c :| cs) = c : cs+ ---------------------------------------------- -- The list type @@ -951,26 +1090,41 @@ {-# INLINE [0] mapFB #-} -- See Note [Inline FB functions] in GHC.List mapFB c f = \x ys -> c (f x) ys --- The rules for map work like this.------ Up to (but not including) phase 1, we use the "map" rule to--- rewrite all saturated applications of map with its build/fold--- form, hoping for fusion to happen.--- In phase 1 and 0, we switch off that rule, inline build, and--- switch on the "mapList" rule, which rewrites the foldr/mapFB--- thing back into plain map.------ It's important that these two rules aren't both active at once--- (along with build's unfolding) else we'd get an infinite loop--- in the rules.  Hence the activation control below.------ This same pattern is followed by many other functions:--- e.g. append, filter, iterate, repeat, etc.------ The "mapFB" rule optimises compositions of map and--- the "mapFB/id" rule get rids of 'map id' calls.--- (Any similarity to the Functor laws for [] is expected.)+{- Note [The rules for map]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The rules for map work like this. +* Up to (but not including) phase 1, we use the "map" rule to+  rewrite all saturated applications of map with its build/fold+  form, hoping for fusion to happen.++  In phase 1 and 0, we switch off that rule, inline build, and+  switch on the "mapList" rule, which rewrites the foldr/mapFB+  thing back into plain map.++  It's important that these two rules aren't both active at once+  (along with build's unfolding) else we'd get an infinite loop+  in the rules.  Hence the activation control below.++* This same pattern is followed by many other functions:+  e.g. append, filter, iterate, repeat, etc. in GHC.List++  See also Note [Inline FB functions] in GHC.List++* The "mapFB" rule optimises compositions of map++* The "mapFB/id" rule gets rid of 'map id' calls.+  You might think that (mapFB c id) will turn into c simply+  when mapFB is inlined; but before that happens the "mapList"+  rule turns+     (foldr (mapFB (:) id) [] a+  back into+     map id+  Which is not very clever.++* Any similarity to the Functor laws for [] is expected.+-}+ {-# RULES "map"       [~1] forall f xs.   map f xs                = build (\c n -> foldr (mapFB c f) n xs) "mapList"   [1]  forall f.      foldr (mapFB (:) f) []  = map f@@ -1067,6 +1221,8 @@ ----------------------------------------------  -- | Identity function.+--+-- > id x = x id                      :: a -> a id x                    =  x @@ -1100,7 +1256,8 @@ data Opaque = forall a. O a -- | @const x@ is a unary function which evaluates to @x@ for all inputs. ----- For instance,+-- >>> const 42 "hello"+-- 42 -- -- >>> map (const 42) [0..3] -- [42,42,42,42]@@ -1115,6 +1272,9 @@ (.) f g = \x -> f (g x)  -- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@.+--+-- >>> flip (++) "hello" "world"+-- "worldhello" flip                    :: (a -> b -> c) -> b -> a -> c flip f x y              =  f y x @@ -1123,7 +1283,7 @@ -- low, right-associative binding precedence, so it sometimes allows -- parentheses to be omitted; for example: ----- >     f $ g $ h x  =  f (g (h x))+-- > f $ g $ h x  =  f (g (h x)) -- -- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@, -- or @'Data.List.zipWith' ('$') fs xs@.

@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}++module GHC.Base where++import GHC.Types ()++class Semigroup a+class Monoid a++data Maybe a = Nothing | Just a

@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.ByteOrder+-- Copyright   :  (c) The University of Glasgow, 1994-2000+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Target byte ordering.+--+-----------------------------------------------------------------------------++module GHC.ByteOrder where++-- | Byte ordering.+data ByteOrder+    = BigEndian    -- ^ most-significant-byte occurs in lowest address.+    | LittleEndian -- ^ least-significant-byte occurs in lowest address.+    deriving (Eq, Ord, Bounded, Enum, Read, Show)++-- | The byte ordering of the target machine.+targetByteOrder :: ByteOrder+#if defined(WORDS_BIGENDIAN)+targetByteOrder = BigEndian+#else+targetByteOrder = LittleEndian+#endif

@@ -0,0 +1,25 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE NoImplicitPrelude #-}++module GHC.Clock+    ( getMonotonicTime+    , getMonotonicTimeNSec+    ) where++import GHC.Base+import GHC.Real+import Data.Word++-- | Return monotonic time in seconds, since some unspecified starting point+--+-- @since 4.11.0.0+getMonotonicTime :: IO Double+getMonotonicTime = do w <- getMonotonicTimeNSec+                      return (fromIntegral w / 1000000000)++-- | Return monotonic time in nanoseconds, since some unspecified starting point+--+-- @since 4.11.0.0+foreign import ccall unsafe "getMonotonicNSec"+    getMonotonicTimeNSec :: IO Word64+

@@ -86,7 +86,7 @@          -- * Miscellaneous         , withMVar-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)         , asyncRead         , asyncWrite         , asyncDoProc@@ -95,14 +95,14 @@         , asyncWriteBA #endif -#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS)         , Signal, HandlerFun, setHandler, runHandlers #endif          , ensureIOManagerIsRunning         , ioManagerCapabilitiesChanged -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)         , ConsoleEvent(..)         , win32ConsoleHandler         , toWin32ConsoleEvent@@ -116,6 +116,6 @@ import GHC.Conc.IO import GHC.Conc.Sync -#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) import GHC.Conc.Signal #endif

@@ -39,7 +39,7 @@         , threadWaitWriteSTM         , closeFdWith -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)         , asyncRead         , asyncWrite         , asyncDoProc@@ -59,7 +59,7 @@ import GHC.Real ( fromIntegral ) import System.Posix.Types -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) import qualified GHC.Conc.Windows as Windows import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA,                          asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler,@@ -69,14 +69,14 @@ #endif  ensureIOManagerIsRunning :: IO ()-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning #else ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning #endif  ioManagerCapabilitiesChanged :: IO ()-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged #else ioManagerCapabilitiesChanged = return ()@@ -90,7 +90,7 @@ -- that has been used with 'threadWaitRead', use 'closeFdWith'. threadWaitRead :: Fd -> IO () threadWaitRead fd-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS)   | threaded  = Event.threadWaitRead fd #endif   | otherwise = IO $ \s ->@@ -106,7 +106,7 @@ -- that has been used with 'threadWaitWrite', use 'closeFdWith'. threadWaitWrite :: Fd -> IO () threadWaitWrite fd-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS)   | threaded  = Event.threadWaitWrite fd #endif   | otherwise = IO $ \s ->@@ -120,7 +120,7 @@ -- in the file descriptor. threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ()) threadWaitReadSTM fd-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS)   | threaded  = Event.threadWaitReadSTM fd #endif   | otherwise = do@@ -139,7 +139,7 @@ -- in the file descriptor. threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ()) threadWaitWriteSTM fd-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS)   | threaded  = Event.threadWaitWriteSTM fd #endif   | otherwise = do@@ -164,7 +164,7 @@             -> Fd            -- ^ File descriptor to close.             -> IO () closeFdWith close fd-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS)   | threaded  = Event.closeFdWith close fd #endif   | otherwise = close fd@@ -178,7 +178,7 @@ -- threadDelay :: Int -> IO () threadDelay time-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   | threaded  = Windows.threadDelay time #else   | threaded  = Event.threadDelay time@@ -193,7 +193,7 @@ -- registerDelay :: Int -> IO (TVar Bool) registerDelay usecs-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   | threaded = Windows.registerDelay usecs #else   | threaded = Event.registerDelay usecs

@@ -487,7 +487,7 @@    case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)  --- |The 'yield' action allows (forces, in a co-operative multitasking+-- | The 'yield' action allows (forces, in a co-operative multitasking -- implementation) a context-switch to any other currently runnable -- threads (if any), and is occasionally useful when implementing -- concurrency abstractions.@@ -591,7 +591,7 @@      mk_stat 17 = ThreadDied      mk_stat _  = ThreadBlocked BlockedOnOther --- | returns the number of the capability on which the thread is currently+-- | Returns the number of the capability on which the thread is currently -- running, and a boolean indicating whether the thread is locked to -- that capability or not.  A thread is locked to a capability if it -- was created with @forkOn@.@@ -602,7 +602,7 @@    case threadStatus# t s of      (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #) --- | make a weak pointer to a 'ThreadId'.  It can be important to do+-- | Make a weak pointer to a 'ThreadId'.  It can be important to do -- this if you want to hold a reference to a 'ThreadId' while still -- allowing the thread to receive the @BlockedIndefinitely@ family of -- exceptions (e.g. 'BlockedIndefinitelyOnMVar').  Holding a normal@@ -714,32 +714,42 @@ unsafeIOToSTM :: IO a -> STM a unsafeIOToSTM (IO m) = STM m --- |Perform a series of STM actions atomically.+-- | Perform a series of STM actions atomically. ----- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.--- Any attempt to do so will result in a runtime error.  (Reason: allowing--- this would effectively allow a transaction inside a transaction, depending--- on exactly when the thunk is evaluated.)+-- Using 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'+-- subverts some of guarantees that STM provides. It makes it possible to+-- run a transaction inside of another transaction, depending on when the+-- thunk is evaluated. If a nested transaction is attempted, an exception+-- is thrown by the runtime. It is possible to safely use 'atomically' inside+-- 'unsafePerformIO' or 'unsafeInterleaveIO', but the typechecker does not+-- rule out programs that may attempt nested transactions, meaning that+-- the programmer must take special care to prevent these. ----- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',--- and which allows top-level TVars to be allocated.+-- However, there are functions for creating transactional variables that+-- can always be safely called in 'unsafePerformIO'. See: 'newTVarIO',+-- 'newTChanIO', 'newBroadcastTChanIO', 'newTQueueIO', 'newTBQueueIO',+-- and 'newTMVarIO'.+--+-- Using 'unsafePerformIO' inside of 'atomically' is also dangerous but for+-- different reasons. See 'unsafeIOToSTM' for more on this.  atomically :: STM a -> IO a atomically (STM m) = IO (\s -> (atomically# m) s ) --- |Retry execution of the current memory transaction because it has seen--- values in TVars which mean that it should not continue (e.g. the TVars+-- | Retry execution of the current memory transaction because it has seen+-- values in 'TVar's which mean that it should not continue (e.g. the 'TVar's -- represent a shared buffer that is now empty).  The implementation may--- block the thread until one of the TVars that it has read from has been--- udpated. (GHC only)+-- block the thread until one of the 'TVar's that it has read from has been+-- updated. (GHC only) retry :: STM a retry = STM $ \s# -> retry# s# --- |Compose two alternative STM actions (GHC only).  If the first action--- completes without retrying then it forms the result of the orElse.--- Otherwise, if the first action retries, then the second action is--- tried in its place.  If both actions retry then the orElse as a--- whole retries.+-- | Compose two alternative STM actions (GHC only).+--+-- If the first action completes without retrying then it forms the result of+-- the 'orElse'. Otherwise, if the first action retries, then the second action+-- is tried in its place. If both actions retry then the 'orElse' as a whole+-- retries. orElse :: STM a -> STM a -> STM a orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s @@ -772,16 +782,17 @@                      Just e' -> unSTM (handler e')                      Nothing -> raiseIO# e --- | Low-level primitive on which always and alwaysSucceeds are built.--- checkInv differs form these in that (i) the invariant is not--- checked when checkInv is called, only at the end of this and--- subsequent transcations, (ii) the invariant failure is indicated--- by raising an exception.+-- | Low-level primitive on which 'always' and 'alwaysSucceeds' are built.+-- 'checkInv' differs from these in that,+--+-- 1. the invariant is not checked when 'checkInv' is called, only at the end of+-- this and subsequent transactions+-- 2. the invariant failure is indicated by raising an exception. checkInv :: STM a -> STM () checkInv (STM m) = STM (\s -> case (check# m) s of s' -> (# s', () #)) --- | alwaysSucceeds adds a new invariant that must be true when passed--- to alwaysSucceeds, at the end of the current transaction, and at+-- | 'alwaysSucceeds' adds a new invariant that must be true when passed+-- to 'alwaysSucceeds', at the end of the current transaction, and at -- the end of every subsequent transaction.  If it fails at any -- of those points then the transaction violating it is aborted -- and the exception raised by the invariant is propagated.@@ -789,9 +800,9 @@ alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )                       checkInv i --- | always is a variant of alwaysSucceeds in which the invariant is--- expressed as an STM Bool action that must return True.  Returning--- False or raising an exception are both treated as invariant failures.+-- | 'always' is a variant of 'alwaysSucceeds' in which the invariant is+-- expressed as an @STM Bool@ action that must return @True@.  Returning+-- @False@ or raising an exception are both treated as invariant failures. always :: STM Bool -> STM () always i = alwaysSucceeds ( do v <- i                                if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) )@@ -803,13 +814,13 @@ instance Eq (TVar a) where         (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#) --- |Create a new TVar holding a value supplied+-- | Create a new 'TVar' holding a value supplied newTVar :: a -> STM (TVar a) newTVar val = STM $ \s1# ->     case newTVar# val s1# of          (# s2#, tvar# #) -> (# s2#, TVar tvar# #) --- |@IO@ version of 'newTVar'.  This is useful for creating top-level+-- | @IO@ version of 'newTVar'.  This is useful for creating top-level -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible.@@ -818,7 +829,7 @@     case newTVar# val s1# of          (# s2#, tvar# #) -> (# s2#, TVar tvar# #) --- |Return the current value stored in a TVar.+-- | Return the current value stored in a 'TVar'. -- This is equivalent to -- -- >  readTVarIO = atomically . readTVar@@ -828,11 +839,11 @@ readTVarIO :: TVar a -> IO a readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s# --- |Return the current value stored in a TVar+-- |Return the current value stored in a 'TVar'. readTVar :: TVar a -> STM a readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s# --- |Write the supplied value into a TVar+-- |Write the supplied value into a 'TVar'. writeTVar :: TVar a -> a -> STM () writeTVar (TVar tvar#) val = STM $ \s1# ->     case writeTVar# tvar# val s1# of@@ -842,6 +853,8 @@ -- MVar utilities ----------------------------------------------------------------------------- +-- | Provide an 'IO' action with the current value of an 'MVar'. The 'MVar'+-- will be empty for the duration that the action is running. withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io =   mask $ \restore -> do@@ -851,6 +864,7 @@     putMVar m a     return b +-- | Modify the value of an 'MVar'. modifyMVar_ :: MVar a -> (a -> IO a) -> IO () modifyMVar_ m io =   mask $ \restore -> do

@@ -53,7 +53,7 @@ import GHC.Word (Word32, Word64) import GHC.Windows -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) # if defined(i386_HOST_ARCH) #  define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH)

@@ -8,11 +8,10 @@ import Foreign.C import GHC.Base import GHC.Real ( fromIntegral )--#ifdef mingw32_HOST_OS-import GHC.IO (finally)-import GHC.Windows+import GHC.IO.Encoding+import qualified GHC.Foreign as GHC +#if defined(mingw32_HOST_OS) # if defined(i386_HOST_ARCH) #  define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH)@@ -20,9 +19,6 @@ # else #  error Unknown mingw32 arch # endif-#else-import GHC.IO.Encoding-import qualified GHC.Foreign as GHC #endif  -- | Computation 'getFullArgs' is the "raw" version of 'getArgs', similar@@ -30,37 +26,14 @@ -- command line arguments, starting with the program name, and -- including those normally eaten by the RTS (+RTS ... -RTS). getFullArgs :: IO [String]-#ifdef mingw32_HOST_OS--- Ignore the arguments to hs_init on Windows for the sake of Unicode compat getFullArgs = do-    p_arg_string <- c_GetCommandLine-    alloca $ \p_argc -> do-     p_argv <- c_CommandLineToArgv p_arg_string p_argc-     if p_argv == nullPtr-      then throwGetLastError "getFullArgs"-      else flip finally (c_LocalFree p_argv) $ do-       argc <- peek p_argc-       p_argvs <- peekArray (fromIntegral argc) p_argv-       mapM peekCWString p_argvs--foreign import WINDOWS_CCONV unsafe "windows.h GetCommandLineW"-    c_GetCommandLine :: IO (Ptr CWString)--foreign import WINDOWS_CCONV unsafe "windows.h CommandLineToArgvW"-    c_CommandLineToArgv :: Ptr CWString -> Ptr CInt -> IO (Ptr CWString)--foreign import WINDOWS_CCONV unsafe "Windows.h LocalFree"-    c_LocalFree :: Ptr a -> IO (Ptr a)-#else-getFullArgs =-  alloca $ \ p_argc ->-  alloca $ \ p_argv -> do-   getFullProgArgv p_argc p_argv-   p    <- fromIntegral `liftM` peek p_argc-   argv <- peek p_argv-   enc <- getFileSystemEncoding-   peekArray p argv >>= mapM (GHC.peekCString enc)+  alloca $ \ p_argc -> do+    alloca $ \ p_argv -> do+        getFullProgArgv p_argc p_argv+        p    <- fromIntegral `liftM` peek p_argc+        argv <- peek p_argv+        enc <- argvEncoding+        peekArray p argv >>= mapM (GHC.peekCString enc)  foreign import ccall unsafe "getFullProgArgv"     getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()-#endif

@@ -1,17 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Event.Clock (getMonotonicTime) where--import GHC.Base-import GHC.Real-import Data.Word---- | Return monotonic time in seconds, since some unspecified starting point-getMonotonicTime :: IO Double-getMonotonicTime = do w <- getMonotonicNSec-                      return (fromIntegral w / 1000000000)--foreign import ccall unsafe "getMonotonicNSec"-    getMonotonicNSec :: IO Word64-

@@ -48,7 +48,7 @@ import Foreign.Storable (Storable(..)) import GHC.Base import GHC.Num (Num(..))-import GHC.Real (ceiling, fromIntegral)+import GHC.Real (fromIntegral, div) import GHC.Show (Show) import System.Posix.Internals (c_close) import System.Posix.Internals (setCloseOnExec)@@ -223,7 +223,9 @@  fromTimeout :: Timeout -> Int fromTimeout Forever     = -1-fromTimeout (Timeout s) = ceiling $ 1000 * s+fromTimeout (Timeout s) = fromIntegral $ s `divRoundUp` 1000000+  where+    divRoundUp num denom = (num + denom - 1) `div` denom  foreign import ccall unsafe "sys/epoll.h epoll_create"     c_epoll_create :: CInt -> IO CInt

@@ -33,8 +33,10 @@ import Foreign.C.Error (eINTR, getErrno, throwErrno) import System.Posix.Types (Fd) import GHC.Base+import GHC.Word (Word64) import GHC.Num (Num(..)) import GHC.Show (Show(..))+import Data.Semigroup.Internal (stimesMonoid)  -- | An I\/O event. newtype Event = Event Int@@ -71,10 +73,14 @@         where ev `so` disp | e `eventIs` ev = disp                            | otherwise      = "" +-- | @since 4.10.0.0+instance Semigroup Event where+    (<>)    = evtCombine+    stimes  = stimesMonoid+ -- | @since 4.3.1.0 instance Monoid Event where     mempty  = evtNothing-    mappend = evtCombine     mconcat = evtConcat  evtCombine :: Event -> Event -> Event@@ -99,12 +105,16 @@ elSupremum _       _       = MultiShot {-# INLINE elSupremum #-} +-- | @since 4.10.0.0+instance Semigroup Lifetime where+    (<>) = elSupremum+    stimes = stimesMonoid+ -- | @mappend@ takes the longer of two lifetimes. -- -- @since 4.8.0.0 instance Monoid Lifetime where     mempty = OneShot-    mappend = elSupremum  -- | A pair of an event and lifetime --@@ -113,10 +123,13 @@ newtype EventLifetime = EL Int                       deriving (Show, Eq) +-- | @since 4.11.0.0+instance Semigroup EventLifetime where+    EL a <> EL b = EL (a .|. b)+ -- | @since 4.8.0.0 instance Monoid EventLifetime where     mempty = EL 0-    EL a `mappend` EL b = EL (a .|. b)  eventLifetime :: Event -> Lifetime -> EventLifetime eventLifetime (Event e) l = EL (e .|. lifetimeBit l)@@ -133,8 +146,8 @@ elEvent (EL x) = Event (x .&. 0x7) {-# INLINE elEvent #-} --- | A type alias for timeouts, specified in seconds.-data Timeout = Timeout {-# UNPACK #-} !Double+-- | A type alias for timeouts, specified in nanoseconds.+data Timeout = Timeout {-# UNPACK #-} !Word64              | Forever                deriving (Show) 

@@ -28,17 +28,19 @@  import Data.Bits (Bits(..), FiniteBits(..)) import Data.Int+import Data.Maybe ( catMaybes ) import Data.Word (Word16, Word32) import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL,                         eNOTSUP, getErrno, throwErrno) import Foreign.C.Types import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array (withArrayLen) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (Storable(..)) import GHC.Base import GHC.Enum (toEnum) import GHC.Num (Num(..))-import GHC.Real (ceiling, floor, fromIntegral)+import GHC.Real (quotRem, fromIntegral) import GHC.Show (Show(show)) import GHC.Event.Internal (Timeout(..)) import System.Posix.Internals (c_close)@@ -56,7 +58,7 @@ -- Handle brokenness on some BSD variants, notably OS X up to at least -- 10.6.  If NOTE_EOF isn't available, we have no way to receive a -- notification from the kernel when we reach EOF on a plain file.-#ifndef NOTE_EOF+#if !defined(NOTE_EOF) # define NOTE_EOF 0 #endif @@ -85,23 +87,20 @@   return ()  modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool-modifyFd kq fd oevt nevt-  | nevt == mempty = do-      let !ev = event fd (toFilter oevt) flagDelete noteEOF-      kqueueControl (kqueueFd kq) ev-  | otherwise      = do-      let !ev = event fd (toFilter nevt) flagAdd noteEOF-      kqueueControl (kqueueFd kq) ev+modifyFd kq fd oevt nevt = kqueueControl (kqueueFd kq) evs+  where+    evs+      | nevt == mempty = toEvents fd (toFilter oevt) flagDelete noteEOF+      | otherwise      = toEvents fd (toFilter nevt) flagAdd noteEOF -toFilter :: E.Event -> Filter-toFilter evt-  | evt `E.eventIs` E.evtRead = filterRead-  | otherwise                 = filterWrite+toFilter :: E.Event -> [Filter]+toFilter e = catMaybes [ check E.evtRead filterRead, check E.evtWrite filterWrite ]+  where+    check e' f = if e `E.eventIs` e' then Just f else Nothing  modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool-modifyFdOnce kq fd evt = do-    let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF-    kqueueControl (kqueueFd kq) ev+modifyFdOnce kq fd evt =+    kqueueControl (kqueueFd kq) (toEvents fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF)  poll :: KQueue      -> Maybe Timeout@@ -132,7 +131,7 @@     , filter :: {-# UNPACK #-} !Filter     , flags  :: {-# UNPACK #-} !Flag     , fflags :: {-# UNPACK #-} !FFlag-#ifdef netbsd_HOST_OS+#if defined(netbsd_HOST_OS)     , data_  :: {-# UNPACK #-} !Int64 #else     , data_  :: {-# UNPACK #-} !CIntPtr@@ -140,8 +139,8 @@     , udata  :: {-# UNPACK #-} !(Ptr ())     } deriving Show -event :: Fd -> Filter -> Flag -> FFlag -> Event-event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr+toEvents :: Fd -> [Filter] -> Flag -> FFlag -> [Event]+toEvents fd flts flag fflag = map (\filt -> KEvent (fromIntegral fd) filt flag fflag 0 nullPtr) flts  -- | @since 4.3.1.0 instance Storable Event where@@ -192,7 +191,7 @@ #else newtype Filter = Filter Int16 #endif-    deriving (Bits, FiniteBits, Eq, Num, Show, Storable)+    deriving (Eq, Num, Show, Storable)  filterRead :: Filter filterRead = Filter (#const EVFILT_READ)@@ -222,11 +221,11 @@ kqueue :: IO KQueueFd kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue -kqueueControl :: KQueueFd -> Event -> IO Bool-kqueueControl kfd ev =+kqueueControl :: KQueueFd -> [Event] -> IO Bool+kqueueControl kfd evts =     withTimeSpec (TimeSpec 0 0) $ \tp ->-        withEvent ev $ \evp -> do-            res <- kevent False kfd evp 1 nullPtr 0 tp+        withArrayLen evts $ \evlen evp -> do+            res <- kevent False kfd evp evlen nullPtr 0 tp             if res == -1               then do                err <- getErrno@@ -255,9 +254,6 @@   | safe      = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts   | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts -withEvent :: Event -> (Ptr Event -> IO a) -> IO a-withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr- withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a withTimeSpec ts f   | tv_sec ts < 0 = f nullPtr@@ -265,13 +261,13 @@  fromTimeout :: Timeout -> TimeSpec fromTimeout Forever     = TimeSpec (-1) (-1)-fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)+fromTimeout (Timeout s) = TimeSpec (toEnum sec') (toEnum nanosec')   where-    sec :: Int-    sec     = floor s+    (sec, nanosec) = s `quotRem` 1000000000 -    nanosec :: Int-    nanosec = ceiling $ (s - fromIntegral sec) * 1000000000+    nanosec', sec' :: Int+    sec' = fromIntegral sec+    nanosec' = fromIntegral nanosec  toEvent :: Filter -> E.Event toEvent (Filter f)

@@ -1,58 +1,17 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}---- Copyright (c) 2008, Ralf Hinze--- All rights reserved.------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions--- are met:------     * Redistributions of source code must retain the above---       copyright notice, this list of conditions and the following---       disclaimer.------     * Redistributions in binary form must reproduce the above---       copyright notice, this list of conditions and the following---       disclaimer in the documentation and/or other materials---       provided with the distribution.------     * The names of the contributors may not be used to endorse or---       promote products derived from this software without specific---       prior written permission.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS--- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT--- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS--- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE--- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,--- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES--- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR--- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)--- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED--- OF THE POSSIBILITY OF SUCH DAMAGE.+{-# LANGUAGE Trustworthy       #-}+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UnboxedTuples     #-} --- | A /priority search queue/ (henceforth /queue/) efficiently--- supports the operations of both a search tree and a priority queue.--- An 'Elem'ent is a product of a key, a priority, and a--- value. Elements can be inserted, deleted, modified and queried in--- logarithmic time, and the element with the least priority can be--- retrieved in constant time.  A queue can be built from a list of--- elements, sorted by keys, in linear time.------ This implementation is due to Ralf Hinze with some modifications by--- Scott Dillard and Johan Tibell.------ * Hinze, R., /A Simple Implementation Technique for Priority Search--- Queues/, ICFP 2001, pp. 110-121------ <http://citeseer.ist.psu.edu/hinze01simple.html> module GHC.Event.PSQ     (     -- * Binding Type-    Elem(..)+      Elem(..)     , Key     , Prio @@ -77,8 +36,6 @@      -- * Conversion     , toList-    , toAscList-    , toDescList     , fromList      -- * Min@@ -88,399 +45,410 @@     , atMost     ) where -import GHC.Base hiding (empty)-import GHC.Float () -- for Show Double instance+import GHC.Base hiding (Nat, empty)+import GHC.Event.Unique+import GHC.Word (Word64) import GHC.Num (Num(..))-import GHC.Show (Show(showsPrec))-import GHC.Event.Unique (Unique)+import GHC.Real (fromIntegral)+import GHC.Types (Int) --- | @E k p@ binds the key @k@ with the priority @p@.-data Elem a = E-    { key   :: {-# UNPACK #-} !Key-    , prio  :: {-# UNPACK #-} !Prio-    , value :: a-    } deriving (Eq, Show)+#include "MachDeps.h" ---------------------------------------------------------------------------- | A mapping from keys @k@ to priorites @p@.+-- TODO (SM): get rid of bang patterns -type Prio = Double-type Key = Unique+{-+-- Use macros to define strictness of functions.+-- STRICT_x_OF_y denotes a y-ary function strict in the x-th parameter.+-- We do not use BangPatterns, because they are not in any standard and we+-- want the compilers to be compiled by as many compilers as possible.+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined+-} -data PSQ a = Void-           | Winner {-# UNPACK #-} !(Elem a)-                    !(LTree a)-                    {-# UNPACK #-} !Key  -- max key-           deriving (Eq, Show) --- | /O(1)/ The number of elements in a queue.-size :: PSQ a -> Int-size Void            = 0-size (Winner _ lt _) = 1 + size' lt+------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------ --- | /O(1)/ True if the queue is empty.-null :: PSQ a -> Bool-null Void           = True-null (Winner _ _ _) = False+type Prio = Word64 --- | /O(log n)/ The priority and value of a given key, or Nothing if--- the key is not bound.-lookup :: Key -> PSQ a -> Maybe (Prio, a)-lookup k q = case tourView q of-    Null -> Nothing-    Single (E k' p v)-        | k == k'   -> Just (p, v)-        | otherwise -> Nothing-    tl `Play` tr-        | k <= maxKey tl -> lookup k tl-        | otherwise      -> lookup k tr+type Nat = Word ---------------------------------------------------------------------------- Construction+type Key = Unique -empty :: PSQ a-empty = Void+-- | We store masks as the index of the bit that determines the branching.+type Mask = Int --- | /O(1)/ Build a queue with one element.-singleton :: Key -> Prio -> a -> PSQ a-singleton k p v = Winner (E k p v) Start k+type PSQ a = IntPSQ a ---------------------------------------------------------------------------- Insertion+-- | @E k p@ binds the key @k@ with the priority @p@.+data Elem a = E+    { key   :: {-# UNPACK #-} !Key+    , prio  :: {-# UNPACK #-} !Prio+    , value :: a+    } --- | /O(log n)/ Insert a new key, priority and value in the queue.  If--- the key is already present in the queue, the associated priority--- and value are replaced with the supplied priority and value.-insert :: Key -> Prio -> a -> PSQ a -> PSQ a-insert k p v q = case q of-    Void -> singleton k p v-    Winner (E k' p' v') Start _ -> case compare k k' of-        LT -> singleton k  p  v  `play` singleton k' p' v'-        EQ -> singleton k  p  v-        GT -> singleton k' p' v' `play` singleton k  p  v-    Winner e (RLoser _ e' tl m tr) m'-        | k <= m    -> insert k p v (Winner e tl m) `play` (Winner e' tr m')-        | otherwise -> (Winner e tl m) `play` insert k p v (Winner e' tr m')-    Winner e (LLoser _ e' tl m tr) m'-        | k <= m    -> insert k p v (Winner e' tl m) `play` (Winner e tr m')-        | otherwise -> (Winner e' tl m) `play` insert k p v (Winner e tr m')+-- | A priority search queue with @Int@ keys and priorities of type @p@ and+-- values of type @v@. It is strict in keys, priorities and values.+data IntPSQ v+    = Bin {-# UNPACK #-} !Key {-# UNPACK #-} !Prio !v {-# UNPACK #-} !Mask !(IntPSQ v) !(IntPSQ v)+    | Tip {-# UNPACK #-} !Key {-# UNPACK #-} !Prio !v+    | Nil ---------------------------------------------------------------------------- Delete/Update+-- bit twiddling+---------------- --- | /O(log n)/ Delete a key and its priority and value from the--- queue.  When the key is not a member of the queue, the original--- queue is returned.-delete :: Key -> PSQ a -> PSQ a-delete k q = case q of-    Void -> empty-    Winner (E k' p v) Start _-        | k == k'   -> empty-        | otherwise -> singleton k' p v-    Winner e (RLoser _ e' tl m tr) m'-        | k <= m    -> delete k (Winner e tl m) `play` (Winner e' tr m')-        | otherwise -> (Winner e tl m) `play` delete k (Winner e' tr m')-    Winner e (LLoser _ e' tl m tr) m'-        | k <= m    -> delete k (Winner e' tl m) `play` (Winner e tr m')-        | otherwise -> (Winner e' tl m) `play` delete k (Winner e tr m')+(.&.) :: Nat -> Nat -> Nat+(.&.) (W# w1) (W# w2) = W# (w1 `and#` w2)+{-# INLINE (.&.) #-} --- | /O(log n)/ Update a priority at a specific key with the result--- of the provided function.  When the key is not a member of the--- queue, the original queue is returned.-adjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a-adjust f k q0 =  go q0+xor :: Nat -> Nat -> Nat+xor (W# w1) (W# w2) = W# (w1 `xor#` w2)+{-# INLINE xor #-}++complement :: Nat -> Nat+complement (W# w) = W# (w `xor#` mb)   where-    go q = case q of-        Void -> empty-        Winner (E k' p v) Start _-            | k == k'   -> singleton k' (f p) v-            | otherwise -> singleton k' p v-        Winner e (RLoser _ e' tl m tr) m'-            | k <= m    -> go (Winner e tl m) `unsafePlay` (Winner e' tr m')-            | otherwise -> (Winner e tl m) `unsafePlay` go (Winner e' tr m')-        Winner e (LLoser _ e' tl m tr) m'-            | k <= m    -> go (Winner e' tl m) `unsafePlay` (Winner e tr m')-            | otherwise -> (Winner e' tl m) `unsafePlay` go (Winner e tr m')-{-# INLINE adjust #-}+#if WORD_SIZE_IN_BITS == 32+    mb = 0xFFFFFFFF##+#elif WORD_SIZE_IN_BITS == 64+    mb = 0xFFFFFFFFFFFFFFFF##+#else+#error Unhandled value for WORD_SIZE_IN_BITS+#endif+{-# INLINE complement #-} ---------------------------------------------------------------------------- Conversion+{-# INLINE natFromInt #-}+natFromInt :: Int -> Nat+natFromInt = fromIntegral --- | /O(n*log n)/ Build a queue from a list of key/priority/value--- tuples.  If the list contains more than one priority and value for--- the same key, the last priority and value for the key is retained.-fromList :: [Elem a] -> PSQ a-fromList = foldr (\(E k p v) q -> insert k p v q) empty+{-# INLINE intFromNat #-}+intFromNat :: Nat -> Int+intFromNat = fromIntegral --- | /O(n)/ Convert to a list of key/priority/value tuples.-toList :: PSQ a -> [Elem a]-toList = toAscList+{-# INLINE zero #-}+zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt (asInt i)) .&. (natFromInt m) == 0 --- | /O(n)/ Convert to an ascending list.-toAscList :: PSQ a -> [Elem a]-toAscList q  = seqToList (toAscLists q)+{-# INLINE nomatch #-}+nomatch :: Key -> Key -> Mask -> Bool+nomatch k1 k2 m =+    natFromInt (asInt k1) .&. m' /= natFromInt (asInt k2) .&. m'+  where+    m' = maskW (natFromInt m) -toAscLists :: PSQ a -> Sequ (Elem a)-toAscLists q = case tourView q of-    Null         -> emptySequ-    Single e     -> singleSequ e-    tl `Play` tr -> toAscLists tl <> toAscLists tr+{-# INLINE maskW #-}+maskW :: Nat -> Nat+maskW m = complement (m-1) `xor` m --- | /O(n)/ Convert to a descending list.-toDescList :: PSQ a -> [ Elem a ]-toDescList q = seqToList (toDescLists q)+{-# INLINE branchMask #-}+branchMask :: Key -> Key -> Mask+branchMask k1' k2' =+    intFromNat (highestBitMask (natFromInt k1 `xor` natFromInt k2))+  where+    k1 = asInt k1'+    k2 = asInt k2' -toDescLists :: PSQ a -> Sequ (Elem a)-toDescLists q = case tourView q of-    Null         -> emptySequ-    Single e     -> singleSequ e-    tl `Play` tr -> toDescLists tr <> toDescLists tl+highestBitMask :: Nat -> Nat+highestBitMask (W# x) =+    W# (uncheckedShiftL# 1## (word2Int# (WORD_SIZE_IN_BITS## `minusWord#` 1## `minusWord#` clz# x)))+{-# INLINE highestBitMask #-} ---------------------------------------------------------------------------- Min+------------------------------------------------------------------------------+-- Query+------------------------------------------------------------------------------ --- | /O(1)/ The element with the lowest priority.-findMin :: PSQ a -> Maybe (Elem a)-findMin Void           = Nothing-findMin (Winner e _ _) = Just e+-- | /O(1)/ True if the queue is empty.+null :: IntPSQ v -> Bool+null Nil = True+null _   = False --- | /O(log n)/ Delete the element with the lowest priority.  Returns--- an empty queue if the queue is empty.-deleteMin :: PSQ a -> PSQ a-deleteMin Void           = Void-deleteMin (Winner _ t m) = secondBest t m+-- | /O(n)/ The number of elements stored in the queue.+size :: IntPSQ v -> Int+size Nil               = 0+size (Tip _ _ _)       = 1+size (Bin _ _ _ _ l r) = 1 + size l + size r+-- TODO (SM): benchmark this against a tail-recursive variant --- | /O(log n)/ Retrieve the binding with the least priority, and the--- rest of the queue stripped of that binding.-minView :: PSQ a -> Maybe (Elem a, PSQ a)-minView Void           = Nothing-minView (Winner e t m) = Just (e, secondBest t m)+-- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the+-- key is not bound.+lookup :: Key -> IntPSQ v -> Maybe (Prio, v)+lookup k = go+  where+    go t = case t of+        Nil                -> Nothing -secondBest :: LTree a -> Key -> PSQ a-secondBest Start _                 = Void-secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m'-secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m'+        Tip k' p' x'+          | k == k'        -> Just (p', x')+          | otherwise      -> Nothing --- | /O(r*(log n - log r))/ Return a list of elements ordered by--- key whose priorities are at most @pt@.-atMost :: Prio -> PSQ a -> ([Elem a], PSQ a)-atMost pt q = let (sequ, q') = atMosts pt q-              in (seqToList sequ, q')+        Bin k' p' x' m l r+          | nomatch k k' m -> Nothing+          | k == k'        -> Just (p', x')+          | zero k m       -> go l+          | otherwise      -> go r -atMosts :: Prio -> PSQ a -> (Sequ (Elem a), PSQ a)-atMosts !pt q = case q of-    (Winner e _ _)-        | prio e > pt -> (emptySequ, q)-    Void              -> (emptySequ, Void)-    Winner e Start _  -> (singleSequ e, Void)-    Winner e (RLoser _ e' tl m tr) m' ->-        let (sequ, q')   = atMosts pt (Winner e tl m)-            (sequ', q'') = atMosts pt (Winner e' tr m')-        in (sequ <> sequ', q' `play` q'')-    Winner e (LLoser _ e' tl m tr) m' ->-        let (sequ, q')   = atMosts pt (Winner e' tl m)-            (sequ', q'') = atMosts pt (Winner e tr m')-        in (sequ <> sequ', q' `play` q'')+-- | /O(1)/ The element with the lowest priority.+findMin :: IntPSQ v -> Maybe (Elem v)+findMin t = case t of+    Nil             -> Nothing+    Tip k p x       -> Just (E k p x)+    Bin k p x _ _ _ -> Just (E k p x) ---------------------------------------------------------------------------- Loser tree -type Size = Int+------------------------------------------------------------------------------+--- Construction+------------------------------------------------------------------------------ -data LTree a = Start-             | LLoser {-# UNPACK #-} !Size-                      {-# UNPACK #-} !(Elem a)-                      !(LTree a)-                      {-# UNPACK #-} !Key  -- split key-                      !(LTree a)-             | RLoser {-# UNPACK #-} !Size-                      {-# UNPACK #-} !(Elem a)-                      !(LTree a)-                      {-# UNPACK #-} !Key  -- split key-                      !(LTree a)-             deriving (Eq, Show)+-- | /O(1)/ The empty queue.+empty :: IntPSQ v+empty = Nil -size' :: LTree a -> Size-size' Start              = 0-size' (LLoser s _ _ _ _) = s-size' (RLoser s _ _ _ _) = s+-- | /O(1)/ Build a queue with one element.+singleton :: Key -> Prio -> v -> IntPSQ v+singleton = Tip -left, right :: LTree a -> LTree a -left Start                = moduleError "left" "empty loser tree"-left (LLoser _ _ tl _ _ ) = tl-left (RLoser _ _ tl _ _ ) = tl+------------------------------------------------------------------------------+-- Insertion+------------------------------------------------------------------------------ -right Start                = moduleError "right" "empty loser tree"-right (LLoser _ _ _  _ tr) = tr-right (RLoser _ _ _  _ tr) = tr+-- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key+-- is already present in the queue, the associated priority and value are+-- replaced with the supplied priority and value.+insert :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v+insert k p x t0 = unsafeInsertNew k p x (delete k t0) -maxKey :: PSQ a -> Key-maxKey Void           = moduleError "maxKey" "empty queue"-maxKey (Winner _ _ m) = m+-- | Internal function to insert a key that is *not* present in the priority+-- queue.+{-# INLINABLE unsafeInsertNew #-}+unsafeInsertNew :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v+unsafeInsertNew k p x = go+  where+    go t = case t of+      Nil       -> Tip k p x -lloser, rloser :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr-rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr+      Tip k' p' x'+        | (p, k) < (p', k') -> link k  p  x  k' t           Nil+        | otherwise         -> link k' p' x' k  (Tip k p x) Nil ---------------------------------------------------------------------------- Balancing+      Bin k' p' x' m l r+        | nomatch k k' m ->+            if (p, k) < (p', k')+              then link k  p  x  k' t           Nil+              else link k' p' x' k  (Tip k p x) (merge m l r) --- | Balance factor-omega :: Int-omega = 4+        | otherwise ->+            if (p, k) < (p', k')+              then+                if zero k' m+                  then Bin k  p  x  m (unsafeInsertNew k' p' x' l) r+                  else Bin k  p  x  m l (unsafeInsertNew k' p' x' r)+              else+                if zero k m+                  then Bin k' p' x' m (unsafeInsertNew k  p  x  l) r+                  else Bin k' p' x' m l (unsafeInsertNew k  p  x  r) -lbalance, rbalance :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a+-- | Link+link :: Key -> Prio -> v -> Key -> IntPSQ v -> IntPSQ v -> IntPSQ v+link k p x k' k't otherTree+  | zero (Unique m) (asInt k') = Bin k p x m k't otherTree+  | otherwise                  = Bin k p x m otherTree k't+  where+    m = branchMask k k' -lbalance k p v l m r-    | size' l + size' r < 2     = lloser        k p v l m r-    | size' r > omega * size' l = lbalanceLeft  k p v l m r-    | size' l > omega * size' r = lbalanceRight k p v l m r-    | otherwise                 = lloser        k p v l m r -rbalance k p v l m r-    | size' l + size' r < 2     = rloser        k p v l m r-    | size' r > omega * size' l = rbalanceLeft  k p v l m r-    | size' l > omega * size' r = rbalanceRight k p v l m r-    | otherwise                 = rloser        k p v l m r+------------------------------------------------------------------------------+-- Delete/Alter+------------------------------------------------------------------------------ -lbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lbalanceLeft  k p v l m r-    | size' (left r) < size' (right r) = lsingleLeft  k p v l m r-    | otherwise                        = ldoubleLeft  k p v l m r+-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When+-- the key is not a member of the queue, the original queue is returned.+{-# INLINABLE delete #-}+delete :: Key -> IntPSQ v -> IntPSQ v+delete k = go+  where+    go t = case t of+        Nil           -> Nil -lbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lbalanceRight k p v l m r-    | size' (left l) > size' (right l) = lsingleRight k p v l m r-    | otherwise                        = ldoubleRight k p v l m r+        Tip k' _ _+          | k == k'   -> Nil+          | otherwise -> t -rbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rbalanceLeft  k p v l m r-    | size' (left r) < size' (right r) = rsingleLeft  k p v l m r-    | otherwise                        = rdoubleLeft  k p v l m r+        Bin k' p' x' m l r+          | nomatch k k' m -> t+          | k == k'        -> merge m l r+          | zero k m       -> binShrinkL k' p' x' m (go l) r+          | otherwise      -> binShrinkR k' p' x' m l      (go r) -rbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rbalanceRight k p v l m r-    | size' (left l) > size' (right l) = rsingleRight k p v l m r-    | otherwise                        = rdoubleRight k p v l m r+-- | /O(min(n,W))/ Delete the binding with the least priority, and return the+-- rest of the queue stripped of that binding. In case the queue is empty, the+-- empty queue is returned again.+{-# INLINE deleteMin #-}+deleteMin :: IntPSQ v -> IntPSQ v+deleteMin t = case minView t of+    Nothing      -> t+    Just (_, t') -> t' -lsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3)-    | p1 <= p2  = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3-    | otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3-lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3-lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree" -rsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =-    rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3-rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3-rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree"+adjust+    :: (Prio -> Prio)+    -> Key+    -> PSQ a+    -> PSQ a+adjust f k q = case alter g k q of (_, q') -> q'+  where g (Just (p, v)) = ((), Just ((f p), v))+        g Nothing       = ((), Nothing) -lsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3)-lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)-lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree"+{-# INLINE adjust #-} -rsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)-rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3-    | p1 <= p2  = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)-    | otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)-rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree"+-- | /O(min(n,W))/ The expression @alter f k queue@ alters the value @x@ at @k@,+-- or absence thereof. 'alter' can be used to insert, delete, or update a value+-- in a queue. It also allows you to calculate an additional value @b@.+{-# INLINE alter #-}+alter+    :: (Maybe (Prio, v) -> (b, Maybe (Prio, v)))+    -> Key+    -> IntPSQ v+    -> (b, IntPSQ v)+alter f = \k t0 ->+    let (t, mbX) = case deleteView k t0 of+                            Nothing          -> (t0, Nothing)+                            Just (p, v, t0') -> (t0', Just (p, v))+    in case f mbX of+          (b, mbX') ->+            (b, maybe t (\(p, v) -> unsafeInsertNew k p v t) mbX')+    where+        maybe _ g (Just x)  = g x+        maybe def _ Nothing = def -ldoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =-    lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)-ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)-ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree"+-- | Smart constructor for a 'Bin' node whose left subtree could have become+-- 'Nil'.+{-# INLINE binShrinkL #-}+binShrinkL :: Key -> Prio -> v -> Mask -> IntPSQ v -> IntPSQ v -> IntPSQ v+binShrinkL k p x m Nil r = case r of Nil -> Tip k p x; _ -> Bin k p x m Nil r+binShrinkL k p x m l   r = Bin k p x m l r -ldoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree"+-- | Smart constructor for a 'Bin' node whose right subtree could have become+-- 'Nil'.+{-# INLINE binShrinkR #-}+binShrinkR :: Key -> Prio -> v -> Mask -> IntPSQ v -> IntPSQ v -> IntPSQ v+binShrinkR k p x m l Nil = case l of Nil -> Tip k p x; _ -> Bin k p x m l Nil+binShrinkR k p x m l r   = Bin k p x m l r -rdoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =-    rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)-rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)-rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree"+------------------------------------------------------------------------------+-- Lists+------------------------------------------------------------------------------ -rdoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree"+-- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples.+-- If the list contains more than one priority and value for the same key, the+-- last priority and value for the key is retained.+{-# INLINABLE fromList #-}+fromList :: [Elem v] -> IntPSQ v+fromList = foldr (\(E k p x) im -> insert k p x im) empty --- | Take two pennants and returns a new pennant that is the union of--- the two with the precondition that the keys in the first tree are--- strictly smaller than the keys in the second tree.-play :: PSQ a -> PSQ a -> PSQ a-Void `play` t' = t'-t `play` Void  = t-Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m'-    | p <= p'   = Winner e (rbalance k' p' v' t m t') m'-    | otherwise = Winner e' (lbalance k p v t m t') m'-{-# INLINE play #-}+-- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The+-- order of the list is not specified.+toList :: IntPSQ v -> [Elem v]+toList =+    go []+  where+    go acc Nil                   = acc+    go acc (Tip k' p' x')        = (E k' p' x') : acc+    go acc (Bin k' p' x' _m l r) = (E k' p' x') : go (go acc r) l --- | A version of 'play' that can be used if the shape of the tree has--- not changed or if the tree is known to be balanced.-unsafePlay :: PSQ a -> PSQ a -> PSQ a-Void `unsafePlay` t' =  t'-t `unsafePlay` Void  =  t-Winner e@(E k p v) t m `unsafePlay` Winner e'@(E k' p' v') t' m'-    | p <= p'   = Winner e (rloser k' p' v' t m t') m'-    | otherwise = Winner e' (lloser k p v t m t') m'-{-# INLINE unsafePlay #-} -data TourView a = Null-                | Single {-# UNPACK #-} !(Elem a)-                | (PSQ a) `Play` (PSQ a)+------------------------------------------------------------------------------+-- Views+------------------------------------------------------------------------------ -tourView :: PSQ a -> TourView a-tourView Void               = Null-tourView (Winner e Start _) = Single e-tourView (Winner e (RLoser _ e' tl m tr) m') =-    Winner e tl m `Play` Winner e' tr m'-tourView (Winner e (LLoser _ e' tl m tr) m') =-    Winner e' tl m `Play` Winner e tr m'+-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If+-- the key was present, the associated priority and value are returned in+-- addition to the updated queue.+{-# INLINABLE deleteView #-}+deleteView :: Key -> IntPSQ v -> Maybe (Prio, v, IntPSQ v)+deleteView k t0 =+    case delFrom t0 of+      (# _, Nothing     #) -> Nothing+      (# t, Just (p, x) #) -> Just (p, x, t)+  where+    delFrom t = case t of+      Nil -> (# Nil, Nothing #) ---------------------------------------------------------------------------- Utility functions+      Tip k' p' x'+        | k == k'   -> (# Nil, Just (p', x') #)+        | otherwise -> (# t,   Nothing       #) -moduleError :: String -> String -> a-moduleError fun msg = errorWithoutStackTrace ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg)-{-# NOINLINE moduleError #-}+      Bin k' p' x' m l r+        | nomatch k k' m -> (# t, Nothing #)+        | k == k'   -> let t' = merge m l r+                       in  t' `seq` (# t', Just (p', x') #) ---------------------------------------------------------------------------- Hughes's efficient sequence type+        | zero k m  -> case delFrom l of+                         (# l', mbPX #) -> let t' = binShrinkL k' p' x' m l' r+                                           in  t' `seq` (# t', mbPX #) -newtype Sequ a = Sequ ([a] -> [a])+        | otherwise -> case delFrom r of+                         (# r', mbPX #) -> let t' = binShrinkR k' p' x' m l  r'+                                           in  t' `seq` (# t', mbPX #) -emptySequ :: Sequ a-emptySequ = Sequ (\as -> as)+-- | /O(min(n,W))/ Retrieve the binding with the least priority, and the+-- rest of the queue stripped of that binding.+{-# INLINE minView #-}+minView :: IntPSQ v -> Maybe (Elem v, IntPSQ v)+minView t = case t of+    Nil             -> Nothing+    Tip k p x       -> Just (E k p x, Nil)+    Bin k p x m l r -> Just (E k p x, merge m l r) -singleSequ :: a -> Sequ a-singleSequ a = Sequ (\as -> a : as)+-- | Return a list of elements ordered by key whose priorities are at most @pt@,+-- and the rest of the queue stripped of these elements.  The returned list of+-- elements can be in any order: no guarantees there.+{-# INLINABLE atMost #-}+atMost :: Prio -> IntPSQ v -> ([Elem v], IntPSQ v)+atMost pt t0 = go [] t0+  where+    go acc t = case t of+        Nil             -> (acc, t)+        Tip k p x+            | p > pt    -> (acc, t)+            | otherwise -> ((E k p x) : acc, Nil) -(<>) :: Sequ a -> Sequ a -> Sequ a-Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as))-infixr 5 <>+        Bin k p x m l r+            | p > pt    -> (acc, t)+            | otherwise ->+                let (acc',  l') = go acc  l+                    (acc'', r') = go acc' r+                in  ((E k p x) : acc'', merge m l' r') -seqToList :: Sequ a -> [a]-seqToList (Sequ x) = x [] --- | @since 4.3.1.0-instance Show a => Show (Sequ a) where-    showsPrec d a = showsPrec d (seqToList a)+------------------------------------------------------------------------------+-- Traversal+------------------------------------------------------------------------------ +-- | Internal function that merges two *disjoint* 'IntPSQ's that share the+-- same prefix mask.+{-# INLINABLE merge #-}+merge :: Mask -> IntPSQ v -> IntPSQ v -> IntPSQ v+merge m l r = case l of+    Nil -> r++    Tip lk lp lx ->+      case r of+        Nil                     -> l+        Tip rk rp rx+          | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r+          | otherwise           -> Bin rk rp rx m l   Nil+        Bin rk rp rx rm rl rr+          | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r+          | otherwise           -> Bin rk rp rx m l   (merge rm rl rr)++    Bin lk lp lx lm ll lr ->+      case r of+        Nil                     -> l+        Tip rk rp rx+          | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r+          | otherwise           -> Bin rk rp rx m l                Nil+        Bin rk rp rx rm rl rr+          | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r+          | otherwise           -> Bin rk rp rx m l                (merge rm rl rr)