diff options
Diffstat (limited to 'libraries/base')
208 files changed, 9218 insertions, 4526 deletions
diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs index 559cceda66..5e2fc8ebe6 100644 --- a/libraries/base/Control/Applicative.hs +++ b/libraries/base/Control/Applicative.hs @@ -64,7 +64,10 @@ import GHC.Read (Read) import GHC.Show (Show) newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } - deriving (Generic, Generic1, Monad) + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Monad -- ^ @since 4.7.0.0 + ) -- | @since 2.01 instance Monad m => Functor (WrappedMonad m) where @@ -82,7 +85,9 @@ instance MonadPlus m => Alternative (WrappedMonad m) where WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } - deriving (Generic, Generic1) + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) -- | @since 2.01 instance Arrow a => Functor (WrappedArrow a b) where @@ -101,13 +106,20 @@ instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where -- | Lists, but with an 'Applicative' functor based on zipping. newtype ZipList a = ZipList { getZipList :: [a] } - deriving ( Show, Eq, Ord, Read, Functor - , Foldable, Generic, Generic1) + deriving ( Show -- ^ @since 4.7.0.0 + , Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Functor -- ^ @since 2.01 + , Foldable -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) -- See Data.Traversable for Traversable instance due to import loops -- | -- > 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: diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs index 377870c88c..8d910277a2 100644 --- a/libraries/base/Control/Arrow.hs +++ b/libraries/base/Control/Arrow.hs @@ -76,7 +76,7 @@ infixr 1 ^<<, <<^ -- -- * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@ -- --- * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@ +-- * @'first' ('first' f) >>> 'arr' assoc = 'arr' assoc >>> 'first' f@ -- -- where -- @@ -209,7 +209,7 @@ instance MonadPlus m => ArrowPlus (Kleisli m) where -- -- * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@ -- --- * @'left' ('left' f) >>> 'arr' 'assocsum' = 'arr' 'assocsum' >>> 'left' f@ +-- * @'left' ('left' f) >>> 'arr' assocsum = 'arr' assocsum >>> 'left' f@ -- -- where -- diff --git a/libraries/base/Control/Category.hs b/libraries/base/Control/Category.hs index ba92178bae..6407a6f509 100644 --- a/libraries/base/Control/Category.hs +++ b/libraries/base/Control/Category.hs @@ -28,8 +28,13 @@ import GHC.Prim (coerce) 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 diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index cc39ddeccf..bd222e2b1e 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -121,6 +121,7 @@ import Foreign.C.Types import Foreign.C import System.IO import Data.Functor ( void ) +import Data.Int ( Int64 ) #else import qualified GHC.Conc #endif @@ -406,7 +407,7 @@ threadWaitRead fd -- fdReady does the right thing, but we have to call it in a -- separate thread, otherwise threadWaitRead won't be interruptible, -- and this only works with -threaded. - | threaded = withThread (waitFd fd 0) + | threaded = withThread (waitFd fd False) | otherwise = case fd of 0 -> do _ <- hWaitForInput stdin (-1) return () @@ -427,7 +428,7 @@ threadWaitRead fd threadWaitWrite :: Fd -> IO () threadWaitWrite fd #if defined(mingw32_HOST_OS) - | threaded = withThread (waitFd fd 1) + | threaded = withThread (waitFd fd True) | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" #else = GHC.Conc.threadWaitWrite fd @@ -443,7 +444,7 @@ threadWaitReadSTM :: Fd -> IO (STM (), IO ()) threadWaitReadSTM fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing - mask_ $ void $ forkIO $ do result <- try (waitFd fd 0) + mask_ $ void $ forkIO $ do result <- try (waitFd fd False) atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of @@ -467,7 +468,7 @@ threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) threadWaitWriteSTM fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing - mask_ $ void $ forkIO $ do result <- try (waitFd fd 1) + mask_ $ void $ forkIO $ do result <- try (waitFd fd True) atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of @@ -493,16 +494,13 @@ withThread io = do Right a -> return a Left e -> throwIO (e :: IOException) -waitFd :: Fd -> CInt -> IO () +waitFd :: Fd -> Bool -> IO () waitFd fd write = do throwErrnoIfMinus1_ "fdReady" $ - fdReady (fromIntegral fd) write iNFINITE 0 - -iNFINITE :: CInt -iNFINITE = 0xFFFFFFFF -- urgh + fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0 foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt #endif -- --------------------------------------------------------------------------- diff --git a/libraries/base/Control/Concurrent/Chan.hs b/libraries/base/Control/Concurrent/Chan.hs index ebbec7ea99..874e48a1a1 100644 --- a/libraries/base/Control/Concurrent/Chan.hs +++ b/libraries/base/Control/Concurrent/Chan.hs @@ -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 @@ module Control.Concurrent.Chan writeChan, readChan, dupChan, - unGetChan, - isEmptyChan, -- * Stream interface getChanContents, @@ -53,7 +50,7 @@ import Control.Exception (mask_) data Chan a = Chan _UPK_(MVar (Stream a)) _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar - deriving (Eq) + deriving Eq -- ^ @since 4.4.0.0 type Stream a = MVar (ChItem a) @@ -105,25 +102,16 @@ writeChan (Chan _ writeVar) val = do -- guarantees of 'MVar's (e.g. threads blocked in this operation are woken up in -- FIFO order). -- --- Throws 'BlockedIndefinitelyOnMVar' when the channel is empty and no other --- thread holds a reference to the channel. +-- Throws 'Control.Exception.BlockedIndefinitelyOnMVar' when the channel is +-- empty and no other thread holds a reference to the channel. readChan :: Chan a -> IO a readChan (Chan readVar _) = do - modifyMVarMasked readVar $ \read_end -> do -- Note [modifyMVarMasked] + modifyMVar readVar $ \read_end -> do (ChItem val new_read_end) <- readMVar read_end -- Use readMVar here, not takeMVar, -- else dupChan doesn't work return (new_read_end, val) --- Note [modifyMVarMasked] --- This prevents a theoretical deadlock if an asynchronous exception --- happens during the readMVar while the MVar is empty. In that case --- the read_end MVar will be left empty, and subsequent readers will --- deadlock. Using modifyMVarMasked prevents this. The deadlock can --- be reproduced, but only by expanding readMVar and inserting an --- artificial yield between its takeMVar and putMVar operations. - - -- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to -- either channel from then on will be available from both. Hence this creates -- a kind of broadcast channel, where data written by anyone is seen by @@ -137,24 +125,6 @@ dupChan (Chan _ writeVar) = do 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. -- |Return a lazy list representing the contents of the supplied diff --git a/libraries/base/Control/Concurrent/MVar.hs b/libraries/base/Control/Concurrent/MVar.hs index 393fca89e2..df28fe8406 100644 --- a/libraries/base/Control/Concurrent/MVar.hs +++ b/libraries/base/Control/Concurrent/MVar.hs @@ -33,16 +33,16 @@ -- -- === Applicability -- --- 'MVar's offer more flexibility than 'IORef's, but less flexibility --- than 'STM'. They are appropriate for building synchronization +-- 'MVar's offer more flexibility than 'Data.IORef.IORef's, but less flexibility +-- than 'GHC.Conc.STM'. They are appropriate for building synchronization -- primitives and performing simple interthread communication; however -- they are very simple and susceptible to race conditions, deadlocks or -- uncaught exceptions. Do not use them if you need perform larger --- atomic operations such as reading from multiple variables: use 'STM' +-- atomic operations such as reading from multiple variables: use 'GHC.Conc.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 @@ -70,7 +70,7 @@ -- -- 'MVar' operations are always observed to take place in the order -- they are written in the program, regardless of the memory model of --- the underlying machine. This is in contrast to 'IORef' operations +-- the underlying machine. This is in contrast to 'Data.IORef.IORef' operations -- which may appear out-of-order to another thread in some cases. -- -- === Example diff --git a/libraries/base/Control/Concurrent/QSem.hs b/libraries/base/Control/Concurrent/QSem.hs index 51624e4777..ea396255a4 100644 --- a/libraries/base/Control/Concurrent/QSem.hs +++ b/libraries/base/Control/Concurrent/QSem.hs @@ -29,7 +29,7 @@ import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar import Control.Exception import Data.Maybe --- | 'QSem' is a quantity semaphore in which the resource is aqcuired +-- | 'QSem' is a quantity semaphore in which the resource is acquired -- and released in units of one. It provides guaranteed FIFO ordering -- for satisfying blocked `waitQSem` calls. -- diff --git a/libraries/base/Control/Concurrent/QSemN.hs b/libraries/base/Control/Concurrent/QSemN.hs index 7686d3f327..b8c9274057 100644 --- a/libraries/base/Control/Concurrent/QSemN.hs +++ b/libraries/base/Control/Concurrent/QSemN.hs @@ -31,7 +31,7 @@ import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar import Control.Exception import Data.Maybe --- | 'QSemN' is a quantity semaphore in which the resource is aqcuired +-- | 'QSemN' is a quantity semaphore in which the resource is acquired -- and released in units of one. It provides guaranteed FIFO ordering -- for satisfying blocked `waitQSemN` calls. -- diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs index 93ba3d5f91..a84005e536 100644 --- a/libraries/base/Control/Exception.hs +++ b/libraries/base/Control/Exception.hs @@ -264,7 +264,7 @@ to write something like > (\e -> handler) If you need to unmask asynchronous exceptions again in the exception -handler, 'restore' can be used there too. +handler, @restore@ can be used there too. Note that 'try' and friends /do not/ have a similar default, because there is no exception handler in this case. Don't use 'try' for @@ -332,21 +332,24 @@ kind of situation: The following operations are guaranteed not to be interruptible: - * operations on 'IORef' from "Data.IORef" + * operations on 'Data.IORef.IORef' from "Data.IORef" - * STM transactions that do not use 'retry' + * STM transactions that do not use 'GHC.Conc.retry' * everything from the @Foreign@ modules - * everything from @Control.Exception@ except for 'throwTo' + * everything from "Control.Exception" except for 'throwTo' - * @tryTakeMVar@, @tryPutMVar@, @isEmptyMVar@ + * 'Control.Concurrent.MVar.tryTakeMVar', 'Control.Concurrent.MVar.tryPutMVar', + 'Control.Concurrent.MVar.isEmptyMVar' - * @takeMVar@ if the @MVar@ is definitely full, and conversely @putMVar@ if the @MVar@ is definitely empty + * 'Control.Concurrent.MVar.takeMVar' if the 'Control.Concurrent.MVar.MVar' is + definitely full, and conversely 'Control.Concurrent.MVar.putMVar' if the + 'Control.Concurrent.MVar.MVar' is definitely empty - * @newEmptyMVar@, @newMVar@ + * 'Control.Concurrent.MVar.newEmptyMVar', 'Control.Concurrent.MVar.newMVar' - * @forkIO@, @forkIOUnmasked@, @myThreadId@ + * 'Control.Concurrent.forkIO', 'Control.Concurrent.myThreadId' -} diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index a15cc8ed32..4b5d94ece7 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -30,6 +30,7 @@ module Control.Exception.Base ( NonTermination(..), NestedAtomically(..), BlockedIndefinitelyOnMVar(..), + FixIOException (..), BlockedIndefinitelyOnSTM(..), AllocationLimitExceeded(..), CompactionFailed(..), @@ -92,9 +93,9 @@ module Control.Exception.Base ( finally, -- * Calls for GHC runtime - recSelError, recConError, irrefutPatError, runtimeError, + recSelError, recConError, runtimeError, nonExhaustiveGuardsError, patError, noMethodBindingError, - absentError, typeError, + absentError, absentSumFieldError, typeError, nonTermination, nestedAtomically, ) where @@ -374,7 +375,7 @@ instance Exception NestedAtomically ----- -recSelError, recConError, irrefutPatError, runtimeError, +recSelError, recConError, runtimeError, nonExhaustiveGuardsError, patError, noMethodBindingError, absentError, typeError :: Addr# -> a -- All take a UTF8-encoded C string @@ -385,7 +386,6 @@ runtimeError s = errorWithoutStackTrace (unpackCStringUtf8# s) absentError s = errorWithoutStackTrace ("Oops! Entered absent arg " ++ unpackCStringUtf8# s) nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) -irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern")) recConError s = throw (RecConError (untangle s "Missing field in record construction")) noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation")) patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in")) @@ -398,3 +398,7 @@ nonTermination = toException NonTermination -- GHC's RTS calls this nestedAtomically :: SomeException nestedAtomically = toException NestedAtomically + +-- Introduced by unarise for unused unboxed sum fields +absentSumFieldError :: a +absentSumFieldError = absentError " in unboxed sum."# diff --git a/libraries/base/Control/Monad.hs b/libraries/base/Control/Monad.hs index 6a474037c0..96d8938101 100644 --- a/libraries/base/Control/Monad.hs +++ b/libraries/base/Control/Monad.hs @@ -86,13 +86,52 @@ import GHC.Num ( (-) ) -- ----------------------------------------------------------------------------- -- 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 --- | This generalizes the list-based 'filter' function. +-- | This generalizes the list-based 'Data.List.filter' function. {-# INLINE filterM #-} filterM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] @@ -100,11 +139,12 @@ filterM p = foldr (\ x -> liftA2 (\ flg -> if flg then (x:) else id) (p x infixr 1 <=<, >=> --- | Left-to-right Kleisli composition of monads. +-- | Left-to-right composition of Kleisli arrows. (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \x -> f x >>= g --- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped. +-- | Right-to-left composition of Kleisli arrows. @('>=>')@, with the arguments +-- flipped. -- -- Note how this operator resembles function composition @('.')@: -- @@ -113,7 +153,30 @@ f >=> g = \x -> f x >>= g (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) (<=<) = flip (>=>) --- | @'forever' act@ repeats the action infinitely. +-- | Repeat an action indefinitely. +-- +-- ==== __Examples__ +-- +-- A common use of 'forever' is to process input from network sockets, +-- 'System.IO.Handle's, and channels +-- (e.g. 'Control.Concurrent.MVar.MVar' and +-- 'Control.Concurrent.Chan.Chan'). +-- +-- For example, here is how we might implement an [echo +-- server](https://en.wikipedia.org/wiki/Echo_Protocol), using +-- 'forever' both to listen for client connections on a network socket +-- and to echo client input on client connection handles: +-- +-- @ +-- echoServer :: Socket -> IO () +-- echoServer socket = 'forever' $ do +-- client <- accept socket +-- 'Control.Concurrent.forkFinally' (echo client) (\\_ -> hClose client) +-- where +-- echo :: Handle -> IO () +-- echo client = 'forever' $ +-- hGetLine client >>= hPutStrLn client +-- @ forever :: (Applicative f) => f a -> f b {-# INLINE forever #-} forever a = let a' = a *> a' in a' @@ -125,7 +188,7 @@ forever a = let a' = a *> a' in a' -- | The 'mapAndUnzipM' function maps its first argument over a list, returning -- the result as a pair of lists. This function is mainly used with complicated --- data structures or a state-transforming monad. +-- data structures or a state monad. mapAndUnzipM :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) {-# INLINE mapAndUnzipM #-} mapAndUnzipM f xs = unzip <$> traverse f xs @@ -140,21 +203,21 @@ zipWithM_ :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m () {-# INLINE zipWithM_ #-} zipWithM_ f xs ys = sequenceA_ (zipWith f xs ys) -{- | The 'foldM' function is analogous to 'foldl', except that its result is +{- | The 'foldM' function is analogous to 'Data.Foldable.foldl', except that its result is encapsulated in a monad. Note that 'foldM' works from left-to-right over the list arguments. This could be an issue where @('>>')@ and the `folded 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. @@ -244,12 +307,25 @@ f <$!> m = do -- ----------------------------------------------------------------------------- -- Other MonadPlus functions --- | Direct 'MonadPlus' equivalent of 'filter' --- @'filter'@ = @(mfilter:: (a -> Bool) -> [a] -> [a]@ --- applicable to any 'MonadPlus', for example --- @mfilter odd (Just 1) == Just 1@ --- @mfilter odd (Just 2) == Nothing@ - +-- | Direct 'MonadPlus' equivalent of 'Data.List.filter'. +-- +-- ==== __Examples__ +-- +-- The 'Data.List.filter' function is just 'mfilter' specialized to +-- the list monad: +-- +-- @ +-- 'Data.List.filter' = ( 'mfilter' :: (a -> Bool) -> [a] -> [a] ) +-- @ +-- +-- An example using 'mfilter' with the 'Maybe' monad: +-- +-- @ +-- >>> mfilter odd (Just 1) +-- Just 1 +-- >>> mfilter odd (Just 2) +-- Nothing +-- @ mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a {-# INLINABLE mfilter #-} mfilter p ma = do @@ -264,19 +340,19 @@ The functions in this library use the following naming conventions: 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 -} diff --git a/libraries/base/Control/Monad/Fail.hs b/libraries/base/Control/Monad/Fail.hs index 91ef3ed349..ecf974bc79 100644 --- a/libraries/base/Control/Monad/Fail.hs +++ b/libraries/base/Control/Monad/Fail.hs @@ -50,13 +50,13 @@ import {-# SOURCE #-} GHC.IO (failIO) -- only a single data constructor, and irrefutable patterns (@~pat@). -- -- Instances of 'MonadFail' should satisfy the following law: @fail s@ should --- be a left zero for '>>=', +-- be a left zero for 'Control.Monad.>>=', -- -- @ -- fail s >>= f = fail s -- @ -- --- If your 'Monad' is also 'MonadPlus', a popular definition is +-- If your 'Monad' is also 'Control.Monad.MonadPlus', a popular definition is -- -- @ -- fail _ = mzero diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs index c8a9ddab58..f287b06541 100644 --- a/libraries/base/Control/Monad/Fix.hs +++ b/libraries/base/Control/Monad/Fix.hs @@ -28,18 +28,19 @@ import Data.Either import Data.Function ( fix ) import Data.Maybe import Data.Monoid ( Dual(..), Sum(..), Product(..) - , First(..), Last(..), Alt(..) ) -import GHC.Base ( Monad, errorWithoutStackTrace, (.) ) + , First(..), Last(..), Alt(..), Ap(..) ) +import Data.Ord ( Down(..) ) +import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) ) import GHC.Generics import GHC.List ( head, tail ) -import GHC.ST +import Control.Monad.ST.Imp import System.IO -- | Monads having fixed points with a \'knot-tying\' semantics. -- Instances of 'MonadFix' should satisfy the following laws: -- -- [/purity/] --- @'mfix' ('return' . h) = 'return' ('fix' h)@ +-- @'mfix' ('Control.Monad.return' . h) = 'Control.Monad.return' ('fix' h)@ -- -- [/left shrinking/ (or /tightening/)] -- @'mfix' (\\x -> a >>= \\y -> f x y) = a >>= \\y -> 'mfix' (\\x -> f x y)@ @@ -74,6 +75,14 @@ instance MonadFix [] where [] -> [] (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 mfix = fixIO @@ -118,6 +127,10 @@ instance MonadFix Last where instance MonadFix f => MonadFix (Alt f) where mfix f = Alt (mfix (getAlt . f)) +-- | @since 4.12.0.0 +instance MonadFix f => MonadFix (Ap f) where + mfix f = Ap (mfix (getAp . f)) + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance MonadFix Par1 where @@ -137,3 +150,10 @@ instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where where fstP (a :*: _) = a sndP (_ :*: b) = b + +-- Instances for Data.Ord + +-- | @since 4.12.0.0 +instance MonadFix Down where + mfix f = Down (fix (getDown . f)) + where getDown (Down x) = x diff --git a/libraries/base/Control/Monad/ST.hs b/libraries/base/Control/Monad/ST.hs index 8313c2d3eb..6f1dc31e38 100644 --- a/libraries/base/Control/Monad/ST.hs +++ b/libraries/base/Control/Monad/ST.hs @@ -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). ----------------------------------------------------------------------------- diff --git a/libraries/base/Control/Monad/ST/Imp.hs b/libraries/base/Control/Monad/ST/Imp.hs index c053dcc64d..55bd780f2c 100644 --- a/libraries/base/Control/Monad/ST/Imp.hs +++ b/libraries/base/Control/Monad/ST/Imp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Unsafe #-} {-# OPTIONS_HADDOCK hide #-} @@ -23,7 +24,7 @@ module Control.Monad.ST.Imp ( runST, fixST, - -- * Converting 'ST' to 'IO' + -- * Converting 'ST' to 'Prelude.IO' RealWorld, -- abstract stToIO, @@ -34,7 +35,56 @@ module Control.Monad.ST.Imp ( unsafeSTToIO ) where -import GHC.ST ( ST, runST, fixST, unsafeInterleaveST +import GHC.ST ( ST, runST, unsafeInterleaveST , unsafeDupableInterleaveST ) -import GHC.Base ( RealWorld ) -import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) +import GHC.Base ( RealWorld, ($), return ) +import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO + , unsafeDupableInterleaveIO ) +import GHC.MVar ( readMVar, putMVar, newEmptyMVar ) +import Control.Exception.Base + ( catch, throwIO, NonTermination (..) + , BlockedIndefinitelyOnMVar (..) ) + +-- | Allow the result of an 'ST' computation to be used (lazily) +-- inside the computation. +-- +-- Note that if @f@ is strict, @'fixST' f = _|_@. +fixST :: (a -> ST s a) -> ST s a +-- See Note [fixST] +fixST k = unsafeIOToST $ do + m <- newEmptyMVar + ans <- unsafeDupableInterleaveIO + (readMVar m `catch` \BlockedIndefinitelyOnMVar -> + throwIO NonTermination) + result <- unsafeSTToIO (k ans) + putMVar m result + return result + +{- Note [fixST] + ~~~~~~~~~~~~ + +For many years, we implemented fixST much like a pure fixpoint, +using liftST: + + fixST :: (a -> ST s a) -> ST s a + fixST k = ST $ \ s -> + let ans = liftST (k r) s + STret _ r = ans + in + case ans of STret s' x -> (# s', x #) + +We knew that lazy blackholing could cause the computation to be re-run if the +result was demanded strictly, but we thought that would be okay in the case of +ST. However, that is not the case (see Trac #15349). Notably, the first time +the computation is executed, it may mutate variables that cause it to behave +*differently* the second time it's run. That may allow it to terminate when it +should not. More frighteningly, Arseniy Alekseyev produced a somewhat contrived +example ( https://mail.haskell.org/pipermail/libraries/2018-July/028889.html ) +demonstrating that it can break reasonable assumptions in "trustworthy" code, +causing a memory safety violation. So now we implement fixST much like we do +fixIO. See also the implementation notes for fixIO. Simon Marlow wondered +whether we could get away with an IORef instead of an MVar. I believe we +cannot. The function passed to fixST may spark a parallel computation that +demands the final result. Such a computation should block until the final +result is available. +-} diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs index 4f1204b89f..699c81e258 100644 --- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs +++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs @@ -14,7 +14,7 @@ -- Portability : non-portable (requires universal quantification for runST) -- -- This module presents an identical interface to "Control.Monad.ST", --- except that the monad delays evaluation of state operations until +-- except that the monad delays evaluation of 'ST' operations until -- a value depending on them is required. -- ----------------------------------------------------------------------------- @@ -46,10 +46,10 @@ import qualified GHC.ST as GHC.ST import GHC.Base import qualified Control.Monad.Fail as Fail --- | The lazy state-transformer monad. --- A computation of type @'ST' s a@ transforms an internal state indexed --- by @s@, and returns a value of type @a@. --- The @s@ parameter is either +-- | The lazy @'ST' monad. +-- The ST monad allows for destructive updates, but is escapable (unlike IO). +-- A computation of type @'ST' s a@ returns a value of type @a@, and +-- execute in "thread" @s@. The @s@ parameter is either -- -- * an uninstantiated type variable (inside invocations of 'runST'), or -- @@ -198,13 +198,13 @@ instance Monad (ST s) where instance Fail.MonadFail (ST s) where fail s = errorWithoutStackTrace s --- | Return the value computed by a state transformer computation. +-- | Return the value computed by an 'ST' computation. -- The @forall@ ensures that the internal state used by the 'ST' -- computation is inaccessible to the rest of the program. runST :: (forall s. ST s a) -> a runST (ST st) = runRW# (\s -> case st (S# s) of (r, _) -> r) --- | Allow the result of a state transformer computation to be used (lazily) +-- | Allow the result of an 'ST' computation to be used (lazily) -- inside the computation. -- Note that if @f@ is strict, @'fixST' f = _|_@. fixST :: (a -> ST s a) -> ST s a @@ -243,7 +243,7 @@ lazyToStrictST :: ST s a -> ST.ST s a lazyToStrictST (ST m) = GHC.ST.ST $ \s -> case (m (S# s)) of (a, S# s') -> (# s', a #) --- | A monad transformer embedding lazy state transformers in the 'IO' +-- | A monad transformer embedding lazy 'ST' in the 'IO' -- monad. The 'RealWorld' parameter indicates that the internal state -- used by the 'ST' computation is a special one supplied by the 'IO' -- monad, and thus distinct from those used by invocations of 'runST'. diff --git a/libraries/base/Control/Monad/ST/Lazy/Safe.hs b/libraries/base/Control/Monad/ST/Lazy/Safe.hs index 9f8e60686f..05aaae7523 100644 --- a/libraries/base/Control/Monad/ST/Lazy/Safe.hs +++ b/libraries/base/Control/Monad/ST/Lazy/Safe.hs @@ -11,7 +11,7 @@ -- Portability : non-portable (requires universal quantification for runST) -- -- This module presents an identical interface to "Control.Monad.ST", --- except that the monad delays evaluation of state operations until +-- except that the monad delays evaluation of 'ST' operations until -- a value depending on them is required. -- -- Safe API only. diff --git a/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs b/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs index 4a1b8c79a6..be31c93c24 100644 --- a/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs +++ b/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs @@ -11,7 +11,7 @@ -- Portability : non-portable (requires universal quantification for runST) -- -- This module presents an identical interface to "Control.Monad.ST", --- except that the monad delays evaluation of state operations until +-- except that the monad delays evaluation of 'ST' operations until -- a value depending on them is required. -- -- Unsafe API. diff --git a/libraries/base/Control/Monad/Zip.hs b/libraries/base/Control/Monad/Zip.hs index 5b670085d4..beef913119 100644 --- a/libraries/base/Control/Monad/Zip.hs +++ b/libraries/base/Control/Monad/Zip.hs @@ -21,7 +21,9 @@ module Control.Monad.Zip where import Control.Monad (liftM, liftM2) import Data.Functor.Identity import Data.Monoid +import Data.Ord ( Down(..) ) import Data.Proxy +import qualified Data.List.NonEmpty as NE import GHC.Generics -- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith` @@ -59,6 +61,12 @@ instance MonadZip [] where 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 mzipWith = liftM2 @@ -117,3 +125,9 @@ instance MonadZip f => MonadZip (M1 i c f) where -- | @since 4.9.0.0 instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2 + +-- instances for Data.Ord + +-- | @since 4.12.0.0 +instance MonadZip Down where + mzipWith = liftM2 diff --git a/libraries/base/Data/Bifoldable.hs b/libraries/base/Data/Bifoldable.hs index 1f632e2ff9..4315fdb259 100644 --- a/libraries/base/Data/Bifoldable.hs +++ b/libraries/base/Data/Bifoldable.hs @@ -76,7 +76,7 @@ import GHC.Generics (K1(..)) -- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z -- @ -- --- If the type is also a 'Bifunctor' instance, it should satisfy: +-- If the type is also a 'Data.Bifunctor.Bifunctor' instance, it should satisfy: -- -- > 'bifoldMap' f g ≡ 'bifold' . 'bimap' f g -- diff --git a/libraries/base/Data/Bifunctor.hs b/libraries/base/Data/Bifunctor.hs index 5441605ecf..04de5ad7f2 100644 --- a/libraries/base/Data/Bifunctor.hs +++ b/libraries/base/Data/Bifunctor.hs @@ -20,7 +20,15 @@ module Data.Bifunctor 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,22 +67,49 @@ class Bifunctor p where -- | 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 instance Bifunctor (,) where bimap f g ~(a, b) = (f a, g b) diff --git a/libraries/base/Data/Bitraversable.hs b/libraries/base/Data/Bitraversable.hs index 169510844d..4064929890 100644 --- a/libraries/base/Data/Bitraversable.hs +++ b/libraries/base/Data/Bitraversable.hs @@ -52,8 +52,11 @@ import GHC.Generics (K1(..)) -- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ -- -- [/composition/] --- @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2 --- ≡ 'traverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@ +-- @'Data.Functor.Compose.Compose' . +-- 'fmap' ('bitraverse' g1 g2) . +-- 'bitraverse' f1 f2 +-- ≡ 'traverse' ('Data.Functor.Compose.Compose' . 'fmap' g1 . f1) +-- ('Data.Functor.Compose.Compose' . 'fmap' g2 . f2)@ -- -- where an /applicative transformation/ is a function -- @@ -66,26 +69,9 @@ import GHC.Generics (K1(..)) -- t (f '<*>' x) = t f '<*>' t x -- @ -- --- and the identity functor 'Identity' and composition functors 'Compose' are --- defined as --- --- > newtype Identity a = Identity { runIdentity :: a } --- > --- > instance Functor Identity where --- > fmap f (Identity x) = Identity (f x) --- > --- > instance Applicative Identity where --- > pure = Identity --- > Identity f <*> Identity x = Identity (f x) --- > --- > newtype Compose f g a = Compose (f (g a)) --- > --- > instance (Functor f, Functor g) => Functor (Compose f g) where --- > fmap f (Compose x) = Compose (fmap (fmap f) x) --- > --- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where --- > pure = Compose . pure . pure --- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +-- and the identity functor 'Identity' and composition functors +-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and +-- "Data.Functor.Compose". -- -- Some simple examples are 'Either' and '(,)': -- diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index d12d6dc4bd..18110b55a8 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -57,17 +57,13 @@ module Data.Bits ( #include "MachDeps.h" -#if defined(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 @@ -194,8 +190,12 @@ class Eq a => Bits a where {-| Return the number of bits in the type of the argument. The actual value of the argument is ignored. The function 'bitSize' is undefined for types that do not have a fixed bitsize, like 'Integer'. + + Default implementation based upon 'bitSizeMaybe' provided since + 4.12.0.0. -} bitSize :: a -> Int + bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b) {-| Return 'True' if the argument is a signed type. The actual value of the argument is ignored -} @@ -245,7 +245,7 @@ class Eq a => Bits a where 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 +526,7 @@ instance Bits Integer where 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 @@ -540,6 +540,74 @@ instance Bits Integer where bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" isSigned _ = True +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0 +instance Bits Natural where + (.&.) = andNatural + (.|.) = orNatural + xor = xorNatural + complement _ = errorWithoutStackTrace + "Bits.complement: Natural complement undefined" + shift x i + | i >= 0 = shiftLNatural x i + | otherwise = shiftRNatural x (negate i) + testBit x i = testBitNatural x i + zeroBits = wordToNaturalBase 0## + clearBit x i = x `xor` (bit i .&. x) + + bit (I# i#) = bitNatural i# + popCount x = popCountNatural x + + rotate x i = shift x i -- since an Natural never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Natural)" + isSigned _ = False +#else +-- | @since 4.8.0.0 +instance Bits Natural where + Natural n .&. Natural m = Natural (n .&. m) + {-# INLINE (.&.) #-} + Natural n .|. Natural m = Natural (n .|. m) + {-# INLINE (.|.) #-} + xor (Natural n) (Natural m) = Natural (xor n m) + {-# INLINE xor #-} + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" + {-# INLINE complement #-} + shift (Natural n) = Natural . shift n + {-# INLINE shift #-} + rotate (Natural n) = Natural . rotate n + {-# INLINE rotate #-} + bit = Natural . bit + {-# INLINE bit #-} + setBit (Natural n) = Natural . setBit n + {-# INLINE setBit #-} + clearBit (Natural n) = Natural . clearBit n + {-# INLINE clearBit #-} + complementBit (Natural n) = Natural . complementBit n + {-# INLINE complementBit #-} + testBit (Natural n) = testBit n + {-# INLINE testBit #-} + bitSizeMaybe _ = Nothing + {-# INLINE bitSizeMaybe #-} + bitSize = errorWithoutStackTrace "Natural: bitSize" + {-# INLINE bitSize #-} + isSigned _ = False + {-# INLINE isSigned #-} + shiftL (Natural n) = Natural . shiftL n + {-# INLINE shiftL #-} + shiftR (Natural n) = Natural . shiftR n + {-# INLINE shiftR #-} + rotateL (Natural n) = Natural . rotateL n + {-# INLINE rotateL #-} + rotateR (Natural n) = Natural . rotateR n + {-# INLINE rotateR #-} + popCount (Natural n) = popCount n + {-# INLINE popCount #-} + zeroBits = Natural 0 + +#endif + ----------------------------------------------------------------------------- -- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using diff --git a/libraries/base/Data/Char.hs b/libraries/base/Data/Char.hs index 69e4db7018..ac0664715c 100644 --- a/libraries/base/Data/Char.hs +++ b/libraries/base/Data/Char.hs @@ -132,6 +132,8 @@ digitToInt c -- True -- >>> isLetter 'A' -- True +-- >>> isLetter 'λ' +-- True -- >>> isLetter '0' -- False -- >>> isLetter '%' diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs index dd3e0eca0b..a544a5bf6c 100644 --- a/libraries/base/Data/Complex.hs +++ b/libraries/base/Data/Complex.hs @@ -55,11 +55,23 @@ infix 6 :+ -- has the phase of @z@, but unit magnitude. -- -- The 'Foldable' and 'Traversable' instances traverse the real part first. +-- +-- Note that `Complex`'s instances inherit the deficiencies from the type +-- parameter's. For example, @Complex Float@'s 'Ord' instance has similar +-- problems to `Float`'s. data Complex a = !a :+ !a -- ^ forms a complex number from its real and imaginary -- rectangular components. - deriving (Eq, Show, Read, Data, Generic, Generic1 - , Functor, Foldable, Traversable) + deriving ( Eq -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Data -- ^ @since 2.01 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Foldable -- ^ @since 4.9.0.0 + , Traversable -- ^ @since 4.9.0.0 + ) -- ----------------------------------------------------------------------------- -- Functions over Complex @@ -197,7 +209,8 @@ instance (RealFloat a) => Floating (Complex a) where 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) diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index 1b55f59b10..fa199f1117 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -4,12 +4,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- @@ -126,7 +126,6 @@ import Data.Version( Version(..) ) import GHC.Base hiding (Any, IntRep, FloatRep) import GHC.List import GHC.Num -import GHC.Natural import GHC.Read import GHC.Show import Text.Read( reads ) @@ -140,6 +139,8 @@ import GHC.Real -- So we can give Data instance for Ratio --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 +278,34 @@ class Typeable a => Data a where ------------------------------------------------------------------------------ -- | 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) @@ -497,7 +510,7 @@ data DataType = DataType , datarep :: DataRep } - deriving Show + deriving Show -- ^ @since 4.0.0.0 -- | Representation of constructors. Note that equality on constructors -- with different types may not work -- i.e. the constructors for 'False' and @@ -529,7 +542,9 @@ data DataRep = AlgRep [Constr] | CharRep | NoRep - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) -- The list of constructors could be an array, a balanced tree, or others. @@ -539,7 +554,9 @@ data ConstrRep = AlgConstr ConIndex | FloatConstr Rational | CharConstr Char - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) -- | Unique index for datatype constructors, @@ -551,7 +568,9 @@ type ConIndex = Int data Fixity = Prefix | Infix -- Later: add associativity and precedence - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) ------------------------------------------------------------------------------ @@ -779,7 +798,7 @@ mkRealConstr dt f = case datarep dt of 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 +1156,9 @@ instance Data a => Data [a] where ------------------------------------------------------------------------------ +-- | @since 4.9.0.0 +deriving instance Data a => Data (NonEmpty a) + -- | @since 4.0.0.0 deriving instance Data a => Data (Maybe a) @@ -1189,6 +1211,12 @@ instance Data a => Data (ForeignPtr a) where 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 -- inefficiency. We omit reflection services for the sake of data abstraction. @@ -1254,6 +1282,9 @@ deriving instance Data a => Data (Last a) -- | @since 4.8.0.0 deriving instance (Data (f a), Data a, Typeable f) => Data (Alt f a) +-- | @since 4.12.0.0 +deriving instance (Data (f a), Data a, Typeable f) => Data (Ap f a) + ---------------------------------------------------------------------------- -- Data instances for GHC.Generics representations @@ -1278,7 +1309,7 @@ deriving instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p)) => Data ((f :+: g) p) -- | @since 4.9.0.0 -deriving instance (Typeable (f :: * -> *), Typeable (g :: * -> *), +deriving instance (Typeable (f :: Type -> Type), Typeable (g :: Type -> Type), Data p, Data (f (g p))) => Data ((f :.: g) p) @@ -1303,3 +1334,9 @@ deriving instance Data SourceStrictness -- | @since 4.9.0.0 deriving instance Data DecidedStrictness + +---------------------------------------------------------------------------- +-- Data instances for Data.Ord + +-- | @since 4.12.0.0 +deriving instance Data a => Data (Down a) diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs index 2469e78511..58987a3910 100644 --- a/libraries/base/Data/Either.hs +++ b/libraries/base/Data/Either.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE StandaloneDeriving #-} @@ -33,8 +34,6 @@ import GHC.Base import GHC.Show import GHC.Read -import Data.Type.Equality - -- $setup -- Allow the use of some Prelude functions in doctests. -- >>> import Prelude ( (+), (*), length, putStrLn ) @@ -124,13 +123,28 @@ Left "parse error" -} data Either a b = Left a | Right b - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 3.0 + , Show -- ^ @since 3.0 + ) -- | @since 3.0 instance Functor (Either a) where 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 @@ -150,7 +164,7 @@ instance Monad (Either e) where -- -- We create two values of type @'Either' 'String' 'Int'@, one using the -- 'Left' constructor and another using the 'Right' constructor. Then --- we apply \"either\" the 'length' function (if we have a 'String') +-- we apply \"either\" the 'Prelude.length' function (if we have a 'String') -- or the \"times-two\" function (if we have an 'Int'): -- -- >>> let s = Left "foo" :: Either String Int @@ -318,13 +332,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 - {- {-------------------------------------------------------------------- Testing @@ -333,4 +340,3 @@ prop_partitionEithers :: [Either Int Int] -> Bool prop_partitionEithers x = partitionEithers x == (lefts x, rights x) -} - diff --git a/libraries/base/Data/Fixed.hs b/libraries/base/Data/Fixed.hs index e5e1f2f746..b8db351257 100644 --- a/libraries/base/Data/Fixed.hs +++ b/libraries/base/Data/Fixed.hs @@ -57,8 +57,10 @@ mod' n d = n - (fromInteger f) * d where f = div' n d -- | The type parameter should be an instance of 'HasResolution'. -newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0 - deriving (Eq,Ord) +newtype Fixed a = MkFixed Integer + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) -- We do this because the automatically derived Data instance requires (Data a) context. -- Our manual instance has the more general (Typeable a) context. diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs index 1d9fc92ca5..f5f3112138 100644 --- a/libraries/base/Data/Foldable.hs +++ b/libraries/base/Data/Foldable.hs @@ -99,6 +99,8 @@ infix 4 `elem`, `notElem` -- -- > fold = foldMap id -- +-- > length = getSum . foldMap (Sum . const 1) +-- -- @sum@, @product@, @maximum@, and @minimum@ should all be essentially -- equivalent to @foldMap@ forms, such as -- @@ -170,8 +172,8 @@ class Foldable t where -- -- Also note that if you want an efficient left-fold, you probably want to -- use 'foldl'' instead of 'foldl'. The reason for this is that latter does - -- not force the "inner" results (e.g. @z `f` x1@ in the above example) - -- before applying them to the operator (e.g. to @(`f` x2)@). This results + -- not force the "inner" results (e.g. @z \`f\` x1@ in the above example) + -- before applying them to the operator (e.g. to @(\`f\` x2)@). This results -- in a thunk chain @O(n)@ elements long, which then must be evaluated from -- the outside-in. -- @@ -294,6 +296,32 @@ instance Foldable [] where 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 + + -- GHC isn't clever enough to transform the default definition + -- into anything like this, so we'd end up shuffling a bunch of + -- Maybes around. + foldr1 f (p :| ps) = foldr go id ps p + where + go x r prev = f prev (r x) + + -- We used to say + -- + -- length (_ :| as) = 1 + length as + -- + -- but the default definition is better, counting from 1. + -- + -- The default definition also works great for null and foldl'. + -- As usual for cons lists, foldr' is basically hopeless. + + foldMap f ~(a :| as) = f a `mappend` foldMap f as + fold ~(m :| ms) = m `mappend` fold ms + toList ~(a :| as) = a : as + -- | @since 4.7.0.0 instance Foldable (Either a) where foldMap _ (Left _) = mempty @@ -408,6 +436,14 @@ instance Foldable First where instance Foldable Last where foldMap f = foldMap f . getLast +-- | @since 4.12.0.0 +instance (Foldable f) => Foldable (Alt f) where + foldMap f = foldMap f . getAlt + +-- | @since 4.12.0.0 +instance (Foldable f) => Foldable (Ap f) where + foldMap f = foldMap f . getAp + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance Foldable U1 where @@ -427,38 +463,76 @@ instance Foldable U1 where sum _ = 0 product _ = 1 +-- | @since 4.9.0.0 deriving instance Foldable V1 + +-- | @since 4.9.0.0 deriving instance Foldable Par1 + +-- | @since 4.9.0.0 deriving instance Foldable f => Foldable (Rec1 f) + +-- | @since 4.9.0.0 deriving instance Foldable (K1 i c) + +-- | @since 4.9.0.0 deriving instance Foldable f => Foldable (M1 i c f) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :+: g) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :*: g) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :.: g) + +-- | @since 4.9.0.0 deriving instance Foldable UAddr + +-- | @since 4.9.0.0 deriving instance Foldable UChar + +-- | @since 4.9.0.0 deriving instance Foldable UDouble + +-- | @since 4.9.0.0 deriving instance Foldable UFloat + +-- | @since 4.9.0.0 deriving instance Foldable UInt + +-- | @since 4.9.0.0 deriving instance Foldable UWord +-- Instances for Data.Ord +-- | @since 4.12.0.0 +deriving instance Foldable Down + -- | Monadic fold over the elements of a structure, -- associating to the right, i.e. from right to left. foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b -foldrM f z0 xs = foldl f' return xs z0 - where f' k x z = f x z >>= k +foldrM f z0 xs = foldl c return xs z0 + -- See Note [List fusion and continuations in 'c'] + where c k x z = f x z >>= k + {-# INLINE c #-} -- | Monadic fold over the elements of a structure, -- associating to the left, i.e. from left to right. foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b -foldlM f z0 xs = foldr f' return xs z0 - where f' x k z = f z x >>= k +foldlM f z0 xs = foldr c return xs z0 + -- See Note [List fusion and continuations in 'c'] + where c x k z = f z x >>= k + {-# INLINE c #-} -- | Map each element of a structure to an action, evaluate these -- actions from left to right, and ignore the results. For a version -- that doesn't ignore the results see 'Data.Traversable.traverse'. traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () -traverse_ f = foldr ((*>) . f) (pure ()) +traverse_ f = foldr c (pure ()) + -- See Note [List fusion and continuations in 'c'] + where c x k = f x *> k + {-# INLINE c #-} -- | 'for_' is 'traverse_' with its arguments flipped. For a version -- that doesn't ignore the results see 'Data.Traversable.for'. @@ -480,7 +554,10 @@ for_ = flip traverse_ -- As of base 4.8.0.0, 'mapM_' is just 'traverse_', specialized to -- 'Monad'. mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () -mapM_ f= foldr ((>>) . f) (return ()) +mapM_ f = foldr c (return ()) + -- See Note [List fusion and continuations in 'c'] + where c x k = f x >> k + {-# INLINE c #-} -- | 'forM_' is 'mapM_' with its arguments flipped. For a version that -- doesn't ignore the results see 'Data.Traversable.forM'. @@ -494,7 +571,10 @@ forM_ = flip mapM_ -- ignore the results. For a version that doesn't ignore the results -- see 'Data.Traversable.sequenceA'. sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () -sequenceA_ = foldr (*>) (pure ()) +sequenceA_ = foldr c (pure ()) + -- See Note [List fusion and continuations in 'c'] + where c m k = m *> k + {-# INLINE c #-} -- | Evaluate each monadic action in the structure from left to right, -- and ignore the results. For a version that doesn't ignore the @@ -503,9 +583,15 @@ sequenceA_ = foldr (*>) (pure ()) -- As of base 4.8.0.0, 'sequence_' is just 'sequenceA_', specialized -- to 'Monad'. sequence_ :: (Foldable t, Monad m) => t (m a) -> m () -sequence_ = foldr (>>) (return ()) +sequence_ = foldr c (return ()) + -- See Note [List fusion and continuations in 'c'] + where c m k = m >> k + {-# INLINE c #-} -- | 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 @@ -580,6 +666,84 @@ find :: Foldable t => (a -> Bool) -> t a -> Maybe a find p = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing)) {- +Note [List fusion and continuations in 'c'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we define + mapM_ f = foldr ((>>) . f) (return ()) +(this is the way it used to be). + +Now suppose we want to optimise the call + + mapM_ <big> (build g) + where + g c n = ...(c x1 y1)...(c x2 y2)....n... + +GHC used to proceed like this: + + mapM_ <big> (build g) + + = { Defintion of mapM_ } + foldr ((>>) . <big>) (return ()) (build g) + + = { foldr/build rule } + g ((>>) . <big>) (return ()) + + = { Inline g } + let c = (>>) . <big> + n = return () + in ...(c x1 y1)...(c x2 y2)....n... + +The trouble is that `c`, being big, will not be inlined. And that can +be absolutely terrible for performance, as we saw in Trac #8763. + +It's much better to define + + mapM_ f = foldr c (return ()) + where + c x k = f x >> k + {-# INLINE c #-} + +Now we get + mapM_ <big> (build g) + + = { inline mapM_ } + foldr c (return ()) (build g) + where c x k = f x >> k + {-# INLINE c #-} + f = <big> + +Notice that `f` does not inline into the RHS of `c`, +because the INLINE pragma stops it; see +Note [Simplifying inside stable unfoldings] in SimplUtils. +Continuing: + + = { foldr/build rule } + g c (return ()) + where ... + c x k = f x >> k + {-# INLINE c #-} + f = <big> + + = { inline g } + ...(c x1 y1)...(c x2 y2)....n... + where c x k = f x >> k + {-# INLINE c #-} + f = <big> + n = return () + + Now, crucially, `c` does inline + + = { inline c } + ...(f x1 >> y1)...(f x2 >> y2)....n... + where f = <big> + n = return () + +And all is well! The key thing is that the fragment +`(f x1 >> y1)` is inlined into the body of the builder +`g`. +-} + +{- Note [maximumBy/minimumBy space usage] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the type signatures of maximumBy and minimumBy were generalized to work diff --git a/libraries/base/Data/Function.hs b/libraries/base/Data/Function.hs index c5ded4cda5..7a77160a60 100644 --- a/libraries/base/Data/Function.hs +++ b/libraries/base/Data/Function.hs @@ -32,21 +32,41 @@ infixl 1 & -- | @'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' b u x y@ runs the binary function @b@ /on/ the results of applying +-- unary function @u@ to two arguments @x@ and @y@. From the opposite +-- perspective, it transforms two inputs and combines the outputs. +-- +-- @((+) \``on`\` f) x y = f x + f y@ -- --- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@. +-- Typical usage: @'Data.List.sortBy' ('Prelude.compare' \`on\` 'Prelude.fst')@. -- -- Algebraic properties: -- --- * @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@) +-- * @(*) \`on\` 'id' = (*) -- (if (*) ∉ {⊥, 'const' ⊥})@ -- -- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@ -- -- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@ - +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +(.*.) `on` f = \x y -> f x .*. f y -- Proofs (so that I don't have to edit the test-suite): -- (*) `on` id @@ -87,14 +107,17 @@ fix f = let x = f x in x -- = -- flip on (g . f) -on :: (b -> b -> c) -> (a -> b) -> a -> a -> c -(.*.) `on` f = \x y -> f x .*. f y - -- | '&' is a reverse application operator. This provides notational -- 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 diff --git a/libraries/base/Data/Functor.hs b/libraries/base/Data/Functor.hs index 62bb70927e..7afcffe05b 100644 --- a/libraries/base/Data/Functor.hs +++ b/libraries/base/Data/Functor.hs @@ -11,8 +11,31 @@ -- Stability : provisional -- Portability : portable -- --- Functors: uniform action over a parameterized type, generalizing the --- 'Data.List.map' function on lists. +-- +-- A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@, +-- lets you apply any function of type @(a -> b)@ to turn an @f a@ into an @f b@, preserving the +-- structure of @f@. +-- +-- ==== __Examples__ +-- +-- >>> fmap show (Just 1) -- (a -> b) -> f a -> f b +-- Just "1" -- (Int -> String) -> Maybe Int -> Maybe String +-- +-- >>> fmap show Nothing -- (a -> b) -> f a -> f b +-- Nothing -- (Int -> String) -> Maybe Int -> Maybe String +-- +-- >>> fmap show [1,2,3] -- (a -> b) -> f a -> f b +-- ["1", "2", "3"] -- (Int -> String) -> [Int] -> [String] +-- +-- >>> fmap show [] -- (a -> b) -> f a -> f b +-- [] -- (Int -> String) -> [Int] -> [String] +-- +-- The 'fmap' function is also available as the infix operator '<$>': +-- +-- >>> fmap show (Just 1) -- (Int -> String) -> Maybe Int -> Maybe String +-- Just "1" +-- >>> show <$> (Just 1) -- (Int -> String) -> Maybe Int -> Maybe String +-- Just "1" module Data.Functor ( @@ -20,6 +43,7 @@ module Data.Functor (<$), ($>), (<$>), + (<&>), void, ) where @@ -33,26 +57,27 @@ infixl 4 <$> -- | An infix synonym for 'fmap'. -- --- The name of this operator is an allusion to '$'. +-- The name of this operator is an allusion to 'Prelude.$'. -- Note the similarities between their types: -- -- > ($) :: (a -> b) -> a -> b -- > (<$>) :: Functor f => (a -> b) -> f a -> f b -- --- Whereas '$' is function application, '<$>' is function +-- Whereas 'Prelude.$' is function application, '<$>' is function -- application lifted over a 'Functor'. -- -- ==== __Examples__ -- --- Convert from a @'Maybe' 'Int'@ to a @'Maybe' 'String'@ using 'show': +-- Convert from a @'Data.Maybe.Maybe' 'Data.Int.Int'@ to a @'Data.Maybe.Maybe' +-- 'Data.String.String'@ using 'Prelude.show': -- -- >>> show <$> Nothing -- Nothing -- >>> show <$> Just 3 -- Just "3" -- --- Convert from an @'Either' 'Int' 'Int'@ to an @'Either' 'Int'@ --- 'String' using 'show': +-- Convert from an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@ to an +-- @'Data.Either.Either' 'Data.Int.Int'@ 'Data.String.String' using 'Prelude.show': -- -- >>> show <$> Left 17 -- Left 17 @@ -64,7 +89,7 @@ infixl 4 <$> -- >>> (*2) <$> [1,2,3] -- [2,4,6] -- --- Apply 'even' to the second element of a pair: +-- Apply 'Prelude.even' to the second element of a pair: -- -- >>> even <$> (2,2) -- (2,True) @@ -74,33 +99,60 @@ infixl 4 <$> 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 '<$'. -- -- @since 4.7.0.0 -- -- ==== __Examples__ -- --- Replace the contents of a @'Maybe' 'Int'@ with a constant 'String': +-- Replace the contents of a @'Data.Maybe.Maybe' 'Data.Int.Int'@ with a constant +-- 'Data.String.String': -- -- >>> Nothing $> "foo" -- Nothing -- >>> Just 90210 $> "foo" -- Just "foo" -- --- Replace the contents of an @'Either' 'Int' 'Int'@ with a constant --- 'String', resulting in an @'Either' 'Int' 'String'@: +-- Replace the contents of an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@ +-- with a constant 'Data.String.String', resulting in an @'Data.Either.Either' +-- 'Data.Int.Int' 'Data.String.String'@: -- -- >>> Left 8675309 $> "foo" -- Left 8675309 -- >>> Right 8675309 $> "foo" -- Right "foo" -- --- Replace each element of a list with a constant 'String': +-- Replace each element of a list with a constant 'Data.String.String': -- -- >>> [1,2,3] $> "foo" -- ["foo","foo","foo"] -- --- Replace the second element of a pair with a constant 'String': +-- Replace the second element of a pair with a constant 'Data.String.String': -- -- >>> (1,2) $> "foo" -- (1,"foo") @@ -113,15 +165,15 @@ infixl 4 $> -- -- ==== __Examples__ -- --- Replace the contents of a @'Maybe' 'Int'@ with unit: +-- Replace the contents of a @'Data.Maybe.Maybe' 'Data.Int.Int'@ with unit: -- -- >>> void Nothing -- Nothing -- >>> void (Just 3) -- Just () -- --- Replace the contents of an @'Either' 'Int' 'Int'@ with unit, --- resulting in an @'Either' 'Int' '()'@: +-- Replace the contents of an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@ +-- with unit, resulting in an @'Data.Either.Either' 'Data.Int.Int' '()'@: -- -- >>> void (Left 8675309) -- Left 8675309 diff --git a/libraries/base/Data/Functor/Classes.hs b/libraries/base/Data/Functor/Classes.hs index 2510da911f..e44c817b64 100644 --- a/libraries/base/Data/Functor/Classes.hs +++ b/libraries/base/Data/Functor/Classes.hs @@ -68,7 +68,9 @@ import Control.Applicative (Alternative((<|>)), Const(Const)) import Data.Functor.Identity (Identity(Identity)) import Data.Proxy (Proxy(Proxy)) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (mappend) +import Data.Ord (Down(Down)) import GHC.Read (expectP, list, paren) @@ -452,6 +454,27 @@ instance Read1 [] where 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 liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 @@ -622,6 +645,24 @@ instance Read1 Proxy where liftReadListPrec = liftReadListPrecDefault liftReadList = liftReadListDefault +-- | @since 4.12.0.0 +instance Eq1 Down where + liftEq eq (Down x) (Down y) = eq x y + +-- | @since 4.12.0.0 +instance Ord1 Down where + liftCompare comp (Down x) (Down y) = comp x y + +-- | @since 4.12.0.0 +instance Read1 Down where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Down" Down + +-- | @since 4.12.0.0 +instance Show1 Down where + liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x + + -- Building blocks -- | @'readsData' p d@ is a parser for datatypes where each alternative diff --git a/libraries/base/Data/Functor/Compose.hs b/libraries/base/Data/Functor/Compose.hs index 68fbfc630a..8ceadb8572 100644 --- a/libraries/base/Data/Functor/Compose.hs +++ b/libraries/base/Data/Functor/Compose.hs @@ -38,7 +38,10 @@ infixr 9 `Compose` -- The composition of applicative functors is always applicative, -- but the composition of monads is not always a monad. newtype Compose f g a = Compose { getCompose :: f (g a) } - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- Instances of lifted Prelude classes diff --git a/libraries/base/Data/Functor/Const.hs b/libraries/base/Data/Functor/Const.hs index 9199b7cf94..4e4992dcf6 100644 --- a/libraries/base/Data/Functor/Const.hs +++ b/libraries/base/Data/Functor/Const.hs @@ -37,12 +37,29 @@ import GHC.Show (Show(showsPrec), showParen, showString) -- | 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) + deriving ( Bits -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , FiniteBits -- ^ @since 4.9.0.0 + , Floating -- ^ @since 4.9.0.0 + , Fractional -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Integral -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Semigroup -- ^ @since 4.9.0.0 + , Monoid -- ^ @since 4.9.0.0 + , Num -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Real -- ^ @since 4.9.0.0 + , RealFrac -- ^ @since 4.9.0.0 + , RealFloat -- ^ @since 4.9.0.0 + , Storable -- ^ @since 4.9.0.0 + ) -- | This instance would be equivalent to the derived instances of the --- 'Const' newtype if the 'runConst' field were removed +-- 'Const' newtype if the 'getConst' field were removed -- -- @since 4.8.0.0 instance Read a => Read (Const a b) where @@ -50,7 +67,7 @@ instance Read a => Read (Const a b) where $ \r -> [(Const x,t) | ("Const", s) <- lex r, (x, t) <- readsPrec 11 s] -- | This instance would be equivalent to the derived instances of the --- 'Const' newtype if the 'runConst' field were removed +-- 'Const' newtype if the 'getConst' field were removed -- -- @since 4.8.0.0 instance Show a => Show (Const a b) where diff --git a/libraries/base/Data/Functor/Contravariant.hs b/libraries/base/Data/Functor/Contravariant.hs new file mode 100644 index 0000000000..184eee2772 --- /dev/null +++ b/libraries/base/Data/Functor/Contravariant.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Contravariant +-- Copyright : (C) 2007-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@, +-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor' +-- the definition of 'Contravariant' for a given ADT is unambiguous. +-- +-- @since 4.12.0.0 +---------------------------------------------------------------------------- + +module Data.Functor.Contravariant ( + -- * Contravariant Functors + Contravariant(..) + , phantom + + -- * Operators + , (>$<), (>$$<), ($<) + + -- * Predicates + , Predicate(..) + + -- * Comparisons + , Comparison(..) + , defaultComparison + + -- * Equivalence Relations + , Equivalence(..) + , defaultEquivalence + , comparisonEquivalence + + -- * Dual arrows + , Op(..) + ) where + +import Control.Applicative +import Control.Category +import Data.Function (on) + +import Data.Functor.Product +import Data.Functor.Sum +import Data.Functor.Compose + +import Data.Monoid (Alt(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Proxy +import GHC.Generics + +import Prelude hiding ((.),id) + +-- | The class of contravariant functors. +-- +-- Whereas in Haskell, one can think of a 'Functor' as containing or producing +-- values, a contravariant functor is a functor that can be thought of as +-- /consuming/ values. +-- +-- As an example, consider the type of predicate functions @a -> Bool@. One +-- such predicate might be @negative x = x < 0@, which +-- classifies integers as to whether they are negative. However, given this +-- predicate, we can re-use it in other situations, providing we have a way to +-- map values /to/ integers. For instance, we can use the @negative@ predicate +-- on a person's bank balance to work out if they are currently overdrawn: +-- +-- @ +-- newtype Predicate a = Predicate { getPredicate :: a -> Bool } +-- +-- instance Contravariant Predicate where +-- contramap f (Predicate p) = Predicate (p . f) +-- | `- First, map the input... +-- `----- then apply the predicate. +-- +-- overdrawn :: Predicate Person +-- overdrawn = contramap personBankBalance negative +-- @ +-- +-- Any instance should be subject to the following laws: +-- +-- > contramap id = id +-- > contramap f . contramap g = contramap (g . f) +-- +-- Note, that the second law follows from the free theorem of the type of +-- 'contramap' and the first law, so you need only check that the former +-- condition holds. + +class Contravariant f where + contramap :: (a -> b) -> f b -> f a + + -- | Replace all locations in the output with the same value. + -- The default definition is @'contramap' . 'const'@, but this may be + -- overridden with a more efficient version. + (>$) :: b -> f b -> f a + (>$) = contramap . const + +-- | If @f@ is both 'Functor' and 'Contravariant' then by the time you factor +-- in the laws of each of those classes, it can't actually use its argument in +-- any meaningful capacity. +-- +-- This method is surprisingly useful. Where both instances exist and are +-- lawful we have the following laws: +-- +-- @ +-- 'fmap' f ≡ 'phantom' +-- 'contramap' f ≡ 'phantom' +-- @ +phantom :: (Functor f, Contravariant f) => f a -> f b +phantom x = () <$ x $< () + +infixl 4 >$, $<, >$<, >$$< + +-- | This is '>$' with its arguments flipped. +($<) :: Contravariant f => f b -> b -> f a +($<) = flip (>$) + +-- | This is an infix alias for 'contramap'. +(>$<) :: Contravariant f => (a -> b) -> f b -> f a +(>$<) = contramap + +-- | This is an infix version of 'contramap' with the arguments flipped. +(>$$<) :: Contravariant f => f b -> (a -> b) -> f a +(>$$<) = flip contramap + +deriving instance Contravariant f => Contravariant (Alt f) +deriving instance Contravariant f => Contravariant (Rec1 f) +deriving instance Contravariant f => Contravariant (M1 i c f) + +instance Contravariant V1 where + contramap _ x = case x of + +instance Contravariant U1 where + contramap _ _ = U1 + +instance Contravariant (K1 i c) where + contramap _ (K1 c) = K1 c + +instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where + contramap f (xs :*: ys) = contramap f xs :*: contramap f ys + +instance (Functor f, Contravariant g) => Contravariant (f :.: g) where + contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg) + +instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where + contramap f (L1 xs) = L1 (contramap f xs) + contramap f (R1 ys) = R1 (contramap f ys) + +instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where + contramap f (InL xs) = InL (contramap f xs) + contramap f (InR ys) = InR (contramap f ys) + +instance (Contravariant f, Contravariant g) + => Contravariant (Product f g) where + contramap f (Pair a b) = Pair (contramap f a) (contramap f b) + +instance Contravariant (Const a) where + contramap _ (Const a) = Const a + +instance (Functor f, Contravariant g) => Contravariant (Compose f g) where + contramap f (Compose fga) = Compose (fmap (contramap f) fga) + +instance Contravariant Proxy where + contramap _ _ = Proxy + +newtype Predicate a = Predicate { getPredicate :: a -> Bool } + +-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can +-- apply its function argument to the input of the predicate. +instance Contravariant Predicate where + contramap f g = Predicate $ getPredicate g . f + +instance Semigroup (Predicate a) where + Predicate p <> Predicate q = Predicate $ \a -> p a && q a + +instance Monoid (Predicate a) where + mempty = Predicate $ const True + +-- | Defines a total ordering on a type as per 'compare'. +-- +-- This condition is not checked by the types. You must ensure that the +-- supplied values are valid total orderings yourself. +newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering } + +deriving instance Semigroup (Comparison a) +deriving instance Monoid (Comparison a) + +-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can +-- apply its function argument to each input of the comparison function. +instance Contravariant Comparison where + contramap f g = Comparison $ on (getComparison g) f + +-- | Compare using 'compare'. +defaultComparison :: Ord a => Comparison a +defaultComparison = Comparison compare + +-- | This data type represents an equivalence relation. +-- +-- Equivalence relations are expected to satisfy three laws: +-- +-- __Reflexivity__: +-- +-- @ +-- 'getEquivalence' f a a = True +-- @ +-- +-- __Symmetry__: +-- +-- @ +-- 'getEquivalence' f a b = 'getEquivalence' f b a +-- @ +-- +-- __Transitivity__: +-- +-- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' +-- then so is @'getEquivalence' f a c@. +-- +-- The types alone do not enforce these laws, so you'll have to check them +-- yourself. +newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool } + +-- | Equivalence relations are 'Contravariant', because you can +-- apply the contramapped function to each input to the equivalence +-- relation. +instance Contravariant Equivalence where + contramap f g = Equivalence $ on (getEquivalence g) f + +instance Semigroup (Equivalence a) where + Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b + +instance Monoid (Equivalence a) where + mempty = Equivalence (\_ _ -> True) + +-- | Check for equivalence with '=='. +-- +-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@. +defaultEquivalence :: Eq a => Equivalence a +defaultEquivalence = Equivalence (==) + +comparisonEquivalence :: Comparison a -> Equivalence a +comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ + +-- | Dual function arrows. +newtype Op a b = Op { getOp :: b -> a } + +deriving instance Semigroup a => Semigroup (Op a b) +deriving instance Monoid a => Monoid (Op a b) + +instance Category Op where + id = Op id + Op f . Op g = Op (g . f) + +instance Contravariant (Op a) where + contramap f g = Op (getOp g . f) + +instance Num a => Num (Op a b) where + Op f + Op g = Op $ \a -> f a + g a + Op f * Op g = Op $ \a -> f a * g a + Op f - Op g = Op $ \a -> f a - g a + abs (Op f) = Op $ abs . f + signum (Op f) = Op $ signum . f + fromInteger = Op . const . fromInteger + +instance Fractional a => Fractional (Op a b) where + Op f / Op g = Op $ \a -> f a / g a + recip (Op f) = Op $ recip . f + fromRational = Op . const . fromRational + +instance Floating a => Floating (Op a b) where + pi = Op $ const pi + exp (Op f) = Op $ exp . f + sqrt (Op f) = Op $ sqrt . f + log (Op f) = Op $ log . f + sin (Op f) = Op $ sin . f + tan (Op f) = Op $ tan . f + cos (Op f) = Op $ cos . f + asin (Op f) = Op $ asin . f + atan (Op f) = Op $ atan . f + acos (Op f) = Op $ acos . f + sinh (Op f) = Op $ sinh . f + tanh (Op f) = Op $ tanh . f + cosh (Op f) = Op $ cosh . f + asinh (Op f) = Op $ asinh . f + atanh (Op f) = Op $ atanh . f + acosh (Op f) = Op $ acosh . f + Op f ** Op g = Op $ \a -> f a ** g a + logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a) diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs index 1fe127f310..daaa3a450c 100644 --- a/libraries/base/Data/Functor/Identity.hs +++ b/libraries/base/Data/Functor/Identity.hs @@ -43,7 +43,7 @@ import Data.Functor.Utils ((#.)) 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) @@ -57,9 +57,26 @@ import GHC.Types (Bool(..)) -- -- @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 - , Real, RealFrac, RealFloat, Storable) + deriving ( Bits -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.8.0.0 + , FiniteBits -- ^ @since 4.9.0.0 + , Floating -- ^ @since 4.9.0.0 + , Fractional -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.8.0.0 + , Generic1 -- ^ @since 4.8.0.0 + , Integral -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Semigroup -- ^ @since 4.9.0.0 + , Monoid -- ^ @since 4.9.0.0 + , Num -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.8.0.0 + , Real -- ^ @since 4.9.0.0 + , RealFrac -- ^ @since 4.9.0.0 + , RealFloat -- ^ @since 4.9.0.0 + , Storable -- ^ @since 4.9.0.0 + ) -- | This instance would be equivalent to the derived instances of the -- 'Identity' newtype if the 'runIdentity' field were removed diff --git a/libraries/base/Data/Functor/Product.hs b/libraries/base/Data/Functor/Product.hs index 7676aa5f0c..d98d31ea59 100644 --- a/libraries/base/Data/Functor/Product.hs +++ b/libraries/base/Data/Functor/Product.hs @@ -35,7 +35,10 @@ import Text.Read (Read(..), readListDefault, readListPrecDefault) -- | Lifted product of functors. data Product f g a = Pair (f a) (g a) - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where diff --git a/libraries/base/Data/Functor/Sum.hs b/libraries/base/Data/Functor/Sum.hs index f18feae2f0..68e60fe817 100644 --- a/libraries/base/Data/Functor/Sum.hs +++ b/libraries/base/Data/Functor/Sum.hs @@ -31,7 +31,10 @@ import Text.Read (Read(..), readListDefault, readListPrecDefault) -- | Lifted sum of functors. data Sum f g a = InL (f a) | InR (g a) - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where diff --git a/libraries/base/Data/Functor/Utils.hs b/libraries/base/Data/Functor/Utils.hs index 1bd729bcca..57e75424da 100644 --- a/libraries/base/Data/Functor/Utils.hs +++ b/libraries/base/Data/Functor/Utils.hs @@ -11,7 +11,7 @@ module Data.Functor.Utils where 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,29 +22,33 @@ import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monoid(..), Ord(..) 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 +-- left-to-right state-transforming monad newtype StateL s a = StateL { runStateL :: s -> (s, a) } -- | @since 4.0 @@ -63,7 +67,7 @@ instance Applicative (StateL s) where (s'', y) = ky s' in (s'', f x y) --- right-to-left state transformer +-- right-to-left state-transforming monad newtype StateR s a = StateR { runStateR :: s -> (s, a) } -- | @since 4.0 diff --git a/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs index c6275f5433..44769268cf 100644 --- a/libraries/base/Data/IORef.hs +++ b/libraries/base/Data/IORef.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -36,8 +37,7 @@ module Data.IORef import GHC.Base import GHC.STRef -import GHC.IORef hiding (atomicModifyIORef) -import qualified GHC.IORef +import GHC.IORef import GHC.Weak -- |Make a 'Weak' pointer to an 'IORef', using the second argument as a finalizer @@ -91,18 +91,9 @@ modifyIORef' ref f = do -- Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem. -- atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef = GHC.IORef.atomicModifyIORef - --- | Strict version of 'atomicModifyIORef'. This forces both the value stored --- in the 'IORef' as well as the value returned. --- --- @since 4.6.0.0 -atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef' ref f = do - b <- atomicModifyIORef ref $ \a -> - case f a of - v@(a',_) -> a' `seq` v - b `seq` return b +atomicModifyIORef ref f = do + (_old, ~(_new, res)) <- atomicModifyIORef2 ref f + pure res -- | Variant of 'writeIORef' with the \"barrier to reordering\" property that -- 'atomicModifyIORef' has. @@ -110,8 +101,8 @@ atomicModifyIORef' ref f = do -- @since 4.6.0.0 atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref a = do - x <- atomicModifyIORef ref (\_ -> (a, ())) - x `seq` return () + _ <- atomicSwapIORef ref a + pure () {- $memmodel @@ -120,19 +111,23 @@ atomicWriteIORef ref a = do processor architecture. For example, on x86, loads can move ahead of stores, so in the following example: -> maybePrint :: IORef Bool -> IORef Bool -> IO () -> maybePrint myRef yourRef = do -> writeIORef myRef True -> yourVal <- readIORef yourRef -> unless yourVal $ putStrLn "critical section" -> -> main :: IO () -> main = do -> r1 <- newIORef False -> r2 <- newIORef False -> forkIO $ maybePrint r1 r2 -> forkIO $ maybePrint r2 r1 -> threadDelay 1000000 + > import Data.IORef + > import Control.Monad (unless) + > import Control.Concurrent (forkIO, threadDelay) + > + > maybePrint :: IORef Bool -> IORef Bool -> IO () + > maybePrint myRef yourRef = do + > writeIORef myRef True + > yourVal <- readIORef yourRef + > unless yourVal $ putStrLn "critical section" + > + > main :: IO () + > main = do + > r1 <- newIORef False + > r2 <- newIORef False + > forkIO $ maybePrint r1 r2 + > forkIO $ maybePrint r2 r1 + > threadDelay 1000000 it is possible that the string @"critical section"@ is printed twice, even though there is no interleaving of the operations of the diff --git a/libraries/base/Data/Kind.hs b/libraries/base/Data/Kind.hs index 348301347c..9ee7b7ab07 100644 --- a/libraries/base/Data/Kind.hs +++ b/libraries/base/Data/Kind.hs @@ -14,6 +14,6 @@ -- @since 4.9.0.0 ----------------------------------------------------------------------------- -module Data.Kind ( Type, Constraint, type (*), type (★) ) where +module Data.Kind ( Type, Constraint ) where import GHC.Types diff --git a/libraries/base/Data/List.hs b/libraries/base/Data/List.hs index 693c0dd151..4b839e954f 100644 --- a/libraries/base/Data/List.hs +++ b/libraries/base/Data/List.hs @@ -76,6 +76,7 @@ module Data.List -- ** Infinite lists , iterate + , iterate' , repeat , replicate , cycle @@ -177,8 +178,8 @@ module Data.List -- counterpart whose name is suffixed with \`@By@\'. -- -- It is often convenient to use these functions together with - -- 'Data.Function.on', for instance @'sortBy' ('compare' - -- \`on\` 'fst')@. + -- 'Data.Function.on', for instance @'sortBy' ('Prelude.compare' + -- ``Data.Function.on`` 'Prelude.fst')@. -- *** User-supplied equality (replacing an @Eq@ context) -- | The predicate is assumed to define an equivalence. diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs index d1cc28c91f..61c1f3d414 100644 --- a/libraries/base/Data/List/NonEmpty.hs +++ b/libraries/base/Data/List/NonEmpty.hs @@ -102,65 +102,14 @@ import Prelude hiding (break, cycle, drop, dropWhile, 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) +import GHC.Base (NonEmpty(..)) -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) - --- | @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 @@ unfoldr f a = case f a of 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 @@ -462,7 +380,7 @@ groupWith1 f = groupBy1 ((==) `on` f) groupAllWith1 :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) groupAllWith1 f = groupWith1 f . sortWith f --- | The 'isPrefix' function returns @True@ if the first argument is +-- | The 'isPrefixOf' function returns 'True' if the first argument is -- a prefix of the second. isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool isPrefixOf [] _ = True diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs index d8aad53b9e..d41ae92672 100644 --- a/libraries/base/Data/Maybe.hs +++ b/libraries/base/Data/Maybe.hs @@ -55,7 +55,7 @@ import GHC.Base -- >>> maybe False odd Nothing -- False -- --- Read an integer from a string using 'readMaybe'. If we succeed, +-- Read an integer from a string using 'Text.Read.readMaybe'. If we succeed, -- return twice the integer; that is, apply @(*2)@ to it. If instead -- we fail to parse an integer, return @0@ by default: -- @@ -65,7 +65,7 @@ import GHC.Base -- >>> maybe 0 (*2) (readMaybe "") -- 0 -- --- Apply 'show' to a @Maybe Int@. If we have @Just n@, we want to show +-- Apply 'Prelude.show' to a @Maybe Int@. If we have @Just n@, we want to show -- the underlying 'Int' @n@. But if we have 'Nothing', we return the -- empty string instead of (for example) \"Nothing\": -- @@ -161,7 +161,7 @@ fromJust (Just x) = x -- >>> fromMaybe "" Nothing -- "" -- --- Read an integer from a string using 'readMaybe'. If we fail to +-- Read an integer from a string using 'Text.Read.readMaybe'. If we fail to -- parse an integer, we want to return @0@ by default: -- -- >>> import Text.Read ( readMaybe ) @@ -228,9 +228,12 @@ maybeToList (Just x) = [x] -- >>> 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. diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index 6ccdb34045..cf55b2150c 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | @@ -16,8 +16,43 @@ -- Stability : experimental -- Portability : portable -- --- A class for monoids (types with an associative binary operation that --- has an identity) with various general-purpose instances. +-- A type @a@ is a 'Monoid' if it provides an associative function ('<>') +-- that lets you combine any two values of type @a@ into one, and a neutral +-- element (`mempty`) such that +-- +-- > a <> mempty == mempty <> a == a +-- +-- A 'Monoid' is a 'Semigroup' with the added requirement of a neutral element. +-- Thus any 'Monoid' is a 'Semigroup', but not the other way around. +-- +-- ==== __Examples__ +-- +-- The 'Sum' monoid is defined by the numerical addition operator and `0` as neutral element: +-- +-- >>> mempty :: Sum Int +-- Sum 0 +-- >>> Sum 1 <> Sum 2 <> Sum 3 <> Sum 4 :: Sum Int +-- Sum {getSum = 10} +-- +-- We can combine multiple values in a list into a single value using the `mconcat` function. +-- Note that we have to specify the type here since 'Int' is a monoid under several different +-- operations: +-- +-- >>> mconcat [1,2,3,4] :: Sum Int +-- Sum {getSum = 10} +-- >>> mconcat [] :: Sum Int +-- Sum {getSum = 0} +-- +-- Another valid monoid instance of 'Int' is 'Product' It is defined by multiplication +-- and `1` as neutral element: +-- +-- >>> Product 1 <> Product 2 <> Product 3 <> Product 4 :: Product Int +-- Product {getProduct = 24} +-- >>> mconcat [1,2,3,4] :: Product Int +-- Product {getProduct = 24} +-- >>> mconcat [] :: Product Int +-- Product {getProduct = 1} +-- -- ----------------------------------------------------------------------------- @@ -38,131 +73,25 @@ module Data.Monoid ( First(..), Last(..), -- * 'Alternative' wrapper - Alt (..) + Alt(..), + -- * 'Applicative' wrapper + Ap(..) ) where -- Push down the module in the dependency hierarchy. import GHC.Base hiding (Any) import GHC.Enum +import GHC.Generics 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) +import Control.Monad.Fail (MonadFail) --- | @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': +-- To implement @find@ or @findLast@ on any 'Data.Foldable.Foldable': -- -- @ -- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a @@ -171,20 +100,20 @@ instance Monad Product where -- else Last Nothing) -- @ -- --- Much of Data.Map's interface can be implemented with --- Data.Map.alter. Some of the rest can be implemented with a new --- @alterA@ function and either 'First' or 'Last': +-- Much of 'Data.Map.Lazy.Map's interface can be implemented with +-- 'Data.Map.Lazy.alter'. Some of the rest can be implemented with a new +-- 'Data.Map.Lazy.alterF' function and either 'First' or 'Last': -- --- > alterA :: (Applicative f, Ord k) => +-- > alterF :: (Functor f, Ord k) => -- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a) -- > --- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative +-- > instance Monoid a => Functor ((,) a) -- from Data.Functor -- -- @ -- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v -- -> Map k v -> (Maybe v, Map k v) -- insertLookupWithKey combine key value = --- Arrow.first getFirst . alterA doChange key +-- Arrow.first getFirst . 'Data.Map.Lazy.alterF' doChange key -- where -- doChange Nothing = (First Nothing, Just value) -- doChange (Just oldValue) = @@ -197,41 +126,121 @@ instance Monad Product where -- -- @'First' a@ is isomorphic to @'Alt' 'Maybe' a@, but precedes it -- historically. +-- +-- >>> getFirst (First (Just "hello") <> First Nothing <> First (Just "world")) +-- Just "hello" +-- +-- Use of this type is discouraged. Note the following equivalence: +-- +-- > Data.Monoid.First x === Maybe (Data.Semigroup.First x) +-- +-- In addition to being equivalent in the structural sense, the two +-- also have 'Monoid' instances that behave the same. This type will +-- be marked deprecated in GHC 8.8, and removed in GHC 8.10. +-- Users are advised to use the variant from "Data.Semigroup" and wrap +-- it in 'Maybe'. newtype First a = First { getFirst :: Maybe a } - deriving (Eq, Ord, Read, Show, Generic, Generic1, - Functor, Applicative, Monad) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + ) + +-- | @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" +-- +-- Use of this type is discouraged. Note the following equivalence: +-- +-- > Data.Monoid.Last x === Maybe (Data.Semigroup.Last x) +-- +-- In addition to being equivalent in the structural sense, the two +-- also have 'Monoid' instances that behave the same. This type will +-- be marked deprecated in GHC 8.8, and removed in GHC 8.10. +-- Users are advised to use the variant from "Data.Semigroup" and wrap +-- it in 'Maybe'. newtype Last a = Last { getLast :: Maybe a } - deriving (Eq, Ord, Read, Show, Generic, Generic1, - Functor, Applicative, Monad) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + ) + +-- | @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 '<|>'. +-- | This data type witnesses the lifting of a 'Monoid' into an +-- 'Applicative' pointwise. -- --- @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) +-- @since 4.12.0.0 +newtype Ap f a = Ap { getAp :: f a } + deriving ( Alternative -- ^ @since 4.12.0.0 + , Applicative -- ^ @since 4.12.0.0 + , Enum -- ^ @since 4.12.0.0 + , Eq -- ^ @since 4.12.0.0 + , Functor -- ^ @since 4.12.0.0 + , Generic -- ^ @since 4.12.0.0 + , Generic1 -- ^ @since 4.12.0.0 + , Monad -- ^ @since 4.12.0.0 + , MonadFail -- ^ @since 4.12.0.0 + , MonadPlus -- ^ @since 4.12.0.0 + , Ord -- ^ @since 4.12.0.0 + , Read -- ^ @since 4.12.0.0 + , Show -- ^ @since 4.12.0.0 + ) + +-- | @since 4.12.0.0 +instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where + (Ap x) <> (Ap y) = Ap $ liftA2 (<>) x y + +-- | @since 4.12.0.0 +instance (Applicative f, Monoid a) => Monoid (Ap f a) where + mempty = Ap $ pure mempty + +-- | @since 4.12.0.0 +instance (Applicative f, Bounded a) => Bounded (Ap f a) where + minBound = pure minBound + maxBound = pure maxBound + +-- | @since 4.12.0.0 +instance (Applicative f, Num a) => Num (Ap f a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum {- {-------------------------------------------------------------------- @@ -253,3 +262,6 @@ prop_mconcatLast x = where listLastToMaybe [] = Nothing listLastToMaybe lst = Just (last lst) -- -} + +-- $setup +-- >>> import Prelude diff --git a/libraries/base/Data/OldList.hs b/libraries/base/Data/OldList.hs index bee1b6f98a..ee2dfac982 100644 --- a/libraries/base/Data/OldList.hs +++ b/libraries/base/Data/OldList.hs @@ -77,6 +77,7 @@ module Data.OldList -- ** Infinite lists , iterate + , iterate' , repeat , replicate , cycle @@ -228,8 +229,12 @@ infix 5 \\ -- comment to fool cpp: https://www.haskell.org/ghc/docs/latest/html/ -- | 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 @@ -240,10 +245,17 @@ dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] -- 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) @@ -253,34 +265,54 @@ stripPrefix _ _ = Nothing -- | 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] #if defined(USE_REPORT_PRELUDE) findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] #else -- Efficient definition, adapted from Data.Sequence -{-# INLINE findIndices #-} +-- (Note that making this INLINABLE instead of INLINE allows +-- 'findIndex' to fuse, fixing #15426.) +{-# INLINABLE findIndices #-} findIndices p ls = build $ \c n -> let go x r k | p x = I# k `c` r (k +# 1#) | otherwise = r (k +# 1#) @@ -289,6 +321,12 @@ findIndices p ls = build $ \c n -> -- | 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 @@ -297,6 +335,12 @@ isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys -- | 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 @@ -311,6 +355,12 @@ ns `isSuffixOf` hs = maybe False id $ do -- 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 _ [] = [] @@ -318,6 +368,9 @@ dropLength (_:x') (_:y') = dropLength x' y' -- 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 @@ -327,10 +380,11 @@ dropLengthMaybe (_:x') (_:y') = dropLengthMaybe x' y' -- 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) @@ -339,12 +393,18 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- (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] #if defined(USE_REPORT_PRELUDE) nubBy eq [] = [] @@ -374,16 +434,19 @@ elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs -- | '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 @@ -394,6 +457,9 @@ deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -- -- > (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. @@ -403,7 +469,8 @@ deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -- | 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 @@ -421,11 +488,13 @@ unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs -- | 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 @@ -444,8 +513,8 @@ intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] -- \`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 @@ -462,18 +531,22 @@ prependToAll sep (x:xs) = sep : x : prependToAll sep xs -- | '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 @@ -485,7 +558,9 @@ transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t -- 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 @@ -549,6 +624,9 @@ mapAccumR f s (x:xs) = (s'', y:ys) -- 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 @@ -563,6 +641,11 @@ insertBy cmp x ys@(y:ys') -- | 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 @@ -574,6 +657,11 @@ maximumBy cmp xs = foldl1 maxBy xs -- | 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 @@ -734,7 +822,8 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- 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. @@ -750,7 +839,8 @@ groupBy eq (x:xs) = (x:ys) : groupBy eq zs -- | 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 ++ _|_@ @@ -768,7 +858,8 @@ inits = map toListSB . scanl' snocSB emptySB -- | 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 _|_ = _|_ : _|_@ @@ -782,14 +873,16 @@ tails lst = build (\c n -> -- | 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) @@ -798,7 +891,8 @@ nonEmptySubsequences (x:xs) = [x] : foldr f [] (nonEmptySubsequences xs) -- | 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 @@ -819,9 +913,15 @@ permutations xs0 = xs0 : perms xs0 [] -- -- 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] #if defined(USE_REPORT_PRELUDE) @@ -987,6 +1087,9 @@ rqpart cmp x (y:ys) rle rgt r = -- 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 = @@ -1012,8 +1115,8 @@ sortOn f = -- -- 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] @@ -1058,13 +1161,26 @@ unfoldr f b0 = build (\c n -> -- 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] @@ -1082,6 +1198,9 @@ lines s = cons (case break (== '\n') s of -- | '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 #if defined(USE_REPORT_PRELUDE) unlines = concatMap (++ "\n") @@ -1094,6 +1213,9 @@ unlines (l:ls) = l ++ '\n' : unlines ls -- | '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 @@ -1117,6 +1239,9 @@ wordsFB c n = go -- | 'unwords' is an inverse operation to 'words'. -- It joins words with separating spaces. +-- +-- >>> unwords ["Lorem", "ipsum", "dolor"] +-- "Lorem ipsum dolor" unwords :: [String] -> String #if defined(USE_REPORT_PRELUDE) unwords [] = "" diff --git a/libraries/base/Data/Ord.hs b/libraries/base/Data/Ord.hs index 11d6967134..c6b7e59543 100644 --- a/libraries/base/Data/Ord.hs +++ b/libraries/base/Data/Ord.hs @@ -48,11 +48,12 @@ comparing p x y = compare (p x) (p y) -- @since 4.6.0.0 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 - , Monoid -- ^ @since 4.11.0.0 + ( Eq -- ^ @since 4.6.0.0 + , 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 diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs index d6f03548f3..557cc1e4dd 100644 --- a/libraries/base/Data/Proxy.hs +++ b/libraries/base/Data/Proxy.hs @@ -28,12 +28,38 @@ import GHC.Read 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 -- ^ @since 4.7.0.0 + , 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 +data KProxy (t :: Type) = KProxy -- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t) -- interchangeably, so all of these instances are hand-written to be @@ -52,10 +78,6 @@ instance Show (Proxy s) where 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 @@ instance Ix (Proxy s) where 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 @@ instance MonadPlus Proxy -- 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 #-} + diff --git a/libraries/base/Data/Ratio.hs b/libraries/base/Data/Ratio.hs index 8517e485ff..946824fec2 100644 --- a/libraries/base/Data/Ratio.hs +++ b/libraries/base/Data/Ratio.hs @@ -47,27 +47,32 @@ import GHC.Real -- The basic defns for Ratio -- 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'' diff --git a/libraries/base/Data/STRef.hs b/libraries/base/Data/STRef.hs index 60bccf50cb..46ca08361b 100644 --- a/libraries/base/Data/STRef.hs +++ b/libraries/base/Data/STRef.hs @@ -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 @@ import GHC.STRef -- | 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 () diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs index fae207ef97..fad1b206c4 100644 --- a/libraries/base/Data/Semigroup.hs +++ b/libraries/base/Data/Semigroup.hs @@ -19,15 +19,52 @@ -- Stability : provisional -- Portability : portable -- --- In mathematics, a semigroup is an algebraic structure consisting of a --- set together with an associative binary operation. A semigroup --- generalizes a monoid in that there might not exist an identity --- element. It also (originally) generalized a group (a monoid with all --- inverses) to a type where every element did not have to have an inverse, --- thus the name semigroup. +-- A type @a@ is a 'Semigroup' if it provides an associative function ('<>') +-- that lets you combine any two values of type @a@ into one. Where being +-- associative means that the following must always hold: -- --- The use of @(\<\>)@ in this module conflicts with an operator with the same --- name that is being exported by Data.Monoid. However, this package +-- >>> (a <> b) <> c == a <> (b <> c) +-- +-- ==== __Examples__ +-- +-- The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller +-- number: +-- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int +-- Min {getMin = 1} +-- +-- If we need to combine multiple values we can use the 'sconcat' function +-- to do so. We need to ensure however that we have at least one value to +-- operate on, since otherwise our result would be undefined. It is for this +-- reason that 'sconcat' uses "Data.List.NonEmpty.NonEmpty" - a list that +-- can never be empty: +-- +-- >>> (1 :| []) +-- 1 :| [] -- equivalent to [1] but guaranteed to be non-empty +-- >>> (1 :| [2, 3, 4]) +-- 1 :| [2,3,4] -- equivalent to [1,2,3,4] but guaranteed to be non-empty +-- +-- Equipped with this guaranteed to be non-empty data structure, we can combine +-- values using 'sconcat' and a 'Semigroup' of our choosing. We can try the 'Min' +-- and 'Max' instances of 'Int' which pick the smallest, or largest number +-- respectively: +-- +-- >>> sconcat (1 :| [2, 3, 4]) :: Min Int +-- Min {getMin = 1} +-- >>> sconcat (1 :| [2, 3, 4]) :: Max Int +-- Max {getMax = 4} +-- +-- String concatenation is another example of a 'Semigroup' instance: +-- +-- >>> "foo" <> "bar" +-- "foobar" +-- +-- A 'Semigroup' is a generalization of a 'Monoid'. Yet unlike the 'Semigroup', the 'Monoid' +-- requires the presence of a neutral element ('mempty') in addition to the associative +-- operator. The requirement for a neutral element prevents many types from being a full Monoid, +-- like "Data.List.NonEmpty.NonEmpty". +-- +-- Note that the use of @(\<\>)@ in this module conflicts with an operator with the same +-- name that is being exported by "Data.Monoid". However, this package -- re-exports (most of) the contents of Data.Monoid, so to use semigroups -- and monoids in the same package just -- @@ -48,7 +85,6 @@ module Data.Semigroup ( , Last(..) , WrappedMonoid(..) -- * Re-exported monoids from Data.Monoid - , Monoid(..) , Dual(..) , Endo(..) , All(..) @@ -69,6 +105,10 @@ module Data.Semigroup ( import Prelude hiding (foldr1) +import GHC.Base (Semigroup(..)) + +import Data.Semigroup.Internal + import Control.Applicative import Control.Monad import Control.Monad.Fix @@ -77,261 +117,30 @@ import Data.Bifunctor 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.Ord (Down(..)) -import Data.Void -#if !defined(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.11.0.0 -instance Semigroup a => Semigroup (Down a) where - Down a <> Down b = Down (a <> b) - stimes n (Down a) = Down (stimes n a) - - --- | @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) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Min a) where @@ -353,7 +162,6 @@ instance Ord a => Semigroup (Min a) where -- | @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 @@ -395,7 +203,15 @@ instance Num a => Num (Min a) where fromInteger = Min . fromInteger newtype Max a = Max { getMax :: a } - deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Max a) where @@ -416,7 +232,6 @@ instance Ord a => Semigroup (Max a) where -- | @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 @@ -460,7 +275,12 @@ instance Num a => Num (Max a) where -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be -- placed inside 'Min' and 'Max' to compute an arg min or arg max. data Arg a b = Arg a b deriving - (Show, Read, Data, Generic, Generic1) + ( Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) type ArgMin a b = Min (Arg a b) type ArgMax a b = Max (Arg a b) @@ -497,7 +317,7 @@ instance Bifunctor Arg where -- | @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 @@ -505,8 +325,16 @@ instance Bitraversable Arg where -- | Use @'Option' ('First' a)@ to get the behavior of -- 'Data.Monoid.First' from "Data.Monoid". -newtype First a = First { getFirst :: a } deriving - (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) +newtype First a = First { getFirst :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (First a) where @@ -555,8 +383,16 @@ instance MonadFix First where -- | Use @'Option' ('Last' a)@ to get the behavior of -- 'Data.Monoid.Last' from "Data.Monoid" -newtype Last a = Last { getLast :: a } deriving - (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) +newtype Last a = Last { getLast :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Last a) where @@ -605,8 +441,19 @@ instance MonadFix Last where 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) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Monoid m => Semigroup (WrappedMonoid m) where @@ -615,7 +462,6 @@ instance Monoid m => Semigroup (WrappedMonoid m) where -- | @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 @@ -646,9 +492,21 @@ mtimesDefault n x -- underlying 'Monoid'. -- -- Ideally, this type would not exist at all and we would just fix the --- 'Monoid' instance of 'Maybe' +-- 'Monoid' instance of 'Maybe'. +-- +-- In GHC 8.4 and higher, the 'Monoid' instance for 'Maybe' has been +-- corrected to lift a 'Semigroup' instance instead of a 'Monoid' +-- instance. Consequently, this type is no longer useful. It will be +-- marked deprecated in GHC 8.8 and removed in GHC 8.10. newtype Option a = Option { getOption :: Maybe a } - deriving (Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Functor Option where @@ -699,40 +557,15 @@ option n j (Option m) = maybe n j m -- | @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 (<>) - -#if !defined(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 diff --git a/libraries/base/Data/Semigroup/Internal.hs b/libraries/base/Data/Semigroup/Internal.hs new file mode 100644 index 0000000000..7484608c24 --- /dev/null +++ b/libraries/base/Data/Semigroup/Internal.hs @@ -0,0 +1,312 @@ +{-# 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 -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) + +-- | @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.7.0.0 + ) + +-- | @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 -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + ) + +-- | @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 -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + ) + +-- | @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 -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.7.0.0 + ) + +-- | @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 -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.7.0.0 + ) + +-- | @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 -- ^ @since 4.8.0.0 + , Generic1 -- ^ @since 4.8.0.0 + , Read -- ^ @since 4.8.0.0 + , Show -- ^ @since 4.8.0.0 + , Eq -- ^ @since 4.8.0.0 + , Ord -- ^ @since 4.8.0.0 + , Num -- ^ @since 4.8.0.0 + , Enum -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + , MonadPlus -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Alternative -- ^ @since 4.8.0.0 + , Functor -- ^ @since 4.8.0.0 + ) + +-- | @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 diff --git a/libraries/base/Data/Semigroup/Internal.hs-boot b/libraries/base/Data/Semigroup/Internal.hs-boot new file mode 100644 index 0000000000..36249294e7 --- /dev/null +++ b/libraries/base/Data/Semigroup/Internal.hs-boot @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Semigroup.Internal where + +import {-# SOURCE #-} GHC.Real (Integral) +import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe) +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base + +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] diff --git a/libraries/base/Data/String.hs b/libraries/base/Data/String.hs index e9f34a82a9..a7295a2144 100644 --- a/libraries/base/Data/String.hs +++ b/libraries/base/Data/String.hs @@ -88,4 +88,6 @@ instance (a ~ Char) => IsString [a] where -- | @since 4.9.0.0 deriving instance IsString a => IsString (Const a b) + +-- | @since 4.9.0.0 deriving instance IsString a => IsString (Identity a) diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs index 5c2745edeb..93c42258e2 100644 --- a/libraries/base/Data/Traversable.hs +++ b/libraries/base/Data/Traversable.hs @@ -60,11 +60,13 @@ import Data.Foldable ( Foldable ) import Data.Functor import Data.Functor.Identity ( Identity(..) ) import Data.Functor.Utils ( StateL(..), StateR(..) ) -import Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..) ) +import Data.Monoid ( Dual(..), Sum(..), Product(..), + First(..), Last(..), Alt(..), Ap(..) ) +import Data.Ord ( Down(..) ) 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 ) @@ -163,7 +165,7 @@ class (Functor t, Foldable t) => Traversable t where traverse f = sequenceA . fmap f -- | Evaluate each action in the structure from left to right, and - -- and collect the results. For a version that ignores the results + -- collect the results. For a version that ignores the results -- see 'Data.Foldable.sequenceA_'. sequenceA :: Applicative f => t (f a) -> f (t a) {-# INLINE sequenceA #-} -- See Note [Inline default methods] @@ -198,8 +200,8 @@ Consider 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/ @@ -237,6 +239,10 @@ instance Traversable [] where 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 traverse _ (Left x) = pure (Left x) @@ -285,12 +291,22 @@ instance Traversable First where instance Traversable Last where traverse f (Last x) = Last <$> traverse f x +-- | @since 4.12.0.0 +instance (Traversable f) => Traversable (Alt f) where + traverse f (Alt x) = Alt <$> traverse f x + +-- | @since 4.12.0.0 +instance (Traversable f) => Traversable (Ap f) where + traverse f (Ap x) = Ap <$> traverse f x + -- | @since 4.9.0.0 instance Traversable ZipList where traverse f (ZipList x) = ZipList <$> traverse f x +-- | @since 4.9.0.0 deriving instance Traversable Identity + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance Traversable U1 where @@ -303,21 +319,52 @@ instance Traversable U1 where sequence _ = pure U1 {-# INLINE sequence #-} +-- | @since 4.9.0.0 deriving instance Traversable V1 + +-- | @since 4.9.0.0 deriving instance Traversable Par1 + +-- | @since 4.9.0.0 deriving instance Traversable f => Traversable (Rec1 f) + +-- | @since 4.9.0.0 deriving instance Traversable (K1 i c) + +-- | @since 4.9.0.0 deriving instance Traversable f => Traversable (M1 i c f) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :+: g) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :*: g) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :.: g) + +-- | @since 4.9.0.0 deriving instance Traversable UAddr + +-- | @since 4.9.0.0 deriving instance Traversable UChar + +-- | @since 4.9.0.0 deriving instance Traversable UDouble + +-- | @since 4.9.0.0 deriving instance Traversable UFloat + +-- | @since 4.9.0.0 deriving instance Traversable UInt + +-- | @since 4.9.0.0 deriving instance Traversable UWord +-- Instance for Data.Ord +-- | @since 4.12.0.0 +deriving instance Traversable Down + -- general functions -- | 'for' is 'traverse' with its arguments flipped. For a version @@ -333,14 +380,14 @@ forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM = flip mapM -- |The 'mapAccumL' function behaves like a combination of 'fmap' --- and 'foldl'; it applies a function to each element of a structure, +-- and 'Data.Foldable.foldl'; it applies a function to each element of a structure, -- passing an accumulating parameter from left to right, and returning -- a final value of this accumulator together with the new structure. mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s -- |The 'mapAccumR' function behaves like a combination of 'fmap' --- and 'foldr'; it applies a function to each element of a structure, +-- and 'Data.Foldable.foldr'; it applies a function to each element of a structure, -- passing an accumulating parameter from right to left, and returning -- a final value of this accumulator together with the new structure. mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) diff --git a/libraries/base/Data/Tuple.hs b/libraries/base/Data/Tuple.hs index 372e2b8a86..569dd14da0 100644 --- a/libraries/base/Data/Tuple.hs +++ b/libraries/base/Data/Tuple.hs @@ -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 :: (a,b) -> b 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) diff --git a/libraries/base/Data/Type/Coercion.hs b/libraries/base/Data/Type/Coercion.hs index 2358115c6d..b757682a62 100644 --- a/libraries/base/Data/Type/Coercion.hs +++ b/libraries/base/Data/Type/Coercion.hs @@ -76,13 +76,17 @@ trans Coercion Coercion = Coercion repr :: (a Eq.:~: b) -> Coercion a b repr Eq.Refl = Coercion +-- | @since 4.7.0.0 deriving instance Eq (Coercion a b) + +-- | @since 4.7.0.0 deriving instance Show (Coercion a b) + +-- | @since 4.7.0.0 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 diff --git a/libraries/base/Data/Type/Equality.hs b/libraries/base/Data/Type/Equality.hs index 8cc34f687d..dfdf23b5f0 100644 --- a/libraries/base/Data/Type/Equality.hs +++ b/libraries/base/Data/Type/Equality.hs @@ -4,14 +4,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- @@ -53,30 +53,6 @@ import GHC.Read import GHC.Base import Data.Type.Bool --- | Lifted, homogeneous equality. By lifted, we mean that it can be --- bogus (deferred type error). By homogeneous, the two types @a@ --- and @b@ must have the same kind. -class a ~~ b => (a :: k) ~ (b :: k) - -- See Note [The equality types story] in TysPrim - -- NB: All this class does is to wrap its superclass, which is - -- the "real", inhomogeneous equality; this is needed when - -- we have a Given (a~b), and we want to prove things from it - -- NB: Not exported, as (~) is magical syntax. That's also why there's - -- no fixity. - - -- It's tempting to put functional dependencies on (~), but it's not - -- necessary because the functional-dependency coverage check looks - -- through superclasses, and (~#) is handled in that check. - --- | @since 4.9.0.0 -instance {-# INCOHERENT #-} a ~~ b => a ~ b - -- See Note [The equality types story] in TysPrim - -- If we have a Wanted (t1 ~ t2), we want to immediately - -- simplify it to (t1 ~~ t2) and solve that instead - -- - -- INCOHERENT because we want to use this instance eagerly, even when - -- the tyvars are partially unknown. - infix 4 :~:, :~~: -- | Propositional equality. If @a :~: b@ is inhabited by some terminating @@ -120,13 +96,17 @@ inner Refl = Refl outer :: (f a :~: g b) -> (f :~: g) outer Refl = Refl +-- | @since 4.7.0.0 deriving instance Eq (a :~: b) + +-- | @since 4.7.0.0 deriving instance Show (a :~: b) + +-- | @since 4.7.0.0 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 +118,7 @@ instance a ~ b => Enum (a :~: b) where -- | @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 +133,7 @@ deriving instance Show (a :~~: b) 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 +160,47 @@ instance TestEquality ((:~:) a) where 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 - --- 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 +-- | 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 + +-- 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`. diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs index 6157e82b1f..c9a8711d79 100644 --- a/libraries/base/Data/Typeable.hs +++ b/libraries/base/Data/Typeable.hs @@ -86,8 +86,6 @@ module Data.Typeable -- * 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 @@ -200,44 +198,30 @@ rnfTypeRep = I.rnfSomeTypeRep -- Keeping backwards-compatibility -typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep +typeOf1 :: forall t (a :: Type). Typeable t => t a -> TypeRep typeOf1 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep +typeOf2 :: forall t (a :: Type) (b :: Type). Typeable t => t a b -> TypeRep typeOf2 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t - => t a b c -> TypeRep +typeOf3 :: forall t (a :: Type) (b :: Type) (c :: Type). + Typeable t => t a b c -> TypeRep typeOf3 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t - => t a b c d -> TypeRep +typeOf4 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type). + Typeable t => t a b c d -> TypeRep typeOf4 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t - => t a b c d e -> TypeRep +typeOf5 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type). + Typeable t => t a b c d e -> TypeRep typeOf5 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *). - Typeable t => t a b c d e f -> TypeRep +typeOf6 :: forall t (a :: Type) (b :: Type) (c :: Type) + (d :: Type) (e :: Type) (f :: Type). + Typeable t => t a b c d e f -> TypeRep typeOf6 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *) - (g :: *). Typeable t => t a b c d e f g -> TypeRep +typeOf7 :: forall t (a :: Type) (b :: Type) (c :: Type) + (d :: Type) (e :: Type) (f :: Type) (g :: Type). + 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 diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index cf3ea0732d..0d4fc825cf 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} @@ -18,6 +17,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -32,6 +32,11 @@ ----------------------------------------------------------------------------- module Data.Typeable.Internal ( + -- * Typeable and kind polymorphism + -- + -- #kind_instantiation + + -- * Miscellaneous Fingerprint(..), -- * Typeable class @@ -70,7 +75,7 @@ module Data.Typeable.Internal ( -- * Construction -- | These are for internal use only - mkTrCon, mkTrApp, mkTrFun, + mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun, mkTyCon, mkTyCon#, typeSymbolTypeRep, typeNatTypeRep, ) where @@ -79,10 +84,10 @@ import GHC.Base import qualified GHC.Arr as A import GHC.Types ( TYPE ) import Data.Type.Equality -import GHC.List ( splitAt, foldl' ) +import GHC.List ( splitAt, foldl', elem ) 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 ) @@ -92,6 +97,7 @@ import {-# SOURCE #-} GHC.Fingerprint -- 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" @@ -173,20 +179,111 @@ rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k -- | 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 @@ -221,6 +318,14 @@ instance Ord SomeTypeRep where SomeTypeRep a `compare` SomeTypeRep b = typeRepFingerprint a `compare` typeRepFingerprint b +-- | The function type constructor. +-- +-- For instance, +-- +-- @ +-- typeRep \@(Int -> Char) === Fun (typeRep \@Int) (typeRep \@Char) +-- @ +-- pattern Fun :: forall k (fun :: k). () => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (arg :: TYPE r1) (res :: TYPE r2). @@ -228,16 +333,21 @@ pattern Fun :: forall k (fun :: k). () => 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. @@ -245,54 +355,195 @@ typeRepFingerprint (TrFun fpr _ _) = fpr -- 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 + +-- 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! --- | Construct a representation for a type application. --- -- 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] --- | Pattern match on a type application +-- | 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 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 k (a :: k) rep (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. -pattern Con' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a -pattern Con' con ks <- TrTyCon _ con ks +-- +-- 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). () + => 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. @@ -301,9 +552,10 @@ someTypeRepTyCon (SomeTypeRep t) = typeRepTyCon t -- | 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 -- @@ -311,9 +563,17 @@ typeRepTyCon (TrFun _ _ _) = typeRepTyCon $ typeRep @(->) eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~~: b) eqTypeRep a b - | typeRepFingerprint a == typeRepFingerprint b = Just (unsafeCoerce HRefl) - | otherwise = Nothing - + | sameTypeRep a b = Just (unsafeCoerce# HRefl) + | otherwise = Nothing +-- We want GHC to inline eqTypeRep to get rid of the Maybe +-- in the usual case that it is scrutinized immediately. We +-- split eqTypeRep into a worker and wrapper because otherwise +-- it's much larger than anything we'd want to inline. +{-# INLINABLE eqTypeRep #-} + +sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2). + TypeRep a -> TypeRep b -> Bool +sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b ------------------------------------------------------------- -- @@ -323,14 +583,10 @@ eqTypeRep a b -- | 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 = @@ -351,14 +607,15 @@ instantiateKindRep vars = go 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) @@ -374,16 +631,16 @@ unkindedTypeRep :: SomeKindedTypeRep k -> SomeTypeRep unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x data SomeKindedTypeRep k where - SomeKindedTypeRep :: forall (a :: k). TypeRep a + SomeKindedTypeRep :: forall k (a :: k). TypeRep a -> SomeKindedTypeRep k kApp :: SomeKindedTypeRep (k -> k') -> 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 :: forall k (a :: k). Typeable a => SomeKindedTypeRep k kindedTypeRep = SomeKindedTypeRep (typeRep @a) buildList :: forall k. Typeable k @@ -447,6 +704,34 @@ vecElemTypeRep e = 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 @@ -484,25 +769,24 @@ instance Show (TypeRep (a :: k)) where 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 []) - = showsPrec p tycon -showTypeable p (TrTyCon _ tycon args) +showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []}) + = showTyCon tycon +showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args}) = showParen (p > 9) $ - showsPrec p tycon . + showTyCon 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 ' ' . @@ -516,23 +800,68 @@ splitApps :: TypeRep a -> (TyCon, [SomeTypeRep]) 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 | ('(':',':_) <- tyConName tc = True | otherwise = False +-- This is only an approximation. We don't have the general +-- character-classification machinery here, so we just do our best. +-- This should work for promoted Haskell 98 data constructors and +-- for TypeOperators type constructors that begin with ASCII +-- characters, but it will miss Unicode operators. +-- +-- If we wanted to catch Unicode as well, we ought to consider moving +-- GHC.Lexeme from ghc-boot-th to base. Then we could just say: +-- +-- startsVarSym symb || startsConSym symb +-- +-- But this is a fair deal of work just for one corner case, so I think I'll +-- leave it like this unless someone shouts. +isOperatorTyCon :: TyCon -> Bool +isOperatorTyCon tc + | symb : _ <- tyConName tc + , symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True + | otherwise = False + +showTyCon :: TyCon -> ShowS +showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon) + showArgs :: Show a => ShowS -> [a] -> ShowS showArgs _ [] = id showArgs _ [a] = showsPrec 10 a @@ -542,9 +871,11 @@ showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as -- -- @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 @@ -649,13 +980,65 @@ tcNat :: TyCon tcNat = typeRepTyCon (typeRep @Nat) -- | An internal function, to make representations for type literals. -typeLitTypeRep :: forall (a :: k). (Typeable k) => String -> TyCon -> TypeRep a +typeLitTypeRep :: forall k (a :: k). (Typeable k) => + String -> TyCon -> TypeRep a typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) [] -- | For compiler use. 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] + +{- $kind_instantiation + +Consider a type like 'Data.Proxy.Proxy', + +@ +data Proxy :: forall k. k -> Type +@ + +One might think that one could decompose an instantiation of this type like +@Proxy Int@ into two applications, + +@ +'App' (App a b) c === typeRep @(Proxy Int) +@ + +where, + +@ +a = typeRep @Proxy +b = typeRep @Type +c = typeRep @Int +@ + +However, this isn't the case. Instead we can only decompose into an application +and a constructor, + +@ +'App' ('Con' proxyTyCon) (typeRep @Int) === typeRep @(Proxy Int) +@ + +The reason for this is that 'Typeable' can only represent /kind-monomorphic/ +types. That is, we must saturate enough of @Proxy@\'s arguments to +fully determine its kind. In the particular case of @Proxy@ this means we must +instantiate the kind variable @k@ such that no @forall@-quantified variables +remain. + +While it is not possible to decompose the 'Con' above into an application, it is +possible to observe the kind variable instantiations of the constructor with the +'Con\'' pattern, + +@ +'App' (Con' proxyTyCon kinds) _ === typeRep @(Proxy Int) +@ + +Here @kinds@ will be @[typeRep \@Type]@. + +-} diff --git a/libraries/base/Data/Unique.hs b/libraries/base/Data/Unique.hs index 2db9247572..eef6256395 100644 --- a/libraries/base/Data/Unique.hs +++ b/libraries/base/Data/Unique.hs @@ -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 @@ import Data.IORef -- | 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 diff --git a/libraries/base/Data/Version.hs b/libraries/base/Data/Version.hs index 310d7387fb..6fb0169d12 100644 --- a/libraries/base/Data/Version.hs +++ b/libraries/base/Data/Version.hs @@ -94,7 +94,10 @@ data Version = -- The interpretation of the list of tags is entirely dependent -- on the entity that this version applies to. } - deriving (Read,Show,Generic) + deriving ( Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.9.0.0 + ) {-# DEPRECATED versionTags "See GHC ticket #2496" #-} -- TODO. Remove all references to versionTags in GHC 8.0 release. diff --git a/libraries/base/Data/Void.hs b/libraries/base/Data/Void.hs index fd4c0b5b21..beb6041f62 100644 --- a/libraries/base/Data/Void.hs +++ b/libraries/base/Data/Void.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} @@ -28,31 +29,22 @@ import Control.Exception 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,9 +56,22 @@ instance Ix Void where -- | @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 absurd a = case a of {} diff --git a/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs index 40475d32f9..7f40b10156 100644 --- a/libraries/base/Debug/Trace.hs +++ b/libraries/base/Debug/Trace.hs @@ -55,6 +55,9 @@ import GHC.Show 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 @@ before returning the second argument as its result. 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 @@ trace string expr = unsafePerformIO $ do {-| 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 @@ Like 'trace', but uses 'show' on the argument to convert it to a 'String'. 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@: + +>>> let f x y = traceShow (x,y) (x + y) in f (1+2) 5 +(3,5) +8 -> f x y = -> traceShow (x, z) $ result -> where -> z = ... -> ... -} -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 {-| @@ -156,28 +169,41 @@ Note that the application of 'traceM' is not an action in the 'Applicative' context, as 'traceIO' is in the 'IO' type. While the fresh bindings in the following example will force the 'traceM' expressions to be reduced every time the @do@-block is executed, @traceM "not crashed"@ would only be reduced once, -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 +and the message would only be printed once. If your monad is in +'Control.Monad.IO.Class.MonadIO', @'Control.Monad.IO.Class.liftIO' . 'traceIO'@ +may be a better option. + +>>> :{ +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 -} diff --git a/libraries/base/Debug/Trace.hs-boot b/libraries/base/Debug/Trace.hs-boot new file mode 100644 index 0000000000..9dbbe2dd37 --- /dev/null +++ b/libraries/base/Debug/Trace.hs-boot @@ -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 () diff --git a/libraries/base/Foreign/C/Types.hs b/libraries/base/Foreign/C/Types.hs index b2e723f724..1b18935b9e 100644 --- a/libraries/base/Foreign/C/Types.hs +++ b/libraries/base/Foreign/C/Types.hs @@ -37,9 +37,9 @@ module Foreign.C.Types -- | These types are represented as @newtype@s of -- types in "Data.Int" and "Data.Word", and are instances of -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', - -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable', - -- 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral' and - -- 'Bits'. + -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable', + -- 'Storable', 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral' + -- and 'Bits'. CChar(..), CSChar(..), CUChar(..) , CShort(..), CUShort(..), CInt(..), CUInt(..) , CLong(..), CULong(..) @@ -51,7 +51,8 @@ module Foreign.C.Types -- | These types are represented as @newtype@s of basic -- foreign types, and are instances of -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', - -- 'Prelude.Show', 'Prelude.Enum', 'Typeable' and 'Storable'. + -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable' and + -- 'Storable'. , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..) -- extracted from CTime, because we don't want this comment in @@ -66,9 +67,13 @@ module Foreign.C.Types -- | These types are represented as @newtype@s of -- 'Prelude.Float' and 'Prelude.Double', and are instances of -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', - -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable', + -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable', 'Storable', -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating', - -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. + -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. That does mean + -- that `CFloat`'s (respectively `CDouble`'s) instances of + -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num' and + -- 'Prelude.Fractional' are as badly behaved as `Prelude.Float`'s + -- (respectively `Prelude.Double`'s). , CFloat(..), CDouble(..) -- XXX GHC doesn't support CLDouble yet -- , CLDouble(..) diff --git a/libraries/base/Foreign/Concurrent.hs b/libraries/base/Foreign/Concurrent.hs index a19b20b664..e197f798c3 100644 --- a/libraries/base/Foreign/Concurrent.hs +++ b/libraries/base/Foreign/Concurrent.hs @@ -40,33 +40,34 @@ newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a) -- associating a finalizer - given by the monadic operation - with the -- reference. The storage manager will start the finalizer, in a -- separate thread, some time after the last reference to the --- @ForeignPtr@ is dropped. There is no guarantee of promptness, and +-- 'ForeignPtr' is dropped. There is no guarantee of promptness, and -- in fact there is no guarantee that the finalizer will eventually -- run at all. -- -- Note that references from a finalizer do not necessarily prevent -- another object from being finalized. If A's finalizer refers to B --- (perhaps using 'touchForeignPtr', then the only guarantee is that --- B's finalizer will never be started before A's. If both A and B --- are unreachable, then both finalizers will start together. See --- 'touchForeignPtr' for more on finalizer ordering. +-- (perhaps using 'Foreign.ForeignPtr.touchForeignPtr', then the only +-- guarantee is that B's finalizer will never be started before A's. If both +-- A and B are unreachable, then both finalizers will start together. See +-- 'Foreign.ForeignPtr.touchForeignPtr' for more on finalizer ordering. -- newForeignPtr = GHC.ForeignPtr.newConcForeignPtr addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO () --- ^This function adds a finalizer to the given @ForeignPtr@. The +-- ^This function adds a finalizer to the given 'ForeignPtr'. The -- finalizer will run /before/ all other finalizers for the same -- object which have already been registered. -- --- This is a variant of @Foreign.ForeignPtr.addForeignPtrFinalizer@, --- where the finalizer is an arbitrary @IO@ action. When it is +-- This is a variant of 'Foreign.ForeignPtr.addForeignPtrFinalizer', +-- where the finalizer is an arbitrary 'IO' action. When it is -- invoked, the finalizer will run in a new thread. -- -- NB. Be very careful with these finalizers. One common trap is that -- if a finalizer references another finalized value, it does not --- prevent that value from being finalized. In particular, 'Handle's --- are finalized objects, so a finalizer should not refer to a 'Handle' --- (including @stdout@, @stdin@ or @stderr@). +-- prevent that value from being finalized. In particular, 'System.IO.Handle's +-- are finalized objects, so a finalizer should not refer to a +-- 'System.IO.Handle' (including 'System.IO.stdout', 'System.IO.stdin', or +-- 'System.IO.stderr'). -- addForeignPtrFinalizer = GHC.ForeignPtr.addForeignPtrConcFinalizer diff --git a/libraries/base/Foreign/ForeignPtr.hs b/libraries/base/Foreign/ForeignPtr.hs index a684a8d25b..12bd4bfdc8 100644 --- a/libraries/base/Foreign/ForeignPtr.hs +++ b/libraries/base/Foreign/ForeignPtr.hs @@ -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 ( diff --git a/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs index 2a3c756035..c32f0b62d7 100644 --- a/libraries/base/Foreign/Marshal/Alloc.hs +++ b/libraries/base/Foreign/Marshal/Alloc.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, + ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | @@ -79,20 +80,14 @@ import GHC.Base -- no longer required. -- {-# INLINE malloc #-} -malloc :: Storable a => IO (Ptr a) -malloc = doMalloc undefined - where - doMalloc :: Storable b => b -> IO (Ptr b) - doMalloc dummy = mallocBytes (sizeOf dummy) +malloc :: forall a . Storable a => IO (Ptr a) +malloc = mallocBytes (sizeOf (undefined :: a)) -- |Like 'malloc' but memory is filled with bytes of value zero. -- {-# INLINE calloc #-} -calloc :: Storable a => IO (Ptr a) -calloc = doCalloc undefined - where - doCalloc :: Storable b => b -> IO (Ptr b) - doCalloc dummy = callocBytes (sizeOf dummy) +calloc :: forall a . Storable a => IO (Ptr a) +calloc = callocBytes (sizeOf (undefined :: a)) -- |Allocate a block of memory of the given number of bytes. -- The block of memory is sufficiently aligned for any of the basic @@ -117,11 +112,22 @@ callocBytes size = failWhenNULL "calloc" $ _calloc 1 (fromIntegral size) -- exception), so the pointer passed to @f@ must /not/ be used after this. -- {-# INLINE alloca #-} -alloca :: Storable a => (Ptr a -> IO b) -> IO b -alloca = doAlloca undefined - where - doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' - doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) +alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b +alloca = + allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a)) + +-- 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. @@ -141,6 +147,8 @@ allocaBytes (I# size) action = IO $ \ s0 -> 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 -> @@ -152,6 +160,8 @@ allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> 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 @@ -163,14 +173,10 @@ allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> -- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like -- 'malloc'. -- -realloc :: Storable b => Ptr a -> IO (Ptr b) -realloc = doRealloc undefined +realloc :: forall a b . Storable b => Ptr a -> IO (Ptr b) +realloc ptr = failWhenNULL "realloc" (_realloc ptr size) where - doRealloc :: Storable b' => b' -> Ptr a' -> IO (Ptr b') - doRealloc dummy ptr = let - size = fromIntegral (sizeOf dummy) - in - failWhenNULL "realloc" (_realloc ptr size) + size = fromIntegral (sizeOf (undefined :: b)) -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' -- to the given size. The returned pointer may refer to an entirely diff --git a/libraries/base/Foreign/Marshal/Array.hs b/libraries/base/Foreign/Marshal/Array.hs index 5e103419b6..c0a9164b51 100644 --- a/libraries/base/Foreign/Marshal/Array.hs +++ b/libraries/base/Foreign/Marshal/Array.hs @@ -1,12 +1,12 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Array -- Copyright : (c) The FFI task force 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : ffi@haskell.org -- Stability : provisional -- Portability : portable @@ -82,11 +82,8 @@ import GHC.Base -- |Allocate storage for the given number of elements of a storable type -- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements). -- -mallocArray :: Storable a => Int -> IO (Ptr a) -mallocArray = doMalloc undefined - where - doMalloc :: Storable a' => a' -> Int -> IO (Ptr a') - doMalloc dummy size = mallocBytes (size * sizeOf dummy) +mallocArray :: forall a . Storable a => Int -> IO (Ptr a) +mallocArray size = mallocBytes (size * sizeOf (undefined :: a)) -- |Like 'mallocArray', but add an extra position to hold a special -- termination element. @@ -96,11 +93,8 @@ mallocArray0 size = mallocArray (size + 1) -- |Like 'mallocArray', but allocated memory is filled with bytes of value zero. -- -callocArray :: Storable a => Int -> IO (Ptr a) -callocArray = doCalloc undefined - where - doCalloc :: Storable a' => a' -> Int -> IO (Ptr a') - doCalloc dummy size = callocBytes (size * sizeOf dummy) +callocArray :: forall a . Storable a => Int -> IO (Ptr a) +callocArray size = callocBytes (size * sizeOf (undefined :: a)) -- |Like 'callocArray0', but allocated memory is filled with bytes of value -- zero. @@ -111,12 +105,9 @@ callocArray0 size = callocArray (size + 1) -- |Temporarily allocate space for the given number of elements -- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements). -- -allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b -allocaArray = doAlloca undefined - where - doAlloca :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b' - doAlloca dummy size = allocaBytesAligned (size * sizeOf dummy) - (alignment dummy) +allocaArray :: forall a b . Storable a => Int -> (Ptr a -> IO b) -> IO b +allocaArray size = allocaBytesAligned (size * sizeOf (undefined :: a)) + (alignment (undefined :: a)) -- |Like 'allocaArray', but add an extra position to hold a special -- termination element. @@ -129,11 +120,8 @@ allocaArray0 size = allocaArray (size + 1) -- |Adjust the size of an array -- -reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a) -reallocArray = doRealloc undefined - where - doRealloc :: Storable a' => a' -> Ptr a' -> Int -> IO (Ptr a') - doRealloc dummy ptr size = reallocBytes ptr (size * sizeOf dummy) +reallocArray :: forall a . Storable a => Ptr a -> Int -> IO (Ptr a) +reallocArray ptr size = reallocBytes ptr (size * sizeOf (undefined :: a)) -- |Adjust the size of an array including an extra position for the end marker. -- @@ -153,7 +141,7 @@ peekArray size ptr | size <= 0 = return [] where f 0 acc = do e <- peekElemOff ptr 0; return (e:acc) f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc) - + -- |Convert an array terminated by the given end marker into a Haskell list -- peekArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO [a] @@ -238,20 +226,14 @@ withArrayLen0 marker vals f = -- |Copy the given number of elements from the second array (source) into the -- first array (destination); the copied areas may /not/ overlap -- -copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () -copyArray = doCopy undefined - where - doCopy :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO () - doCopy dummy dest src size = copyBytes dest src (size * sizeOf dummy) +copyArray :: forall a . Storable a => Ptr a -> Ptr a -> Int -> IO () +copyArray dest src size = copyBytes dest src (size * sizeOf (undefined :: a)) -- |Copy the given number of elements from the second array (source) into the -- first array (destination); the copied areas /may/ overlap -- -moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () -moveArray = doMove undefined - where - doMove :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO () - doMove dummy dest src size = moveBytes dest src (size * sizeOf dummy) +moveArray :: forall a . Storable a => Ptr a -> Ptr a -> Int -> IO () +moveArray dest src size = moveBytes dest src (size * sizeOf (undefined :: a)) -- finding the length @@ -272,9 +254,5 @@ lengthArray0 marker ptr = loop 0 -- |Advance a pointer into an array by the given number of elements -- -advancePtr :: Storable a => Ptr a -> Int -> Ptr a -advancePtr = doAdvance undefined - where - doAdvance :: Storable a' => a' -> Ptr a' -> Int -> Ptr a' - doAdvance dummy ptr i = ptr `plusPtr` (i * sizeOf dummy) - +advancePtr :: forall a . Storable a => Ptr a -> Int -> Ptr a +advancePtr ptr i = ptr `plusPtr` (i * sizeOf (undefined :: a)) diff --git a/libraries/base/Foreign/Marshal/Pool.hs b/libraries/base/Foreign/Marshal/Pool.hs index 5d92f6fdd9..8d704c1a2d 100644 --- a/libraries/base/Foreign/Marshal/Pool.hs +++ b/libraries/base/Foreign/Marshal/Pool.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | @@ -102,11 +102,8 @@ withPool act = -- ATTENTION: cut-n-paste from Control.Exception below! -- allocated is determined by the 'sizeOf' method from the instance of -- 'Storable' for the appropriate type. -pooledMalloc :: Storable a => Pool -> IO (Ptr a) -pooledMalloc = pm undefined - where - pm :: Storable a' => a' -> Pool -> IO (Ptr a') - pm dummy pool = pooledMallocBytes pool (sizeOf dummy) +pooledMalloc :: forall a . Storable a => Pool -> IO (Ptr a) +pooledMalloc pool = pooledMallocBytes pool (sizeOf (undefined :: a)) -- | Allocate the given number of bytes of storage in the pool. @@ -120,11 +117,8 @@ pooledMallocBytes (Pool pool) size = do -- | Adjust the storage area for an element in the pool to the given size of -- the required type. -pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a) -pooledRealloc = pr undefined - where - pr :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a') - pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy) +pooledRealloc :: forall a . Storable a => Pool -> Ptr a -> IO (Ptr a) +pooledRealloc pool ptr = pooledReallocBytes pool ptr (sizeOf (undefined :: a)) -- | Adjust the storage area for an element in the pool to the given size. @@ -140,11 +134,9 @@ pooledReallocBytes (Pool pool) ptr size = do -- | Allocate storage for the given number of elements of a storable type in the -- pool. -pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a) -pooledMallocArray = pma undefined - where - pma :: Storable a' => a' -> Pool -> Int -> IO (Ptr a') - pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy) +pooledMallocArray :: forall a . Storable a => Pool -> Int -> IO (Ptr a) +pooledMallocArray pool size = + pooledMallocBytes pool (size * sizeOf (undefined :: a)) -- | Allocate storage for the given number of elements of a storable type in the -- pool, but leave room for an extra element to signal the end of the array. @@ -155,11 +147,9 @@ pooledMallocArray0 pool size = -- | Adjust the size of an array in the given pool. -pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a) -pooledReallocArray = pra undefined - where - pra :: Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a') - pra dummy pool ptr size = pooledReallocBytes pool ptr (size * sizeOf dummy) +pooledReallocArray :: forall a . Storable a => Pool -> Ptr a -> Int -> IO (Ptr a) +pooledReallocArray pool ptr size = + pooledReallocBytes pool ptr (size * sizeOf (undefined :: a)) -- | Adjust the size of an array with an end marker in the given pool. @@ -195,4 +185,3 @@ pooledNewArray0 pool marker vals = do ptr <- pooledMallocArray0 pool (length vals) pokeArray0 marker ptr vals return ptr - diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs index adfd602d9d..003d706f88 100644 --- a/libraries/base/GHC/Arr.hs +++ b/libraries/base/GHC/Arr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, RoleAnnotations #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -239,6 +240,15 @@ instance Ix Integer where inRange (m,n) i = m <= i && i <= n ---------------------------------------------------------------------- +-- | @since 4.8.0.0 +instance Ix Natural where + range (m,n) = [m..n] + inRange (m,n) i = m <= i && i <= n + unsafeIndex (m,_) i = fromIntegral (i-m) + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Natural" + +---------------------------------------------------------------------- -- | @since 2.01 instance Ix Bool where -- as derived {-# INLINE range #-} @@ -443,13 +453,13 @@ array :: Ix i -- of the array. These bounds are the lowest and -- highest indices in the array, in that order. -- For example, a one-origin vector of length - -- '10' has bounds '(1,10)', and a one-origin '10' - -- by '10' matrix has bounds '((1,1),(10,10))'. + -- @10@ has bounds @(1,10)@, and a one-origin @10@ + -- by @10@ matrix has bounds @((1,1),(10,10))@. -> [(i, e)] -- ^ a list of /associations/ of the form -- (/index/, /value/). Typically, this list will -- be expressed as a comprehension. An - -- association '(i, x)' defines the value of - -- the array at index 'i' to be 'x'. + -- association @(i, x)@ defines the value of + -- the array at index @i@ to be @x@. -> Array i e array (l,u) ies = let n = safeRangeSize (l,u) @@ -505,7 +515,11 @@ listArray (l,u) es = runST (ST $ \s1# -> -- | The value at the given index in an array. {-# INLINE (!) #-} (!) :: Ix i => Array i e -> i -> e -arr@(Array l u n _) ! i = unsafeAt arr $ safeIndex (l,u) n i +(!) arr@(Array l u n _) i = unsafeAt arr $ safeIndex (l,u) n i + +{-# INLINE (!#) #-} +(!#) :: Ix i => Array i e -> i -> (# e #) +(!#) arr@(Array l u n _) i = unsafeAt# arr $ safeIndex (l,u) n i {-# INLINE safeRangeSize #-} safeRangeSize :: Ix i => (i, i) -> Int @@ -550,6 +564,15 @@ unsafeAt :: Array i e -> Int -> e unsafeAt (Array _ _ _ arr#) (I# i#) = case indexArray# arr# i# of (# e #) -> e +-- | Look up an element in an array without forcing it +unsafeAt# :: Array i e -> Int -> (# e #) +unsafeAt# (Array _ _ _ arr#) (I# i#) = indexArray# arr# i# + +-- | A convenient version of unsafeAt# +unsafeAtA :: Applicative f + => Array i e -> Int -> f e +unsafeAtA ary i = case unsafeAt# ary i of (# e #) -> pure e + -- | The bounds with which an array was constructed. {-# INLINE bounds #-} bounds :: Array i e -> (i,i) @@ -569,7 +592,7 @@ indices (Array l u _ _) = range (l,u) {-# INLINE elems #-} elems :: Array i e -> [e] elems arr@(Array _ _ n _) = - [unsafeAt arr i | i <- [0 .. n - 1]] + [e | i <- [0 .. n - 1], e <- unsafeAtA arr i] -- | A right fold over the elements {-# INLINABLE foldrElems #-} @@ -577,7 +600,8 @@ foldrElems :: (a -> b -> b) -> b -> Array i a -> b foldrElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == n = b0 - | otherwise = f (unsafeAt arr i) (go (i+1)) + | (# e #) <- unsafeAt# arr i + = f e (go (i+1)) in go 0 -- | A left fold over the elements @@ -586,7 +610,8 @@ foldlElems :: (b -> a -> b) -> b -> Array i a -> b foldlElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == (-1) = b0 - | otherwise = f (go (i-1)) (unsafeAt arr i) + | (# e #) <- unsafeAt# arr i + = f (go (i-1)) e in go (n-1) -- | A strict right fold over the elements @@ -595,7 +620,8 @@ foldrElems' :: (a -> b -> b) -> b -> Array i a -> b foldrElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == (-1) = a - | otherwise = go (i-1) (f (unsafeAt arr i) $! a) + | (# e #) <- unsafeAt# arr i + = go (i-1) (f e $! a) in go (n-1) b0 -- | A strict left fold over the elements @@ -604,7 +630,8 @@ foldlElems' :: (b -> a -> b) -> b -> Array i a -> b foldlElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == n = a - | otherwise = go (i+1) (a `seq` f a (unsafeAt arr i)) + | (# e #) <- unsafeAt# arr i + = go (i+1) (a `seq` f a e) in go 0 b0 -- | A left fold over the elements with no starting value @@ -613,7 +640,8 @@ foldl1Elems :: (a -> a -> a) -> Array i a -> a foldl1Elems f = \ arr@(Array _ _ n _) -> let go i | i == 0 = unsafeAt arr 0 - | otherwise = f (go (i-1)) (unsafeAt arr i) + | (# e #) <- unsafeAt# arr i + = f (go (i-1)) e in if n == 0 then errorWithoutStackTrace "foldl1: empty Array" else go (n-1) @@ -623,7 +651,8 @@ foldr1Elems :: (a -> a -> a) -> Array i a -> a foldr1Elems f = \ arr@(Array _ _ n _) -> let go i | i == n-1 = unsafeAt arr i - | otherwise = f (unsafeAt arr i) (go (i + 1)) + | (# e #) <- unsafeAt# arr i + = f e (go (i + 1)) in if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0 @@ -631,11 +660,12 @@ foldr1Elems f = \ arr@(Array _ _ n _) -> {-# INLINE assocs #-} assocs :: Ix i => Array i e -> [(i, e)] assocs arr@(Array l u _ _) = - [(i, arr ! i) | i <- range (l,u)] + [(i, e) | i <- range (l,u), let !(# e #) = arr !# i] -- | The 'accumArray' function deals with repeated indices in the association -- list using an /accumulating function/ which combines the values of -- associations with the same index. +-- -- For example, given a list of values of some index type, @hist@ -- produces a histogram of the number of occurrences of each index within -- a specified range: @@ -643,10 +673,10 @@ assocs arr@(Array l u _ _) = -- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b -- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i] -- --- If the accumulating function is strict, then 'accumArray' is strict in --- the values, as well as the indices, in the association list. Thus, --- unlike ordinary arrays built with 'array', accumulated arrays should --- not in general be recursive. +-- @accumArray@ is strict in each result of applying the accumulating +-- function, although it is lazy in the initial value. Thus, unlike +-- arrays built with 'array', accumulated arrays should not in general +-- be recursive. {-# INLINE accumArray #-} accumArray :: Ix i => (e -> a -> e) -- ^ accumulating function @@ -667,7 +697,7 @@ unsafeAccumArray f initial b ies = unsafeAccumArray' f initial b (rangeSize b) i unsafeAccumArray' :: (e -> a -> e) -> e -> (i,i) -> Int -> [(Int, a)] -> Array i e unsafeAccumArray' f initial (l,u) n@(I# n#) ies = runST (ST $ \s1# -> case newArray# n# initial s1# of { (# s2#, marr# #) -> - foldr (adjust f marr#) (done l u n marr#) ies s2# }) + foldr (adjust' f marr#) (done l u n marr#) ies s2# }) {-# INLINE adjust #-} adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b @@ -678,6 +708,18 @@ adjust f marr# (I# i#, new) next case writeArray# marr# i# (f old new) s2# of s3# -> next s3# +{-# INLINE adjust' #-} +adjust' :: (e -> a -> e) + -> MutableArray# s e + -> (Int, a) + -> STRep s b -> STRep s b +adjust' f marr# (I# i#, new) next + = \s1# -> case readArray# marr# i# s1# of + (# s2#, old #) -> + let !combined = f old new + in next (writeArray# marr# i# combined s2#) + + -- | Constructs an array identical to the first argument except that it has -- been updated by the associations in the right argument. -- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then @@ -706,6 +748,8 @@ unsafeReplace arr ies = runST (do -- -- > accumArray f z b = accum f (array b [(i, z) | i <- range b]) -- +-- @accum@ is strict in all the results of applying the accumulation. +-- However, it is lazy in the initial values of the array. {-# INLINE accum #-} accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e accum f arr@(Array l u n _) ies = @@ -715,7 +759,7 @@ accum f arr@(Array l u n _) ies = unsafeAccum :: (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e unsafeAccum f arr ies = runST (do STArray l u n marr# <- thawSTArray arr - ST (foldr (adjust f marr#) (done l u n marr#) ies)) + ST (foldr (adjust' f marr#) (done l u n marr#) ies)) {-# INLINE [1] amap #-} -- See Note [amap] amap :: (a -> b) -> Array i a -> Array i b @@ -724,7 +768,8 @@ amap f arr@(Array l u n@(I# n#) _) = runST (ST $ \s1# -> (# s2#, marr# #) -> let go i s# | i == n = done l u n marr# s# - | otherwise = fill marr# (i, f (unsafeAt arr i)) (go (i+1)) s# + | (# e #) <- unsafeAt# arr i + = fill marr# (i, f e) (go (i+1)) s# in go 0 s2# ) {- Note [amap] diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index ffcd7ff2a0..1c927405ce 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -83,6 +83,9 @@ Other Prelude modules are much easier with fewer complex dependencies. , UnboxedTuples , ExistentialQuantification , RankNTypes + , KindSignatures + , PolyKinds + , DataKinds #-} -- -Wno-orphans is needed for things like: -- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 @@ -114,7 +117,8 @@ module GHC.Base module GHC.Types, module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, -- to avoid lots of people having to - module GHC.Err -- import it explicitly + module GHC.Err, -- import it explicitly + module GHC.Maybe ) where @@ -124,10 +128,20 @@ import GHC.CString import GHC.Magic import GHC.Prim import GHC.Err +import GHC.Maybe import {-# SOURCE #-} GHC.IO (failIO,mplusIO) -import GHC.Tuple () -- Note [Depend on GHC.Tuple] -import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Tuple () -- Note [Depend on GHC.Tuple] +import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Natural () -- Note [Depend on GHC.Natural] + +-- for 'class Semigroup' +import {-# SOURCE #-} GHC.Real (Integral) +import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault + , stimesMaybe + , stimesList + , stimesIdempotentMonoid + ) infixr 9 . infixr 5 ++ @@ -171,6 +185,10 @@ Similarly, tuple syntax (or ()) creates an implicit dependency on GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on GHC.Integer] --- to explain this to the build system. We make GHC.Base depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude. + +Note [Depend on GHC.Natural] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similar to GHC.Integer. -} #if 0 @@ -191,29 +209,53 @@ build = errorWithoutStackTrace "urk" foldr = errorWithoutStackTrace "urk" #endif --- | The 'Maybe' type encapsulates an optional value. A value of type --- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), --- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to --- deal with errors or exceptional cases without resorting to drastic --- measures such as 'error'. +infixr 6 <> + +-- | The class of semigroups (types with an associative binary operation). +-- +-- Instances should satisfy the associativity law: -- --- The 'Maybe' type is also a monad. It is a simple kind of error --- monad, where all errors are represented by 'Nothing'. A richer --- error monad can be built using the 'Data.Either.Either' type. +-- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ -- -data Maybe a = Nothing | Just a - deriving (Eq, Ord) +-- @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 = 'Data.Semigroup.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. @@ -221,28 +263,40 @@ data Maybe a = Nothing | Just a -- Some types can be viewed as a monoid in more than one way, -- 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 +-- of 'Monoid', e.g. 'Data.Semigroup.Sum' and 'Data.Semigroup.Product'. +-- +-- __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 +320,104 @@ needed to make foldr/build forms efficient are turned off, we'll get reasonably 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,26 +429,27 @@ instance Monoid a => Monoid (Maybe a) where -- @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: +{- | A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@ +lets you apply any function from @(a -> b)@ to turn an @f a@ into an @f b@, preserving the +structure of @f@. Furthermore @f@ needs to adhere to the following laws: -> fmap id == id -> fmap (f . g) == fmap f . fmap g - -The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' -satisfy these laws. +> fmap id == id +> fmap (f . g) == fmap f . fmap g -} class Functor f where @@ -379,7 +472,8 @@ class Functor f where -- the same as their default definitions: -- -- @('<*>') = 'liftA2' 'id'@ --- @'liftA2' f x y = f '<$>' x '<*>' y@ +-- +-- @'liftA2' f x y = f 'Prelude.<$>' x '<*>' y@ -- -- Further, any definition must satisfy the following: -- @@ -427,6 +521,8 @@ class Functor f where -- -- * @('<*>') = 'ap'@ -- +-- * @('*>') = ('>>')@ +-- -- (which implies that 'pure' and '<*>' satisfy the applicative functor laws). class Functor f => Applicative f where @@ -494,6 +590,33 @@ liftA3 f a b c = liftA2 f a b <*> c -- | The 'join' function is the conventional monad join operator. It -- is used to remove one level of monadic structure, projecting its -- bound argument into the outer level. +-- +-- ==== __Examples__ +-- +-- A common use of 'join' is to run an 'IO' computation returned from +-- an 'GHC.Conc.STM' transaction, since 'GHC.Conc.STM' transactions +-- can't perform 'IO' directly. Recall that +-- +-- @ +-- 'GHC.Conc.atomically' :: STM a -> IO a +-- @ +-- +-- is used to run 'GHC.Conc.STM' transactions atomically. So, by +-- specializing the types of 'GHC.Conc.atomically' and 'join' to +-- +-- @ +-- 'GHC.Conc.atomically' :: STM (IO b) -> IO (IO b) +-- 'join' :: IO (IO b) -> IO b +-- @ +-- +-- we can compose them as +-- +-- @ +-- 'join' . 'GHC.Conc.atomically' :: STM (IO b) -> IO b +-- @ +-- +-- to run an 'GHC.Conc.STM' transaction and the 'IO' action it +-- returns. join :: (Monad m) => m (m a) -> m a join x = x >>= id @@ -546,8 +669,8 @@ class Applicative m => Monad m where -- failure in a @do@ expression. -- -- As part of the MonadFail proposal (MFP), this function is moved - -- to its own class 'MonadFail' (see "Control.Monad.Fail" for more - -- details). The definition here will be removed in a future + -- to its own class 'Control.Monad.MonadFail' (see "Control.Monad.Fail" for + -- more details). The definition here will be removed in a future -- release. fail :: String -> m a fail s = errorWithoutStackTrace s @@ -629,8 +752,8 @@ liftM f m1 = do { x1 <- m1; return (f x1) } -- | 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 +794,11 @@ liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; {- | 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 +867,9 @@ infixl 3 <|> -- If defined, 'some' and 'many' should be the least solutions -- of the equations: -- --- * @some v = (:) '<$>' v '<*>' many v@ +-- * @'some' v = (:) 'Prelude.<$>' 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 +902,61 @@ instance Alternative Maybe where -- | 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 -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + ) + +-- | @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 @@ -1082,6 +1245,8 @@ maxInt = I# 0x7FFFFFFFFFFFFFFF# ---------------------------------------------- -- | Identity function. +-- +-- > id x = x id :: a -> a id x = x @@ -1089,8 +1254,8 @@ id x = x -- The compiler may rewrite it to @('assertError' line)@. -- | If the first argument evaluates to 'True', then the result is the --- second argument. Otherwise an 'AssertionFailed' exception is raised, --- containing a 'String' with the source file and line number of the +-- second argument. Otherwise an 'Control.Exception.AssertionFailed' exception +-- is raised, containing a 'String' with the source file and line number of the -- call to 'assert'. -- -- Assertions can normally be turned on or off with a compiler flag @@ -1115,7 +1280,8 @@ breakpointCond _ r = r 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] @@ -1130,6 +1296,9 @@ const x _ = x (.) 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 @@ -1138,20 +1307,24 @@ flip f x y = f y x -- 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@. +-- +-- Note that @($)@ is levity-polymorphic in its result type, so that +-- foo $ True where foo :: Bool -> Int# +-- is well-typed {-# INLINE ($) #-} -($) :: (a -> b) -> a -> b -f $ x = f x +($) :: forall r a (b :: TYPE r). (a -> b) -> a -> b +f $ x = f x -- | Strict (call-by-value) application operator. It takes a function and an -- argument, evaluates the argument to weak head normal form (WHNF), then calls -- the function with that value. -($!) :: (a -> b) -> a -> b -f $! x = let !vx = x in f vx -- see #2273 +($!) :: forall r a (b :: TYPE r). (a -> b) -> a -> b +f $! x = let !vx = x in f vx -- see #2273 -- | @'until' p f@ yields the result of applying @f@ until @p@ holds. until :: (a -> Bool) -> (a -> a) -> a -> a @@ -1213,7 +1386,7 @@ unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) unIO (IO a) = a {- | -Returns the 'tag' of a constructor application; this function is used +Returns the tag of a constructor application; this function is used by the deriving code for Eq, Ord and Enum. The primitive dataToTag# requires an evaluated constructor application diff --git a/libraries/base/GHC/Base.hs-boot b/libraries/base/GHC/Base.hs-boot new file mode 100644 index 0000000000..64e6365525 --- /dev/null +++ b/libraries/base/GHC/Base.hs-boot @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Base (Maybe, Semigroup, Monoid) where + +import GHC.Maybe (Maybe) +import GHC.Types () + +class Semigroup a +class Monoid a diff --git a/libraries/base/GHC/ByteOrder.hs b/libraries/base/GHC/ByteOrder.hs index eecc56c9ad..8a42e8df71 100644 --- a/libraries/base/GHC/ByteOrder.hs +++ b/libraries/base/GHC/ByteOrder.hs @@ -12,6 +12,7 @@ -- -- Target byte ordering. -- +-- @since 4.11.0.0 ----------------------------------------------------------------------------- module GHC.ByteOrder where @@ -20,7 +21,13 @@ module GHC.ByteOrder where 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) + deriving ( Eq -- ^ @since 4.11.0.0 + , Ord -- ^ @since 4.11.0.0 + , Bounded -- ^ @since 4.11.0.0 + , Enum -- ^ @since 4.11.0.0 + , Read -- ^ @since 4.11.0.0 + , Show -- ^ @since 4.11.0.0 + ) -- | The byte ordering of the target machine. targetByteOrder :: ByteOrder diff --git a/libraries/base/GHC/Event/Clock.hsc b/libraries/base/GHC/Clock.hsc index 7f98a03cd2..6339dc0a52 100644 --- a/libraries/base/GHC/Event/Clock.hsc +++ b/libraries/base/GHC/Clock.hsc @@ -1,7 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -module GHC.Event.Clock +module GHC.Clock ( getMonotonicTime , getMonotonicTimeNSec ) where @@ -11,11 +11,15 @@ 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 diff --git a/libraries/base/GHC/Conc.hs b/libraries/base/GHC/Conc.hs index 8c5c1536d9..15397422a5 100644 --- a/libraries/base/GHC/Conc.hs +++ b/libraries/base/GHC/Conc.hs @@ -74,8 +74,6 @@ module GHC.Conc , orElse , throwSTM , catchSTM - , alwaysSucceeds - , always , TVar(..) , newTVar , newTVarIO diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs index eb0bffe8b4..7b87adc7ea 100644 --- a/libraries/base/GHC/Conc/IO.hs +++ b/libraries/base/GHC/Conc/IO.hs @@ -85,7 +85,7 @@ ioManagerCapabilitiesChanged = return () -- | Block the current thread until data is available to read on the -- given file descriptor (GHC only). -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitRead', use 'closeFdWith'. threadWaitRead :: Fd -> IO () @@ -101,7 +101,7 @@ threadWaitRead fd -- | Block the current thread until data can be written to the -- given file descriptor (GHC only). -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitWrite', use 'closeFdWith'. threadWaitWrite :: Fd -> IO () @@ -188,8 +188,9 @@ threadDelay time case delay# time# s of { s' -> (# s', () #) }} --- | Set the value of returned TVar to True after a given number of --- microseconds. The caveats associated with threadDelay also apply. +-- | Switch the value of returned 'TVar' from initial value 'False' to 'True' +-- after a given number of microseconds. The caveats associated with +-- 'threadDelay' also apply. -- registerDelay :: Int -> IO (TVar Bool) registerDelay usecs diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index f9514d6681..6751de72a8 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -74,8 +74,6 @@ module GHC.Conc.Sync , orElse , throwSTM , catchSTM - , alwaysSucceeds - , always , TVar(..) , newTVar , newTVarIO @@ -105,6 +103,7 @@ import Data.Maybe import GHC.Base import {-# SOURCE #-} GHC.IO.Handle ( hFlush ) import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout ) +import GHC.Int import GHC.IO import GHC.IO.Encoding.UTF8 import GHC.IO.Exception @@ -194,18 +193,16 @@ instance Ord ThreadId where -- -- @since 4.8.0.0 setAllocationCounter :: Int64 -> IO () -setAllocationCounter i = do - ThreadId t <- myThreadId - rts_setThreadAllocationCounter t i +setAllocationCounter (I64# i) = IO $ \s -> + case setThreadAllocationCounter# i s of s' -> (# s', () #) -- | Return the current value of the allocation counter for the -- current thread. -- -- @since 4.8.0.0 getAllocationCounter :: IO Int64 -getAllocationCounter = do - ThreadId t <- myThreadId - rts_getThreadAllocationCounter t +getAllocationCounter = IO $ \s -> + case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #) -- | Enables the allocation counter to be treated as a limit for the -- current thread. When the allocation limit is enabled, if the @@ -242,16 +239,6 @@ disableAllocationLimit = do ThreadId t <- myThreadId rts_disableThreadAllocationLimit t --- We cannot do these operations safely on another thread, because on --- a 32-bit machine we cannot do atomic operations on a 64-bit value. --- Therefore, we only expose APIs that allow getting and setting the --- limit of the current thread. -foreign import ccall unsafe "rts_setThreadAllocationCounter" - rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO () - -foreign import ccall unsafe "rts_getThreadAllocationCounter" - rts_getThreadAllocationCounter :: ThreadId# -> IO Int64 - foreign import ccall unsafe "rts_enableThreadAllocationLimit" rts_enableThreadAllocationLimit :: ThreadId# -> IO () @@ -487,7 +474,7 @@ myThreadId = IO $ \s -> 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. @@ -556,9 +543,12 @@ data BlockReason -- ^currently in a foreign call | BlockedOnOther -- ^blocked on some other resource. Without @-threaded@, - -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ - -- they show up as 'BlockedOnMVar'. - deriving (Eq,Ord,Show) + -- I\/O and 'Control.Concurrent.threadDelay' show up as + -- 'BlockedOnOther', with @-threaded@ they show up as 'BlockedOnMVar'. + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | The current status of a thread data ThreadStatus @@ -570,7 +560,10 @@ data ThreadStatus -- ^the thread is blocked on some resource | ThreadDied -- ^the thread received an uncaught exception - deriving (Eq,Ord,Show) + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) threadStatus :: ThreadId -> IO ThreadStatus threadStatus (ThreadId t) = IO $ \s -> @@ -591,7 +584,7 @@ threadStatus (ThreadId t) = IO $ \s -> 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 +595,7 @@ threadCapability (ThreadId t) = IO $ \s -> 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 +707,45 @@ instance MonadPlus STM 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', +-- 'Control.Concurrent.STM.TChan.newTChanIO', +-- 'Control.Concurrent.STM.TChan.newBroadcastTChanIO', +-- 'Control.Concurrent.STM.TQueue.newTQueueIO', +-- 'Control.Concurrent.STM.TBQueue.newTBQueueIO', and +-- 'Control.Concurrent.STM.TMVar.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 +-- 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,30 +778,6 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler' 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. -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 --- 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. -alwaysSucceeds :: STM a -> STM () -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 :: STM Bool -> STM () -always i = alwaysSucceeds ( do v <- i - if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) ) - -- |Shared memory locations that support atomic memory transactions. data TVar a = TVar (TVar# RealWorld a) @@ -803,13 +785,13 @@ data TVar a = TVar (TVar# RealWorld a) 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 +800,7 @@ newTVarIO val = IO $ \s1# -> 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 +810,11 @@ newTVarIO val = IO $ \s1# -> 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 +824,8 @@ writeTVar (TVar tvar#) val = STM $ \s1# -> -- 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 +835,7 @@ withMVar m io = putMVar m a return b +-- | Modify the value of an 'MVar'. modifyMVar_ :: MVar a -> (a -> IO a) -> IO () modifyMVar_ m io = mask $ \restore -> do diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs index 6b87b06fe7..ed5e0452a0 100644 --- a/libraries/base/GHC/Conc/Windows.hs +++ b/libraries/base/GHC/Conc/Windows.hs @@ -131,7 +131,7 @@ waitForDelayEvent :: Int -> IO () waitForDelayEvent usecs = do m <- newEmptyMVar target <- calculateTarget usecs - atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ())) + _ <- atomicModifyIORef'_ pendingDelays (\xs -> Delay target m : xs) prodServiceThread takeMVar m @@ -140,7 +140,7 @@ waitForDelayEventSTM :: Int -> IO (TVar Bool) waitForDelayEventSTM usecs = do t <- atomically $ newTVar False target <- calculateTarget usecs - atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ())) + _ <- atomicModifyIORef'_ pendingDelays (\xs -> DelaySTM target t : xs) prodServiceThread return t @@ -219,10 +219,10 @@ foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore" prodServiceThread :: IO () prodServiceThread = do - -- NB. use atomicModifyIORef here, otherwise there are race + -- NB. use atomicSwapIORef here, otherwise there are race -- conditions in which prodding is left at True but the server is -- blocked in select(). - was_set <- atomicModifyIORef prodding $ \b -> (True,b) + was_set <- atomicSwapIORef prodding True when (not was_set) wakeupIOManager -- ---------------------------------------------------------------------------- @@ -239,7 +239,7 @@ service_loop :: HANDLE -- read end of pipe service_loop wakeup old_delays = do -- pick up new delay requests - new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) + new_delays <- atomicSwapIORef pendingDelays [] let delays = foldr insertDelay old_delays new_delays now <- getMonotonicUSec @@ -262,8 +262,7 @@ service_loop wakeup old_delays = do service_cont :: HANDLE -> [DelayReq] -> IO () service_cont wakeup delays = do - r <- atomicModifyIORef prodding (\_ -> (False,False)) - r `seq` return () -- avoid space leak + _ <- atomicSwapIORef prodding False service_loop wakeup delays -- must agree with rts/win32/ThrIOManager.c @@ -278,7 +277,12 @@ data ConsoleEvent -- these are sent to Services only. | Logoff | Shutdown - deriving (Eq, Ord, Enum, Show, Read) + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Enum -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + ) start_console_handler :: Word32 -> IO () start_console_handler r = diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs index feb45854d2..af74f7c984 100644 --- a/libraries/base/GHC/Enum.hs +++ b/libraries/base/GHC/Enum.hs @@ -92,13 +92,51 @@ class Enum a where -- applied to a value that is too large to fit in an 'Int'. fromEnum :: a -> Int - -- | Used in Haskell's translation of @[n..]@. + -- | Used in Haskell's translation of @[n..]@ with @[n..] = enumFrom n@, + -- a possible implementation being @enumFrom n = n : enumFrom (succ n)@. + -- For example: + -- + -- * @enumFrom 4 :: [Integer] = [4,5,6,7,...]@ + -- * @enumFrom 6 :: [Int] = [6,7,8,9,...,maxBound :: Int]@ enumFrom :: a -> [a] - -- | Used in Haskell's translation of @[n,n'..]@. + -- | Used in Haskell's translation of @[n,n'..]@ + -- with @[n,n'..] = enumFromThen n n'@, a possible implementation being + -- @enumFromThen n n' = n : n' : worker (f x) (f x n')@, + -- @worker s v = v : worker s (s v)@, @x = fromEnum n' - fromEnum n@ and + -- @f n y + -- | n > 0 = f (n - 1) (succ y) + -- | n < 0 = f (n + 1) (pred y) + -- | otherwise = y@ + -- For example: + -- + -- * @enumFromThen 4 6 :: [Integer] = [4,6,8,10...]@ + -- * @enumFromThen 6 2 :: [Int] = [6,2,-2,-6,...,minBound :: Int]@ enumFromThen :: a -> a -> [a] - -- | Used in Haskell's translation of @[n..m]@. + -- | Used in Haskell's translation of @[n..m]@ with + -- @[n..m] = enumFromTo n m@, a possible implementation being + -- @enumFromTo n m + -- | n <= m = n : enumFromTo (succ n) m + -- | otherwise = []@. + -- For example: + -- + -- * @enumFromTo 6 10 :: [Int] = [6,7,8,9,10]@ + -- * @enumFromTo 42 1 :: [Integer] = []@ enumFromTo :: a -> a -> [a] - -- | Used in Haskell's translation of @[n,n'..m]@. + -- | Used in Haskell's translation of @[n,n'..m]@ with + -- @[n,n'..m] = enumFromThenTo n n' m@, a possible implementation + -- being @enumFromThenTo n n' m = worker (f x) (c x) n m@, + -- @x = fromEnum n' - fromEnum n@, @c x = bool (>=) (<=) (x > 0)@ + -- @f n y + -- | n > 0 = f (n - 1) (succ y) + -- | n < 0 = f (n + 1) (pred y) + -- | otherwise = y@ and + -- @worker s c v m + -- | c v m = v : worker s c (s v) m + -- | otherwise = []@ + -- For example: + -- + -- * @enumFromThenTo 4 2 -6 :: [Integer] = [4,2,0,-2,-4,-6]@ + -- * @enumFromThenTo 6 8 2 :: [Int] = []@ enumFromThenTo :: a -> a -> a -> [a] succ = toEnum . (+ 1) . fromEnum @@ -877,6 +915,79 @@ dn_list x0 delta lim = go (x0 :: Integer) go x | x < lim = [] | otherwise = x : go (x+delta) +------------------------------------------------------------------------ +-- Natural +------------------------------------------------------------------------ + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Enum Natural where + succ n = n `plusNatural` wordToNaturalBase 1## + pred n = n `minusNatural` wordToNaturalBase 1## + + toEnum = intToNatural + + fromEnum (NatS# w) + | i >= 0 = i + | otherwise = errorWithoutStackTrace "fromEnum: out of Int range" + where + i = I# (word2Int# w) + fromEnum n = fromEnum (naturalToInteger n) + + enumFrom x = enumDeltaNatural x (wordToNaturalBase 1##) + enumFromThen x y + | x <= y = enumDeltaNatural x (y-x) + | otherwise = enumNegDeltaToNatural x (x-y) (wordToNaturalBase 0##) + + enumFromTo x lim = enumDeltaToNatural x (wordToNaturalBase 1##) lim + enumFromThenTo x y lim + | x <= y = enumDeltaToNatural x (y-x) lim + | otherwise = enumNegDeltaToNatural x (x-y) lim + +-- Helpers for 'Enum Natural'; TODO: optimise & make fusion work + +enumDeltaNatural :: Natural -> Natural -> [Natural] +enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d + +enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumDeltaToNatural x0 delta lim = go x0 + where + go x | x > lim = [] + | otherwise = x : go (x+delta) + +enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumNegDeltaToNatural x0 ndelta lim = go x0 + where + go x | x < lim = [] + | x >= ndelta = x : go (x-ndelta) + | otherwise = [x] + +#else + +-- | @since 4.8.0.0 +instance Enum Natural where + pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" + pred (Natural n) = Natural (pred n) + {-# INLINE pred #-} + succ (Natural n) = Natural (succ n) + {-# INLINE succ #-} + fromEnum (Natural n) = fromEnum n + {-# INLINE fromEnum #-} + toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" + | otherwise = Natural (toEnum n) + {-# INLINE toEnum #-} + + enumFrom = coerce (enumFrom :: Integer -> [Integer]) + enumFromThen x y + | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y + | otherwise = enumFromThenTo x y (wordToNaturalBase 0##) + + enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) + enumFromThenTo + = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) + +#endif + -- Instances from GHC.Types -- | @since 4.10.0.0 diff --git a/libraries/base/GHC/Environment.hs b/libraries/base/GHC/Environment.hs index a077f6f8c4..4db0837664 100644 --- a/libraries/base/GHC/Environment.hs +++ b/libraries/base/GHC/Environment.hs @@ -8,11 +8,10 @@ import Foreign import Foreign.C import GHC.Base import GHC.Real ( fromIntegral ) +import GHC.IO.Encoding +import qualified GHC.Foreign as GHC #if defined(mingw32_HOST_OS) -import GHC.IO (finally) -import GHC.Windows - # if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH) @@ -20,47 +19,21 @@ import GHC.Windows # 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 --- to @argv@ in other languages. It returns a list of the program's --- command line arguments, starting with the program name, and --- including those normally eaten by the RTS (+RTS ... -RTS). +-- | Computation 'getFullArgs' is the "raw" version of +-- 'System.Environment.getArgs', similar to @argv@ in other languages. It +-- returns a list of the program's command line arguments, starting with the +-- program name, and including those normally eaten by the RTS (+RTS ... -RTS). getFullArgs :: IO [String] -#if defined(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 diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index 4231fcefa5..095ccd8dd7 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} -{-# LANGUAGE RankNTypes, TypeInType #-} +{-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -27,10 +27,14 @@ import GHC.CString () import GHC.Types (Char, RuntimeRep) import GHC.Stack.Types import GHC.Prim -import GHC.Integer () -- Make sure Integer is compiled first - -- because GHC depends on it in a wired-in way - -- so the build system doesn't see the dependency -import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) +import GHC.Integer () -- Make sure Integer and Natural are compiled first +import GHC.Natural () -- because GHC depends on it in a wired-in way + -- so the build system doesn't see the dependency. + -- See Note [Depend on GHC.Integer] and + -- Note [Depend on GHC.Natural] in GHC.Base. +import {-# SOURCE #-} GHC.Exception + ( errorCallWithCallStackException + , errorCallException ) -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). @@ -46,10 +50,7 @@ error s = raise# (errorCallWithCallStackException s ?callStack) -- @since 4.9.0.0 errorWithoutStackTrace :: forall (r :: RuntimeRep). forall (a :: TYPE r). [Char] -> a -errorWithoutStackTrace s = - -- we don't have withFrozenCallStack yet, so we just inline the definition - let ?callStack = freezeCallStack emptyCallStack - in error s +errorWithoutStackTrace s = raise# (errorCallException s) -- Note [Errors in base] diff --git a/libraries/base/GHC/Event/Control.hs b/libraries/base/GHC/Event/Control.hs index 9e3940ad19..779d60d5d7 100644 --- a/libraries/base/GHC/Event/Control.hs +++ b/libraries/base/GHC/Event/Control.hs @@ -57,7 +57,9 @@ data ControlMessage = CMsgWakeup | CMsgDie | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Signal - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | The structure used to tell the IO manager thread what to do. data Control = W { @@ -124,7 +126,7 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do -- file after it has been closed. closeControl :: Control -> IO () closeControl w = do - atomicModifyIORef (controlIsDead w) (\_ -> (True, ())) + _ <- atomicSwapIORef (controlIsDead w) True _ <- c_close . fromIntegral . controlReadFd $ w _ <- c_close . fromIntegral . controlWriteFd $ w when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1) diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc index 32bfc3913b..14324bc43d 100644 --- a/libraries/base/GHC/Event/EPoll.hsc +++ b/libraries/base/GHC/Event/EPoll.hsc @@ -161,7 +161,12 @@ newtype ControlOp = ControlOp CInt newtype EventType = EventType { unEventType :: Word32 - } deriving (Show, Eq, Num, Bits, FiniteBits) + } deriving ( Show -- ^ @since 4.4.0.0 + , Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Bits -- ^ @since 4.4.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + ) #{enum EventType, EventType , epollIn = EPOLLIN diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs index 9b8230c032..5778c6f3fe 100644 --- a/libraries/base/GHC/Event/Internal.hs +++ b/libraries/base/GHC/Event/Internal.hs @@ -36,10 +36,11 @@ 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 - deriving (Eq) + deriving Eq -- ^ @since 4.4.0.0 evtNothing :: Event evtNothing = Event 0 @@ -63,7 +64,7 @@ evtClose = Event 4 eventIs :: Event -> Event -> Bool eventIs (Event a) (Event b) = a .&. b /= 0 --- | @since 4.3.1.0 +-- | @since 4.4.0.0 instance Show Event where show e = '[' : (intercalate "," . filter (not . null) $ [evtRead `so` "evtRead", @@ -72,10 +73,14 @@ instance Show Event where where ev `so` disp | e `eventIs` ev = disp | otherwise = "" --- | @since 4.3.1.0 +-- | @since 4.10.0.0 +instance Semigroup Event where + (<>) = evtCombine + stimes = stimesMonoid + +-- | @since 4.4.0.0 instance Monoid Event where mempty = evtNothing - mappend = evtCombine mconcat = evtConcat evtCombine :: Event -> Event -> Event @@ -92,7 +97,9 @@ evtConcat = foldl' evtCombine evtNothing data Lifetime = OneShot -- ^ the registration will be active for only one -- event | MultiShot -- ^ the registration will trigger multiple times - deriving (Show, Eq) + deriving ( Show -- ^ @since 4.8.1.0 + , Eq -- ^ @since 4.8.1.0 + ) -- | The longer of two lifetimes. elSupremum :: Lifetime -> Lifetime -> Lifetime @@ -100,24 +107,33 @@ elSupremum OneShot OneShot = OneShot 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 -- -- Here we encode the event in the bottom three bits and the lifetime -- in the fourth bit. newtype EventLifetime = EL Int - deriving (Show, Eq) + deriving ( Show -- ^ @since 4.8.0.0 + , Eq -- ^ @since 4.8.0.0 + ) + +-- | @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) @@ -137,7 +153,7 @@ elEvent (EL x) = Event (x .&. 0x7) -- | A type alias for timeouts, specified in nanoseconds. data Timeout = Timeout {-# UNPACK #-} !Word64 | Forever - deriving (Show) + deriving Show -- ^ @since 4.4.0.0 -- | Event notification backend. data Backend = forall a. Backend { @@ -200,7 +216,7 @@ delete :: Backend -> IO () delete (Backend bState _ _ _ bDelete) = bDelete bState {-# INLINE delete #-} --- | Throw an 'IOError' corresponding to the current value of +-- | Throw an 'Prelude.IOError' corresponding to the current value of -- 'getErrno' if the result value of the 'IO' action is -1 and -- 'getErrno' is not 'eINTR'. If the result value is -1 and -- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result diff --git a/libraries/base/GHC/Event/KQueue.hsc b/libraries/base/GHC/Event/KQueue.hsc index e9c8419ea7..49cf82db14 100644 --- a/libraries/base/GHC/Event/KQueue.hsc +++ b/libraries/base/GHC/Event/KQueue.hsc @@ -28,11 +28,13 @@ available = False 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 @@ -85,23 +87,20 @@ delete kq = do 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 - -toFilter :: E.Event -> Filter -toFilter evt - | evt `E.eventIs` E.evtRead = filterRead - | otherwise = filterWrite +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 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 @@ -125,7 +124,9 @@ poll kq mtimeout f = do newtype KQueueFd = KQueueFd { fromKQueueFd :: CInt - } deriving (Eq, Show) + } deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) data Event = KEvent { ident :: {-# UNPACK #-} !CUIntPtr @@ -138,10 +139,10 @@ data Event = KEvent { , data_ :: {-# UNPACK #-} !CIntPtr #endif , udata :: {-# UNPACK #-} !(Ptr ()) - } deriving Show + } deriving Show -- ^ @since 4.4.0.0 -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 @@ -168,7 +169,10 @@ instance Storable Event where #{poke struct kevent, udata} ptr (udata ev) newtype FFlag = FFlag Word32 - deriving (Eq, Show, Storable) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) #{enum FFlag, FFlag , noteEOF = NOTE_EOF @@ -179,7 +183,13 @@ newtype Flag = Flag Word32 #else newtype Flag = Flag Word16 #endif - deriving (Bits, FiniteBits, Eq, Num, Show, Storable) + deriving ( Bits -- ^ @since 4.7.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + , Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) #{enum Flag, Flag , flagAdd = EV_ADD @@ -192,7 +202,11 @@ newtype Filter = Filter Int32 #else newtype Filter = Filter Int16 #endif - deriving (Bits, FiniteBits, Eq, Num, Show, Storable) + deriving ( Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) filterRead :: Filter filterRead = Filter (#const EVFILT_READ) @@ -222,11 +236,11 @@ instance Storable TimeSpec where 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 +269,6 @@ kevent safe k chs chlen evs evlen ts | 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 diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs index 013850b5d2..3ee9116812 100644 --- a/libraries/base/GHC/Event/Manager.hs +++ b/libraries/base/GHC/Event/Manager.hs @@ -110,7 +110,9 @@ data FdData = FdData { data FdKey = FdKey { keyFd :: {-# UNPACK #-} !Fd , keyUnique :: {-# UNPACK #-} !Unique - } deriving (Eq, Show) + } deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | Callback invoked on I/O events. type IOCallback = FdKey -> Event -> IO () @@ -120,7 +122,9 @@ data State = Created | Dying | Releasing | Finished - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | The event manager state. data EventManager = EventManager diff --git a/libraries/base/GHC/Event/PSQ.hs b/libraries/base/GHC/Event/PSQ.hs index 976ffe16b3..6e13839491 100644 --- a/libraries/base/GHC/Event/PSQ.hs +++ b/libraries/base/GHC/Event/PSQ.hs @@ -28,7 +28,7 @@ module GHC.Event.PSQ , singleton -- * Insertion - , insert + , unsafeInsertNew -- * Delete/Update , delete @@ -36,7 +36,6 @@ module GHC.Event.PSQ -- * Conversion , toList - , fromList -- * Min , findMin @@ -58,7 +57,7 @@ import GHC.Types (Int) {- -- Use macros to define strictness of functions. --- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter. +-- 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 @@ -213,14 +212,7 @@ singleton = Tip -- Insertion ------------------------------------------------------------------------------ --- | /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) - --- | Internal function to insert a key that is *not* present in the priority --- queue. +-- | /O(min(n,W))/ Insert a new key that is *not* present in the priority queue. {-# INLINABLE unsafeInsertNew #-} unsafeInsertNew :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v unsafeInsertNew k p x = go @@ -340,13 +332,6 @@ binShrinkR k p x m l r = Bin k p x m l r -- Lists ------------------------------------------------------------------------------ --- | /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 - -- | /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] diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc index 74525c6b40..1dafd601ec 100644 --- a/libraries/base/GHC/Event/Poll.hsc +++ b/libraries/base/GHC/Event/Poll.hsc @@ -151,10 +151,16 @@ data PollFd = PollFd { pfdFd :: {-# UNPACK #-} !Fd , pfdEvents :: {-# UNPACK #-} !Event , pfdRevents :: {-# UNPACK #-} !Event - } deriving (Show) + } deriving Show -- ^ @since 4.4.0.0 newtype Event = Event CShort - deriving (Eq, Show, Num, Storable, Bits, FiniteBits) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + , Bits -- ^ @since 4.4.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + ) -- We have to duplicate the whole enum like this in order for the -- hsc2hs cross-compilation mode to work diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index d4b679206a..a9d5410d9c 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -72,7 +72,7 @@ registerDelay usecs = do -- | Block the current thread until data is available to read from the -- given file descriptor. -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitRead', use 'closeFdWith'. threadWaitRead :: Fd -> IO () @@ -82,7 +82,7 @@ threadWaitRead = threadWait evtRead -- | Block the current thread until the given file descriptor can -- accept data to write. -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitWrite', use 'closeFdWith'. threadWaitWrite :: Fd -> IO () @@ -145,7 +145,7 @@ threadWaitSTM evt fd = mask_ $ do -- The second element of the return value pair is an IO action that can be used -- to deregister interest in the file descriptor. -- --- The STM action will throw an 'IOError' if the file descriptor was closed +-- The STM action will throw an 'Prelude.IOError' if the file descriptor was closed -- while the STM action is being executed. To safely close a file descriptor -- that has been used with 'threadWaitReadSTM', use 'closeFdWith'. threadWaitReadSTM :: Fd -> IO (STM (), IO ()) @@ -157,7 +157,7 @@ threadWaitReadSTM = threadWaitSTM evtRead -- The second element of the return value pair is an IO action that can be used to deregister -- interest in the file descriptor. -- --- The STM action will throw an 'IOError' if the file descriptor was closed +-- The STM action will throw an 'Prelude.IOError' if the file descriptor was closed -- while the STM action is being executed. To safely close a file descriptor -- that has been used with 'threadWaitWriteSTM', use 'closeFdWith'. threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index f3dbb21686..946f2333bf 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -43,11 +43,12 @@ import Data.Foldable (sequence_) import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, writeIORef) import GHC.Base +import GHC.Clock (getMonotonicTimeNSec) import GHC.Conc.Signal (runHandlers) +import GHC.Enum (maxBound) import GHC.Num (Num(..)) -import GHC.Real (fromIntegral) +import GHC.Real (quot, fromIntegral) import GHC.Show (Show(..)) -import GHC.Event.Clock (getMonotonicTimeNSec) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..)) import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) @@ -67,7 +68,7 @@ import qualified GHC.Event.Poll as Poll -- | A timeout registration cookie. newtype TimeoutKey = TK Unique - deriving (Eq) + deriving Eq -- ^ @since 4.7.0.0 -- | Callback invoked on timeout events. type TimeoutCallback = IO () @@ -76,7 +77,9 @@ data State = Created | Running | Dying | Finished - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + ) -- | A priority search queue, with timeouts as priorities. type TimeoutQueue = Q.PSQ TimeoutCallback @@ -206,6 +209,18 @@ wakeManager mgr = sendWakeup (emControl mgr) ------------------------------------------------------------------------ -- Registering interest in timeout events +expirationTime :: Int -> IO Q.Prio +expirationTime us = do + now <- getMonotonicTimeNSec + let expTime + -- Currently we treat overflows by clamping to maxBound. If humanity + -- still exists in 2500 CE we will ned to be a bit more careful here. + -- See #15158. + | (maxBound - now) `quot` 1000 < fromIntegral us = maxBound + | otherwise = now + ns + where ns = 1000 * fromIntegral us + return expTime + -- | Register a timeout in the given number of microseconds. The -- returned 'TimeoutKey' can be used to later unregister or update the -- timeout. The timeout is automatically unregistered after the given @@ -215,10 +230,11 @@ registerTimeout mgr us cb = do !key <- newUnique (emUniqueSource mgr) if us <= 0 then cb else do - now <- getMonotonicTimeNSec - let expTime = fromIntegral us * 1000 + now + expTime <- expirationTime us - editTimeouts mgr (Q.insert key expTime cb) + -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It + -- doesn't because we just generated it from a unique supply. + editTimeouts mgr (Q.unsafeInsertNew key expTime cb) return $ TK key -- | Unregister an active timeout. @@ -230,9 +246,7 @@ unregisterTimeout mgr (TK key) = do -- microseconds. updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO () updateTimeout mgr (TK key) us = do - now <- getMonotonicTimeNSec - let expTime = fromIntegral us * 1000 + now - + expTime <- expirationTime us editTimeouts mgr (Q.adjust (const expTime) key) editTimeouts :: TimerManager -> TimeoutEdit -> IO () diff --git a/libraries/base/GHC/Event/Unique.hs b/libraries/base/GHC/Event/Unique.hs index 0363af2068..1339bd97e7 100644 --- a/libraries/base/GHC/Event/Unique.hs +++ b/libraries/base/GHC/Event/Unique.hs @@ -19,7 +19,10 @@ import GHC.Show(Show(..)) data UniqueSource = US (MutableByteArray# RealWorld) newtype Unique = Unique { asInt :: Int } - deriving (Eq, Ord, Num) + deriving ( Eq -- ^ @since 4.4.0.0 + , Ord -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + ) -- | @since 4.3.1.0 instance Show Unique where diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index 6a77e6e50b..3b32e230e8 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -5,6 +5,7 @@ , RecordWildCards , PatternSynonyms #-} +{-# LANGUAGE TypeInType #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -22,155 +23,38 @@ ----------------------------------------------------------------------------- module GHC.Exception - ( Exception(..) -- Class + ( module GHC.Exception.Type , throw - , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..) - , divZeroException, overflowException, ratioZeroDenomException - , underflowException - , errorCallException, errorCallWithCallStackException + , ErrorCall(..,ErrorCall) + , errorCallException + , errorCallWithCallStackException -- re-export CallStack and SrcLoc from GHC.Types , CallStack, fromCallSiteList, getCallStack, prettyCallStack , prettyCallStackLines, showCCSStack , SrcLoc(..), prettySrcLoc ) where -import Data.Maybe -import Data.Typeable (Typeable, cast) - -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show import GHC.Stack.Types import GHC.OldList +import GHC.Prim import GHC.IO.Unsafe import {-# SOURCE #-} GHC.Stack.CCS - -{- | -The @SomeException@ type is the root of the exception type hierarchy. -When an exception of type @e@ is thrown, behind the scenes it is -encapsulated in a @SomeException@. --} -data SomeException = forall e . Exception e => SomeException e - --- | @since 3.0 -instance Show SomeException where - showsPrec p (SomeException e) = showsPrec p e - -{- | -Any type that you wish to throw or catch as an exception must be an -instance of the @Exception@ class. The simplest case is a new exception -type directly below the root: - -> data MyException = ThisException | ThatException -> deriving Show -> -> instance Exception MyException - -The default method definitions in the @Exception@ class do what we need -in this case. You can now throw and catch @ThisException@ and -@ThatException@ as exceptions: - -@ -*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) -Caught ThisException -@ - -In more complicated examples, you may wish to define a whole hierarchy -of exceptions: - -> --------------------------------------------------------------------- -> -- Make the root exception type for all the exceptions in a compiler -> -> data SomeCompilerException = forall e . Exception e => SomeCompilerException e -> -> instance Show SomeCompilerException where -> show (SomeCompilerException e) = show e -> -> instance Exception SomeCompilerException -> -> compilerExceptionToException :: Exception e => e -> SomeException -> compilerExceptionToException = toException . SomeCompilerException -> -> compilerExceptionFromException :: Exception e => SomeException -> Maybe e -> compilerExceptionFromException x = do -> SomeCompilerException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make a subhierarchy for exceptions in the frontend of the compiler -> -> data SomeFrontendException = forall e . Exception e => SomeFrontendException e -> -> instance Show SomeFrontendException where -> show (SomeFrontendException e) = show e -> -> instance Exception SomeFrontendException where -> toException = compilerExceptionToException -> fromException = compilerExceptionFromException -> -> frontendExceptionToException :: Exception e => e -> SomeException -> frontendExceptionToException = toException . SomeFrontendException -> -> frontendExceptionFromException :: Exception e => SomeException -> Maybe e -> frontendExceptionFromException x = do -> SomeFrontendException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make an exception type for a particular frontend compiler exception -> -> data MismatchedParentheses = MismatchedParentheses -> deriving Show -> -> instance Exception MismatchedParentheses where -> toException = frontendExceptionToException -> fromException = frontendExceptionFromException - -We can now catch a @MismatchedParentheses@ exception as -@MismatchedParentheses@, @SomeFrontendException@ or -@SomeCompilerException@, but not other types, e.g. @IOException@: - -@ -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: IOException)) -*** Exception: MismatchedParentheses -@ - --} -class (Typeable e, Show e) => Exception e where - toException :: e -> SomeException - fromException :: SomeException -> Maybe e - - toException = SomeException - fromException (SomeException e) = cast e - - -- | Render this exception value in a human-friendly manner. - -- - -- Default implementation: @'show'@. - -- - -- @since 4.8.0.0 - displayException :: e -> String - displayException = show - --- | @since 3.0 -instance Exception SomeException where - toException se = se - fromException = Just - displayException (SomeException e) = displayException e +import GHC.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely -- functional code, but may only be caught within the 'IO' monad. -throw :: Exception e => e -> a +throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e. + Exception e => e -> a throw e = raise# (toException e) --- |This is thrown when the user calls 'error'. The @String@ is the --- argument given to 'error'. +-- | This is thrown when the user calls 'error'. The first @String@ is the +-- argument given to 'error', second @String@ is the location. data ErrorCall = ErrorCallWithLocation String String - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + ) pattern ErrorCall :: String -> ErrorCall pattern ErrorCall err <- ErrorCallWithLocation err _ where @@ -184,7 +68,8 @@ instance Exception ErrorCall -- | @since 4.0.0.0 instance Show ErrorCall where showsPrec _ (ErrorCallWithLocation err "") = showString err - showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc) + showsPrec _ (ErrorCallWithLocation err loc) = + showString err . showChar '\n' . showString loc errorCallException :: String -> SomeException errorCallException s = toException (ErrorCall s) @@ -230,31 +115,3 @@ prettyCallStackLines cs = case getCallStack cs of : map ((" " ++) . prettyCallSite) stk where prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc - --- |Arithmetic exceptions. -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - | RatioZeroDenominator -- ^ @since 4.6.0.0 - deriving (Eq, Ord) - -divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException -divZeroException = toException DivideByZero -overflowException = toException Overflow -ratioZeroDenomException = toException RatioZeroDenominator -underflowException = toException Underflow - --- | @since 4.0.0.0 -instance Exception ArithException - --- | @since 4.0.0.0 -instance Show ArithException where - showsPrec _ Overflow = showString "arithmetic overflow" - showsPrec _ Underflow = showString "arithmetic underflow" - showsPrec _ LossOfPrecision = showString "loss of precision" - showsPrec _ DivideByZero = showString "divide by zero" - showsPrec _ Denormal = showString "denormal" - showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot index d539dd4962..4507b20790 100644 --- a/libraries/base/GHC/Exception.hs-boot +++ b/libraries/base/GHC/Exception.hs-boot @@ -24,17 +24,15 @@ well-behaved, non-bottom values. The clients use 'raise#' to get a visibly-bottom value. -} -module GHC.Exception ( SomeException, errorCallException, - errorCallWithCallStackException, - divZeroException, overflowException, ratioZeroDenomException, - underflowException - ) where +module GHC.Exception + ( module GHC.Exception.Type + , errorCallException + , errorCallWithCallStackException + ) where + +import {-# SOURCE #-} GHC.Exception.Type import GHC.Types ( Char ) import GHC.Stack.Types ( CallStack ) -data SomeException -divZeroException, overflowException, ratioZeroDenomException :: SomeException -underflowException :: SomeException - errorCallException :: [Char] -> SomeException errorCallWithCallStackException :: [Char] -> CallStack -> SomeException diff --git a/libraries/base/GHC/Exception/Type.hs b/libraries/base/GHC/Exception/Type.hs new file mode 100644 index 0000000000..6c3eb49ff9 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , RecordWildCards + , PatternSynonyms + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exception.Type +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- +----------------------------------------------------------------------------- + +module GHC.Exception.Type + ( Exception(..) -- Class + , SomeException(..), ArithException(..) + , divZeroException, overflowException, ratioZeroDenomException + , underflowException + ) where + +import Data.Maybe +import Data.Typeable (Typeable, cast) + -- loop: Data.Typeable -> GHC.Err -> GHC.Exception +import GHC.Base +import GHC.Show + +{- | +The @SomeException@ type is the root of the exception type hierarchy. +When an exception of type @e@ is thrown, behind the scenes it is +encapsulated in a @SomeException@. +-} +data SomeException = forall e . Exception e => SomeException e + +-- | @since 3.0 +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +{- | +Any type that you wish to throw or catch as an exception must be an +instance of the @Exception@ class. The simplest case is a new exception +type directly below the root: + +> data MyException = ThisException | ThatException +> deriving Show +> +> instance Exception MyException + +The default method definitions in the @Exception@ class do what we need +in this case. You can now throw and catch @ThisException@ and +@ThatException@ as exceptions: + +@ +*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +Caught ThisException +@ + +In more complicated examples, you may wish to define a whole hierarchy +of exceptions: + +> --------------------------------------------------------------------- +> -- Make the root exception type for all the exceptions in a compiler +> +> data SomeCompilerException = forall e . Exception e => SomeCompilerException e +> +> instance Show SomeCompilerException where +> show (SomeCompilerException e) = show e +> +> instance Exception SomeCompilerException +> +> compilerExceptionToException :: Exception e => e -> SomeException +> compilerExceptionToException = toException . SomeCompilerException +> +> compilerExceptionFromException :: Exception e => SomeException -> Maybe e +> compilerExceptionFromException x = do +> SomeCompilerException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make a subhierarchy for exceptions in the frontend of the compiler +> +> data SomeFrontendException = forall e . Exception e => SomeFrontendException e +> +> instance Show SomeFrontendException where +> show (SomeFrontendException e) = show e +> +> instance Exception SomeFrontendException where +> toException = compilerExceptionToException +> fromException = compilerExceptionFromException +> +> frontendExceptionToException :: Exception e => e -> SomeException +> frontendExceptionToException = toException . SomeFrontendException +> +> frontendExceptionFromException :: Exception e => SomeException -> Maybe e +> frontendExceptionFromException x = do +> SomeFrontendException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make an exception type for a particular frontend compiler exception +> +> data MismatchedParentheses = MismatchedParentheses +> deriving Show +> +> instance Exception MismatchedParentheses where +> toException = frontendExceptionToException +> fromException = frontendExceptionFromException + +We can now catch a @MismatchedParentheses@ exception as +@MismatchedParentheses@, @SomeFrontendException@ or +@SomeCompilerException@, but not other types, e.g. @IOException@: + +@ +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) +*** Exception: MismatchedParentheses +@ + +-} +class (Typeable e, Show e) => Exception e where + toException :: e -> SomeException + fromException :: SomeException -> Maybe e + + toException = SomeException + fromException (SomeException e) = cast e + + -- | Render this exception value in a human-friendly manner. + -- + -- Default implementation: @'show'@. + -- + -- @since 4.8.0.0 + displayException :: e -> String + displayException = show + +-- | @since 3.0 +instance Exception SomeException where + toException se = se + fromException = Just + displayException (SomeException e) = displayException e + +-- |Arithmetic exceptions. +data ArithException + = Overflow + | Underflow + | LossOfPrecision + | DivideByZero + | Denormal + | RatioZeroDenominator -- ^ @since 4.6.0.0 + deriving ( Eq -- ^ @since 3.0 + , Ord -- ^ @since 3.0 + ) + +divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException +divZeroException = toException DivideByZero +overflowException = toException Overflow +ratioZeroDenomException = toException RatioZeroDenominator +underflowException = toException Underflow + +-- | @since 4.0.0.0 +instance Exception ArithException + +-- | @since 4.0.0.0 +instance Show ArithException where + showsPrec _ Overflow = showString "arithmetic overflow" + showsPrec _ Underflow = showString "arithmetic underflow" + showsPrec _ LossOfPrecision = showString "loss of precision" + showsPrec _ DivideByZero = showString "divide by zero" + showsPrec _ Denormal = showString "denormal" + showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception/Type.hs-boot b/libraries/base/GHC/Exception/Type.hs-boot new file mode 100644 index 0000000000..1b4f0c0d81 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Exception.Type + ( SomeException + , divZeroException + , overflowException + , ratioZeroDenomException + , underflowException + ) where + +import GHC.Types () + +data SomeException +divZeroException, overflowException, + ratioZeroDenomException, underflowException :: SomeException diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index f6204aabd4..9fc1a638fc 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -34,6 +34,9 @@ module GHC.Exts uncheckedIShiftL64#, uncheckedIShiftRA64#, isTrue#, + -- * Compat wrapper + atomicModifyMutVar#, + -- * Fusion build, augment, @@ -46,7 +49,7 @@ module GHC.Exts -- * Ids with special behaviour lazy, inline, oneShot, - -- * Running 'RealWorld' state transformers + -- * Running 'RealWorld' state thread runRW#, -- * Safe coercions @@ -154,7 +157,9 @@ traceEvent = Debug.Trace.traceEventIO -- entire ghc package at runtime data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr - deriving( Data, Eq ) + deriving ( Data -- ^ @since 4.3.0.0 + , Eq -- ^ @since 4.3.0.0 + ) {- ********************************************************************** @@ -194,6 +199,15 @@ instance IsList [a] where fromList = id toList = id +-- | @since 4.9.0.0 +instance IsList (NonEmpty a) where + type Item (NonEmpty a) = a + + fromList (a:as) = a :| as + fromList [] = errorWithoutStackTrace "NonEmpty.fromList: empty list" + + toList ~(a :| as) = a : as + -- | @since 4.8.0.0 instance IsList Version where type (Item Version) = Int @@ -208,3 +222,27 @@ instance IsList CallStack where type (Item CallStack) = (String, SrcLoc) fromList = fromCallSiteList toList = getCallStack + +-- | An implementation of the old @atomicModifyMutVar#@ primop in +-- terms of the new 'atomicModifyMutVar2#' primop, for backwards +-- compatibility. The type of this function is a bit bogus. It's +-- best to think of it as having type +-- +-- @ +-- atomicModifyMutVar# +-- :: MutVar# s a +-- -> (a -> (a, b)) +-- -> State# s +-- -> (# State# s, b #) +-- @ +-- +-- but there may be code that uses this with other two-field record +-- types. +atomicModifyMutVar# + :: MutVar# s a + -> (a -> b) + -> State# s + -> (# State# s, c #) +atomicModifyMutVar# mv f s = + case unsafeCoerce# (atomicModifyMutVar2# mv f s) of + (# s', _, ~(_, res) #) -> (# s', res #) diff --git a/libraries/base/GHC/Fingerprint/Type.hs b/libraries/base/GHC/Fingerprint/Type.hs index 1ad34a7791..234bac1d43 100644 --- a/libraries/base/GHC/Fingerprint/Type.hs +++ b/libraries/base/GHC/Fingerprint/Type.hs @@ -22,7 +22,9 @@ import Numeric (showHex) -- Using 128-bit MD5 fingerprints for now. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.4.0.0 + , Ord -- ^ @since 4.4.0.0 + ) -- | @since 4.7.0.0 instance Show Fingerprint where diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index c534bafa07..9296978bd4 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -64,6 +64,13 @@ infixr 8 ** ------------------------------------------------------------------------ -- | Trigonometric and hyperbolic functions and related functions. +-- +-- The Haskell Report defines no laws for 'Floating'. However, '(+)', '(*)' +-- and 'exp' are customarily expected to define an exponential field and have +-- the following properties: +-- +-- * @exp (a + b)@ = @exp a * exp b +-- * @exp (fromInteger 0)@ = @fromInteger 1@ class (Fractional a) => Floating a where pi :: a exp, log, sqrt :: a -> a @@ -159,7 +166,7 @@ class (RealFrac a, Floating a) => RealFloat a where decodeFloat :: a -> (Integer,Int) -- | 'encodeFloat' performs the inverse of 'decodeFloat' in the -- sense that for finite @x@ with the exception of @-0.0@, - -- @'uncurry' 'encodeFloat' ('decodeFloat' x) = x@. + -- @'Prelude.uncurry' 'encodeFloat' ('decodeFloat' x) = x@. -- @'encodeFloat' m n@ is one of the two closest representable -- floating-point numbers to @m*b^^n@ (or @±Infinity@ if overflow -- occurs); usually the closer, but if @m@ contains too many bits, @@ -245,7 +252,18 @@ class (RealFrac a, Floating a) => RealFloat a where ------------------------------------------------------------------------ -- | @since 2.01 -instance Num Float where +-- Note that due to the presence of @NaN@, not all elements of 'Float' have an +-- additive inverse. +-- +-- >>> 0/0 + (negate 0/0 :: Float) +-- NaN +-- +-- Also note that due to the presence of -0, `Float`'s 'Num' instance doesn't +-- have an additive identity +-- +-- >>> 0 + (-0 :: Float) +-- 0.0 +instance Num Float where (+) x y = plusFloat x y (-) x y = minusFloat x y negate x = negateFloat x @@ -272,6 +290,11 @@ instance Real Float where smallInteger m# :% shiftLInteger 1 (negateInt# e#) -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Float' have an +-- multiplicative inverse. +-- +-- >>> 0/0 * (recip 0/0 :: Float) +-- NaN instance Fractional Float where (/) x y = divideFloat x y {-# INLINE fromRational #-} @@ -367,9 +390,9 @@ instance Floating Float where (**) x y = powerFloat x y logBase x y = log y / log x - asinh x = log (x + sqrt (1.0+x*x)) - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + asinh x = asinhFloat x + acosh x = acoshFloat x + atanh x = atanhFloat x log1p = log1pFloat expm1 = expm1Float @@ -425,6 +448,17 @@ instance Show Float where ------------------------------------------------------------------------ -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Double' have an +-- additive inverse. +-- +-- >>> 0/0 + (negate 0/0 :: Double) +-- NaN +-- +-- Also note that due to the presence of -0, `Double`'s 'Num' instance doesn't +-- have an additive identity +-- +-- >>> 0 + (-0 :: Double) +-- 0.0 instance Num Double where (+) x y = plusDouble x y (-) x y = minusDouble x y @@ -454,6 +488,11 @@ instance Real Double where m :% shiftLInteger 1 (negateInt# e#) -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Double' have an +-- multiplicative inverse. +-- +-- >>> 0/0 * (recip 0/0 :: Double) +-- NaN instance Fractional Double where (/) x y = divideDouble x y {-# INLINE fromRational #-} @@ -492,9 +531,9 @@ instance Floating Double where (**) x y = powerDouble x y logBase x y = log y / log x - asinh x = log (x + sqrt (1.0+x*x)) - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + asinh x = asinhDouble x + acosh x = acoshDouble x + atanh x = atanhDouble x log1p = log1pDouble expm1 = expm1Double @@ -682,6 +721,18 @@ formatRealFloatAlt fmt decs alt x [d] -> d : ".0e" ++ show_e' (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' [] -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []" + Just d | d <= 0 -> + -- handle this case specifically since we need to omit the + -- decimal point as well (#15115). + -- Note that this handles negative precisions as well for consistency + -- (see #15509). + case is of + [0] -> "0e0" + _ -> + let + (ei,is') = roundTo base 1 is + n:_ = map intToDigit (if ei > 0 then init is' else is') + in n : 'e' : show (e-1+ei) Just dec -> let dec' = max dec 1 in case is of @@ -1092,6 +1143,7 @@ expFloat, logFloat, sqrtFloat, fabsFloat :: Float -> Float sinFloat, cosFloat, tanFloat :: Float -> Float asinFloat, acosFloat, atanFloat :: Float -> Float sinhFloat, coshFloat, tanhFloat :: Float -> Float +asinhFloat, acoshFloat, atanhFloat :: Float -> Float expFloat (F# x) = F# (expFloat# x) logFloat (F# x) = F# (logFloat# x) sqrtFloat (F# x) = F# (sqrtFloat# x) @@ -1105,6 +1157,9 @@ atanFloat (F# x) = F# (atanFloat# x) sinhFloat (F# x) = F# (sinhFloat# x) coshFloat (F# x) = F# (coshFloat# x) tanhFloat (F# x) = F# (tanhFloat# x) +asinhFloat (F# x) = F# (asinhFloat# x) +acoshFloat (F# x) = F# (acoshFloat# x) +atanhFloat (F# x) = F# (atanhFloat# x) powerFloat :: Float -> Float -> Float powerFloat (F# x) (F# y) = F# (powerFloat# x y) @@ -1137,6 +1192,7 @@ expDouble, logDouble, sqrtDouble, fabsDouble :: Double -> Double sinDouble, cosDouble, tanDouble :: Double -> Double asinDouble, acosDouble, atanDouble :: Double -> Double sinhDouble, coshDouble, tanhDouble :: Double -> Double +asinhDouble, acoshDouble, atanhDouble :: Double -> Double expDouble (D# x) = D# (expDouble# x) logDouble (D# x) = D# (logDouble# x) sqrtDouble (D# x) = D# (sqrtDouble# x) @@ -1150,6 +1206,9 @@ atanDouble (D# x) = D# (atanDouble# x) sinhDouble (D# x) = D# (sinhDouble# x) coshDouble (D# x) = D# (coshDouble# x) tanhDouble (D# x) = D# (tanhDouble# x) +asinhDouble (D# x) = D# (asinhDouble# x) +acoshDouble (D# x) = D# (acoshDouble# x) +atanhDouble (D# x) = D# (atanhDouble# x) powerDouble :: Double -> Double -> Double powerDouble (D# x) (D# y) = D# (x **## y) diff --git a/libraries/base/GHC/Foreign.hs b/libraries/base/GHC/Foreign.hs index eb5e853b38..196005d3a7 100644 --- a/libraries/base/GHC/Foreign.hs +++ b/libraries/base/GHC/Foreign.hs @@ -154,7 +154,8 @@ withCStringsLen enc strs f = go [] strs go cs (s:ss) = withCString enc s $ \c -> go (c:cs) ss go cs [] = withArrayLen (reverse cs) f --- | Determines whether a character can be accurately encoded in a 'CString'. +-- | Determines whether a character can be accurately encoded in a +-- 'Foreign.C.String.CString'. -- -- Pretty much anyone who uses this function is in a state of sin because -- whether or not a character is encodable will, in general, depend on the @@ -200,7 +201,7 @@ peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes) from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p) to <- newCharBuffer chunk_size WriteBuffer - let go iteration from = do + let go !iteration from = do (why, from', to') <- encode decoder from to if isEmptyBuffer from' then @@ -229,7 +230,7 @@ withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p - let go iteration to_sz_bytes = do + let go !iteration to_sz_bytes = do putDebugMsg ("withEncodedCString: " ++ show iteration) allocaBytes to_sz_bytes $ \to_p -> do mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes act @@ -249,7 +250,7 @@ newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p - let go iteration to_p to_sz_bytes = do + let go !iteration to_p to_sz_bytes = do putDebugMsg ("newEncodedCString: " ++ show iteration) mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes return case mb_res of @@ -271,7 +272,7 @@ tryFillBufferAndCall encoder null_terminate from0 to_p to_sz_bytes act = do to_fp <- newForeignPtr_ to_p go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer) where - go iteration (from, to) = do + go !iteration (from, to) = do (why, from', to') <- encode encoder from to putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from') if isEmptyBuffer from' diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index 043de1f94b..6aed677dbb 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -153,8 +153,8 @@ mallocForeignPtr :: Storable a => IO (ForeignPtr a) -- implementation in GHC. It uses pinned memory in the garbage -- collected heap, so the 'ForeignPtr' does not require a finalizer to -- free the memory. Use of 'mallocForeignPtr' and associated --- functions is strongly recommended in preference to 'newForeignPtr' --- with a finalizer. +-- functions is strongly recommended in preference to +-- 'Foreign.ForeignPtr.newForeignPtr' with a finalizer. -- mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) @@ -289,9 +289,10 @@ addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO () -- -- NB. Be very careful with these finalizers. One common trap is that -- if a finalizer references another finalized value, it does not --- prevent that value from being finalized. In particular, 'Handle's --- are finalized objects, so a finalizer should not refer to a 'Handle' --- (including @stdout@, @stdin@ or @stderr@). +-- prevent that value from being finalized. In particular, 'System.IO.Handle's +-- are finalized objects, so a finalizer should not refer to a +-- 'System.IO.Handle' (including 'System.IO.stdout', 'System.IO.stdin', or +-- 'System.IO.stderr'). -- addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer = addForeignPtrConcFinalizer_ c finalizer @@ -321,7 +322,7 @@ addForeignPtrConcFinalizer_ _ _ = insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool insertHaskellFinalizer r f = do - !wasEmpty <- atomicModifyIORef r $ \finalizers -> case finalizers of + !wasEmpty <- atomicModifyIORefP r $ \finalizers -> case finalizers of NoFinalizers -> (HaskellFinalizers [f], True) HaskellFinalizers fs -> (HaskellFinalizers (f:fs), False) _ -> noMixingError @@ -352,8 +353,8 @@ ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do NoFinalizers -> IO $ \s -> case mkWeakNoFinalizer# r# (unsafeCoerce# value) s of { (# s1, w #) -> -- See Note [MallocPtr finalizers] (#10904) - case atomicModifyMutVar# r# (update w) s1 of - { (# s2, (weak, needKill ) #) -> + case atomicModifyMutVar2# r# (update w) s1 of + { (# s2, _, (_, (weak, needKill )) #) -> if needKill then case finalizeWeak# w s2 of { (# s3, _, _ #) -> (# s3, weak #) } @@ -370,7 +371,8 @@ noMixingError = errorWithoutStackTrace $ foreignPtrFinalizer :: IORef Finalizers -> IO () foreignPtrFinalizer r = do - fs <- atomicModifyIORef r $ \fs -> (NoFinalizers, fs) -- atomic, see #7170 + fs <- atomicSwapIORef r NoFinalizers + -- atomic, see #7170 case fs of NoFinalizers -> return () CFinalizers w -> IO $ \s -> case finalizeWeak# w s of diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs index 14184c2eb6..c4e09aa198 100644 --- a/libraries/base/GHC/Generics.hs +++ b/libraries/base/GHC/Generics.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -14,7 +15,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -105,7 +105,7 @@ module GHC.Generics ( -- This is a lot of information! However, most of it is actually merely meta-information -- that makes names of datatypes and constructors and more available on the type level. -- --- Here is a reduced representation for 'Tree' with nearly all meta-information removed, +-- Here is a reduced representation for @Tree@ with nearly all meta-information removed, -- for now keeping only the most essential aspects: -- -- @ @@ -189,7 +189,7 @@ module GHC.Generics ( -- -- Here, 'R' is a type-level proxy that does not have any associated values. -- --- There used to be another variant of 'K1' (namely 'Par0'), but it has since +-- There used to be another variant of 'K1' (namely @Par0@), but it has since -- been deprecated. -- *** Meta information: 'M1' @@ -273,7 +273,7 @@ module GHC.Generics ( -- between the original value and its `Rep`-based representation and then invokes the -- generic instances. -- --- As an example, let us look at a function 'encode' that produces a naive, but lossless +-- As an example, let us look at a function @encode@ that produces a naive, but lossless -- bit encoding of values of various datatypes. So we are aiming to define a function -- -- @ @@ -367,18 +367,15 @@ module GHC.Generics ( -- @ -- -- The case for 'K1' is rather interesting. Here, we call the final function --- 'encode' that we yet have to define, recursively. We will use another type --- class 'Encode' for that function: +-- @encode@ that we yet have to define, recursively. We will use another type +-- class @Encode@ for that function: -- -- @ -- instance (Encode c) => Encode' ('K1' i c) where -- encode' ('K1' x) = encode x -- @ -- --- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define --- a uniform instance here. --- --- Similarly, we can define a uniform instance for 'M1', because we completely +-- Note how we can define a uniform instance for 'M1', because we completely -- disregard all meta-information: -- -- @ @@ -386,13 +383,13 @@ module GHC.Generics ( -- encode' ('M1' x) = encode' x -- @ -- --- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. +-- Unlike in 'K1', the instance for 'M1' refers to @encode'@, not @encode@. -- *** The wrapper and generic default -- -- | -- --- We now define class 'Encode' for the actual 'encode' function: +-- We now define class @Encode@ for the actual @encode@ function: -- -- @ -- class Encode a where @@ -401,9 +398,9 @@ module GHC.Generics ( -- encode x = encode' ('from' x) -- @ -- --- The incoming 'x' is converted using 'from', then we dispatch to the --- generic instances using 'encode''. We use this as a default definition --- for 'encode'. We need the 'default encode' signature because ordinary +-- The incoming @x@ is converted using 'from', then we dispatch to the +-- generic instances using @encode'@. We use this as a default definition +-- for @encode@. We need the @default encode@ signature because ordinary -- Haskell default methods must not introduce additional class constraints, -- but our generic default does. -- @@ -421,10 +418,10 @@ module GHC.Generics ( -- possible to use @deriving Encode@ as well, but GHC does not yet support -- that syntax for this situation. -- --- Having 'Encode' as a class has the advantage that we can define +-- Having @Encode@ as a class has the advantage that we can define -- non-generic special cases, which is particularly useful for abstract -- datatypes that have no structural representation. For example, given --- a suitable integer encoding function 'encodeInt', we can define +-- a suitable integer encoding function @encodeInt@, we can define -- -- @ -- instance Encode Int where @@ -457,7 +454,7 @@ module GHC.Generics ( -- any datatype where each constructor has at least one field. -- -- An 'M1' instance is always required (but it can just ignore the --- meta-information, as is the case for 'encode' above). +-- meta-information, as is the case for @encode@ above). #if 0 -- *** Using meta-information -- @@ -470,14 +467,15 @@ module GHC.Generics ( -- | -- -- Datatype-generic functions as defined above work for a large class --- of datatypes, including parameterized datatypes. (We have used 'Tree' +-- of datatypes, including parameterized datatypes. (We have used @Tree@ -- as our example above, which is of kind @* -> *@.) However, the -- 'Generic' class ranges over types of kind @*@, and therefore, the --- resulting generic functions (such as 'encode') must be parameterized +-- resulting generic functions (such as @encode@) must be parameterized -- by a generic type argument of kind @*@. -- -- What if we want to define generic classes that range over type --- constructors (such as 'Functor', 'Traversable', or 'Foldable')? +-- constructors (such as 'Data.Functor.Functor', +-- 'Data.Traversable.Traversable', or 'Data.Foldable.Foldable')? -- *** The 'Generic1' class -- @@ -491,7 +489,7 @@ module GHC.Generics ( -- The 'Generic1' class is also derivable. -- -- The representation 'Rep1' is ever so slightly different from 'Rep'. --- Let us look at 'Tree' as an example again: +-- Let us look at @Tree@ as an example again: -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) @@ -731,6 +729,7 @@ module GHC.Generics ( -- We use some base types import Data.Either ( Either (..) ) import Data.Maybe ( Maybe(..), fromMaybe ) +import Data.Ord ( Down(..) ) import GHC.Integer ( Integer, integerToInt ) import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Ptr ( Ptr ) @@ -739,10 +738,11 @@ import GHC.Types -- Needed for instances import GHC.Arr ( Ix ) import GHC.Base ( Alternative(..), Applicative(..), Functor(..) - , Monad(..), MonadPlus(..), String, coerce ) + , Monad(..), MonadPlus(..), NonEmpty(..), String, coerce + , Semigroup(..), Monoid(..) ) import GHC.Classes ( Eq(..), Ord(..) ) import GHC.Enum ( Bounded, Enum ) -import GHC.Read ( Read(..), lex, readParen ) +import GHC.Read ( Read(..) ) import GHC.Show ( Show(..), showString ) -- Needed for metadata @@ -755,28 +755,35 @@ import GHC.TypeLits ( Nat, Symbol, KnownSymbol, KnownNat, symbolVal, natVal ) -- | Void: used for datatypes without constructors data V1 (p :: k) - deriving (Functor, Generic, Generic1) - -deriving instance Eq (V1 p) -deriving instance Ord (V1 p) -deriving instance Read (V1 p) -deriving instance Show (V1 p) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.12.0.0 +instance Semigroup (V1 p) where + v <> _ = v -- | Unit: used for constructors without arguments data U1 (p :: k) = U1 - deriving (Generic, Generic1) + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Eq (U1 p) where _ == _ = True --- | @since 4.9.0.0 +-- | @since 4.7.0.0 instance Ord (U1 p) where compare _ _ = EQ -- | @since 4.9.0.0 -instance Read (U1 p) where - readsPrec d = readParen (d > 10) (\r -> [(U1, s) | ("U1",s) <- lex r ]) +deriving instance Read (U1 p) -- | @since 4.9.0.0 instance Show (U1 p) where @@ -804,9 +811,24 @@ instance Monad U1 where -- | @since 4.9.0.0 instance MonadPlus U1 +-- | @since 4.12.0.0 +instance Semigroup (U1 p) where + _ <> _ = U1 + +-- | @since 4.12.0.0 +instance Monoid (U1 p) where + mempty = U1 + -- | Used for marking occurrences of the parameter newtype Par1 p = Par1 { unPar1 :: p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Applicative Par1 where @@ -818,10 +840,23 @@ instance Applicative Par1 where instance Monad Par1 where Par1 x >>= f = f x +-- | @since 4.12.0.0 +deriving instance Semigroup p => Semigroup (Par1 p) + +-- | @since 4.12.0.0 +deriving instance Monoid p => Monoid (Par1 p) + -- | Recursive calls of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@ -- is enabled) -newtype Rec1 (f :: k -> *) (p :: k) = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype Rec1 (f :: k -> Type) (p :: k) = Rec1 { unRec1 :: f p } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 deriving instance Applicative f => Applicative (Rec1 f) @@ -836,9 +871,34 @@ instance Monad f => Monad (Rec1 f) where -- | @since 4.9.0.0 deriving instance MonadPlus f => MonadPlus (Rec1 f) +-- | @since 4.12.0.0 +deriving instance Semigroup (f p) => Semigroup (Rec1 f p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f p) => Monoid (Rec1 f p) + -- | Constants, additional parameters and recursion of kind @*@ -newtype K1 (i :: *) c (p :: k) = K1 { unK1 :: c } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype K1 (i :: Type) c (p :: k) = K1 { unK1 :: c } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.12.0.0 +instance Monoid c => Applicative (K1 i c) where + pure _ = K1 mempty + liftA2 = \_ -> coerce (mappend :: c -> c -> c) + (<*>) = coerce (mappend :: c -> c -> c) + +-- | @since 4.12.0.0 +deriving instance Semigroup c => Semigroup (K1 i c p) + +-- | @since 4.12.0.0 +deriving instance Monoid c => Monoid (K1 i c p) -- | @since 4.9.0.0 deriving instance Applicative f => Applicative (M1 i c f) @@ -852,19 +912,47 @@ deriving instance Monad f => Monad (M1 i c f) -- | @since 4.9.0.0 deriving instance MonadPlus f => MonadPlus (M1 i c f) +-- | @since 4.12.0.0 +deriving instance Semigroup (f p) => Semigroup (M1 i c f p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f p) => Monoid (M1 i c f p) + -- | Meta-information (constructor names, etc.) -newtype M1 (i :: *) (c :: Meta) (f :: k -> *) (p :: k) = M1 { unM1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype M1 (i :: Type) (c :: Meta) (f :: k -> Type) (p :: k) = + M1 { unM1 :: f p } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Sums: encode choice between constructors infixr 5 :+: -data (:+:) (f :: k -> *) (g :: k -> *) (p :: k) = L1 (f p) | R1 (g p) - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +data (:+:) (f :: k -> Type) (g :: k -> Type) (p :: k) = L1 (f p) | R1 (g p) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Products: encode multiple arguments to constructors infixr 6 :*: -data (:*:) (f :: k -> *) (g :: k -> *) (p :: k) = f p :*: g p - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +data (:*:) (f :: k -> Type) (g :: k -> Type) (p :: k) = f p :*: g p + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Applicative f, Applicative g) => Applicative (f :*: g) where @@ -887,11 +975,26 @@ instance (Monad f, Monad g) => Monad (f :*: g) where -- | @since 4.9.0.0 instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) +-- | @since 4.12.0.0 +instance (Semigroup (f p), Semigroup (g p)) => Semigroup ((f :*: g) p) where + (x1 :*: y1) <> (x2 :*: y2) = (x1 <> x2) :*: (y1 <> y2) + +-- | @since 4.12.0.0 +instance (Monoid (f p), Monoid (g p)) => Monoid ((f :*: g) p) where + mempty = mempty :*: mempty + -- | Composition of functors infixr 7 :.: -newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = +newtype (:.:) (f :: k2 -> Type) (g :: k1 -> k2) (p :: k1) = Comp1 { unComp1 :: f (g p) } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Applicative f, Applicative g) => Applicative (f :.: g) where @@ -905,46 +1008,85 @@ instance (Alternative f, Applicative g) => Alternative (f :.: g) where (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a)) :: forall a . (f :.: g) a -> (f :.: g) a -> (f :.: g) a +-- | @since 4.12.0.0 +deriving instance Semigroup (f (g p)) => Semigroup ((f :.: g) p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f (g p)) => Monoid ((f :.: g) p) + -- | Constants of unlifted kinds -- -- @since 4.9.0.0 -data family URec (a :: *) (p :: k) +data family URec (a :: Type) (p :: k) -- | Used for marking occurrences of 'Addr#' -- -- @since 4.9.0.0 data instance URec (Ptr ()) (p :: k) = UAddr { uAddr# :: Addr# } - deriving (Eq, Ord, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Char#' -- -- @since 4.9.0.0 data instance URec Char (p :: k) = UChar { uChar# :: Char# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Double#' -- -- @since 4.9.0.0 data instance URec Double (p :: k) = UDouble { uDouble# :: Double# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Float#' -- -- @since 4.9.0.0 data instance URec Float (p :: k) = UFloat { uFloat# :: Float# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq, Ord, Show + , Functor -- ^ @since 4.9.0.0 + , Generic + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Int#' -- -- @since 4.9.0.0 data instance URec Int (p :: k) = UInt { uInt# :: Int# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Word#' -- -- @since 4.9.0.0 data instance URec Word (p :: k) = UWord { uWord# :: Word# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Type synonym for @'URec' 'Addr#'@ -- @@ -975,10 +1117,10 @@ type UInt = URec Int -- @since 4.9.0.0 type UWord = URec Word --- | Tag for K1: recursion (of kind @*@) +-- | Tag for K1: recursion (of kind @Type@) data R --- | Type synonym for encoding recursion (of kind @*@) +-- | Type synonym for encoding recursion (of kind @Type@) type Rec0 = K1 R -- | Tag for M1: datatype @@ -1000,17 +1142,17 @@ type S1 = M1 S -- | Class for datatypes that represent datatypes class Datatype d where -- | The name of the datatype (unqualified) - datatypeName :: t d (f :: k -> *) (a :: k) -> [Char] + datatypeName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | The fully-qualified name of the module where the type is declared - moduleName :: t d (f :: k -> *) (a :: k) -> [Char] + moduleName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | The package name of the module where the type is declared -- -- @since 4.9.0.0 - packageName :: t d (f :: k -> *) (a :: k) -> [Char] + packageName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | Marks if the datatype is actually a newtype -- -- @since 4.7.0.0 - isNewtype :: t d (f :: k -> *) (a :: k) -> Bool + isNewtype :: t d (f :: k -> Type) (a :: k) -> Bool isNewtype _ = False -- | @since 4.9.0.0 @@ -1024,14 +1166,14 @@ instance (KnownSymbol n, KnownSymbol m, KnownSymbol p, SingI nt) -- | Class for datatypes that represent data constructors class Constructor c where -- | The name of the constructor - conName :: t c (f :: k -> *) (a :: k) -> [Char] + conName :: t c (f :: k -> Type) (a :: k) -> [Char] -- | The fixity of the constructor - conFixity :: t c (f :: k -> *) (a :: k) -> Fixity + conFixity :: t c (f :: k -> Type) (a :: k) -> Fixity conFixity _ = Prefix -- | Marks if this constructor is a record - conIsRecord :: t c (f :: k -> *) (a :: k) -> Bool + conIsRecord :: t c (f :: k -> Type) (a :: k) -> Bool conIsRecord _ = False -- | @since 4.9.0.0 @@ -1044,7 +1186,12 @@ instance (KnownSymbol n, SingI f, SingI r) -- | Datatype to represent the fixity of a constructor. An infix -- | declaration directly corresponds to an application of 'Infix'. data Fixity = Prefix | Infix Associativity Int - deriving (Eq, Show, Ord, Read, Generic) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + , Ord -- ^ @since 4.6.0.0 + , Read -- ^ @since 4.6.0.0 + , Generic -- ^ @since 4.7.0.0 + ) -- | This variant of 'Fixity' appears at the type level. -- @@ -1060,7 +1207,15 @@ prec (Infix _ n) = n data Associativity = LeftAssociative | RightAssociative | NotAssociative - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + , Ord -- ^ @since 4.6.0.0 + , Read -- ^ @since 4.6.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + ) -- | The unpackedness of a field as the user wrote it in the source code. For -- example, in the following data type: @@ -1078,7 +1233,15 @@ data Associativity = LeftAssociative data SourceUnpackedness = NoSourceUnpackedness | SourceNoUnpack | SourceUnpack - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | The strictness of a field as the user wrote it in the source code. For -- example, in the following data type: @@ -1094,7 +1257,15 @@ data SourceUnpackedness = NoSourceUnpackedness data SourceStrictness = NoSourceStrictness | SourceLazy | SourceStrict - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | The strictness that GHC infers for a field during compilation. Whereas -- there are nine different combinations of 'SourceUnpackedness' and @@ -1121,24 +1292,32 @@ data SourceStrictness = NoSourceStrictness data DecidedStrictness = DecidedLazy | DecidedStrict | DecidedUnpack - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | Class for datatypes that represent records class Selector s where -- | The name of the selector - selName :: t s (f :: k -> *) (a :: k) -> [Char] + selName :: t s (f :: k -> Type) (a :: k) -> [Char] -- | The selector's unpackedness annotation (if any) -- -- @since 4.9.0.0 - selSourceUnpackedness :: t s (f :: k -> *) (a :: k) -> SourceUnpackedness + selSourceUnpackedness :: t s (f :: k -> Type) (a :: k) -> SourceUnpackedness -- | The selector's strictness annotation (if any) -- -- @since 4.9.0.0 - selSourceStrictness :: t s (f :: k -> *) (a :: k) -> SourceStrictness + selSourceStrictness :: t s (f :: k -> Type) (a :: k) -> SourceStrictness -- | The strictness that the compiler inferred for the selector -- -- @since 4.9.0.0 - selDecidedStrictness :: t s (f :: k -> *) (a :: k) -> DecidedStrictness + selDecidedStrictness :: t s (f :: k -> Type) (a :: k) -> DecidedStrictness -- | @since 4.9.0.0 instance (SingI mn, SingI su, SingI ss, SingI ds) @@ -1148,11 +1327,18 @@ instance (SingI mn, SingI su, SingI ss, SingI ds) selSourceStrictness _ = fromSing (sing :: Sing ss) selDecidedStrictness _ = fromSing (sing :: Sing ds) --- | Representable types of kind *. --- This class is derivable in GHC with the DeriveGeneric flag on. +-- | Representable types of kind @*@. +-- This class is derivable in GHC with the @DeriveGeneric@ flag on. +-- +-- A 'Generic' instance must satisfy the following laws: +-- +-- @ +-- 'from' . 'to' ≡ 'Prelude.id' +-- 'to' . 'from' ≡ 'Prelude.id' +-- @ class Generic a where -- | Generic representation type - type Rep a :: * -> * + type Rep a :: Type -> Type -- | Convert from the datatype to its representation from :: a -> (Rep a) x -- | Convert from the representation to the datatype @@ -1162,9 +1348,16 @@ class Generic a where -- | Representable types of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@ -- is enabled). -- This class is derivable in GHC with the @DeriveGeneric@ flag on. -class Generic1 (f :: k -> *) where +-- +-- A 'Generic1' instance must satisfy the following laws: +-- +-- @ +-- 'from1' . 'to1' ≡ 'Prelude.id' +-- 'to1' . 'from1' ≡ 'Prelude.id' +-- @ +class Generic1 (f :: k -> Type) where -- | Generic representation type - type Rep1 f :: k -> * + type Rep1 f :: k -> Type -- | Convert from the datatype to its representation from1 :: f a -> (Rep1 f) a -- | Convert from the representation to the datatype @@ -1199,31 +1392,88 @@ data Meta = MetaData Symbol Symbol Symbol Bool -- Derived instances -------------------------------------------------------------------------------- +-- | @since 4.6.0.0 deriving instance Generic [a] + +-- | @since 4.6.0.0 +deriving instance Generic (NonEmpty a) + +-- | @since 4.6.0.0 deriving instance Generic (Maybe a) + +-- | @since 4.6.0.0 deriving instance Generic (Either a b) + +-- | @since 4.6.0.0 deriving instance Generic Bool + +-- | @since 4.6.0.0 deriving instance Generic Ordering + +-- | @since 4.6.0.0 deriving instance Generic (Proxy t) + +-- | @since 4.6.0.0 deriving instance Generic () + +-- | @since 4.6.0.0 deriving instance Generic ((,) a b) + +-- | @since 4.6.0.0 deriving instance Generic ((,,) a b c) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,) a b c d) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,) a b c d e) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,,) a b c d e f) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,,,) a b c d e f g) +-- | @since 4.12.0.0 +deriving instance Generic (Down a) + + +-- | @since 4.6.0.0 deriving instance Generic1 [] + +-- | @since 4.6.0.0 +deriving instance Generic1 NonEmpty + +-- | @since 4.6.0.0 deriving instance Generic1 Maybe + +-- | @since 4.6.0.0 deriving instance Generic1 (Either a) + +-- | @since 4.6.0.0 deriving instance Generic1 Proxy + +-- | @since 4.6.0.0 deriving instance Generic1 ((,) a) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,) a b) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,) a b c) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,) a b c d) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,,) a b c d e) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,,,) a b c d e f) +-- | @since 4.12.0.0 +deriving instance Generic1 Down + -------------------------------------------------------------------------------- -- Copied from the singletons package -------------------------------------------------------------------------------- @@ -1232,8 +1482,6 @@ deriving instance Generic1 ((,,,,,,) a b c d e f) data family Sing (a :: k) -- | A 'SingI' constraint is essentially an implicitly-passed singleton. --- If you need to satisfy this constraint with an explicit singleton, please --- see 'withSingI'. class SingI (a :: k) where -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ -- extension to use this method the way you want. @@ -1245,7 +1493,7 @@ class SingI (a :: k) where class SingKind k where -- | Get a base type from a proxy for the promoted kind. For example, -- @DemoteRep Bool@ will be the type @Bool@. - type DemoteRep k :: * + type DemoteRep k :: Type -- | Convert a singleton to its unrefined version. fromSing :: Sing (a :: k) -> DemoteRep k diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs index 118ebeaeed..6b83cca0d1 100644 --- a/libraries/base/GHC/IO.hs +++ b/libraries/base/GHC/IO.hs @@ -53,8 +53,8 @@ import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError ) -- The IO Monad {- -The IO Monad is just an instance of the ST monad, where the state is -the real world. We use the exception mechanism (in GHC.Exception) to +The IO Monad is just an instance of the ST monad, where the state thread +is the real world. We use the exception mechanism (in GHC.Exception) to implement IO exceptions. NOTE: The IO representation is deeply wired in to various parts of the @@ -84,7 +84,7 @@ failIO s = IO (raiseIO# (toException (userError s))) -- --------------------------------------------------------------------------- -- Coercions between IO and ST --- | Embed a strict state transformer in an 'IO' +-- | Embed a strict state thread in an 'IO' -- action. The 'RealWorld' parameter indicates that the internal state -- used by the 'ST' computation is a special one supplied by the 'IO' -- monad, and thus distinct from those used by invocations of 'runST'. @@ -92,20 +92,20 @@ stToIO :: ST RealWorld a -> IO a stToIO (ST m) = IO m -- | Convert an 'IO' action into an 'ST' action. The type of the result --- is constrained to use a 'RealWorld' state, and therefore the result cannot --- be passed to 'runST'. +-- is constrained to use a 'RealWorld' state thread, and therefore the +-- result cannot be passed to 'runST'. ioToST :: IO a -> ST RealWorld a ioToST (IO m) = (ST m) -- | Convert an 'IO' action to an 'ST' action. -- This relies on 'IO' and 'ST' having the same representation modulo the --- constraint on the type of the state. +-- constraint on the state thread type parameter. unsafeIOToST :: IO a -> ST s a unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s -- | Convert an 'ST' action to an 'IO' action. -- This relies on 'IO' and 'ST' having the same representation modulo the --- constraint on the type of the state. +-- constraint on the state thread type parameter. -- -- For an example demonstrating why this is unsafe, see -- https://mail.haskell.org/pipermail/haskell-cafe/2009-April/060719.html @@ -279,7 +279,9 @@ data MaskingState -- ^ the state during 'mask': asynchronous exceptions are masked, but blocking operations may still be interrupted | MaskedUninterruptible -- ^ the state during 'uninterruptibleMask': asynchronous exceptions are masked, and blocking operations may not be interrupted - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | Returns the 'MaskingState' for the current thread. getMaskingState :: IO MaskingState @@ -334,7 +336,7 @@ onException io what = io `catchException` \e -> do _ <- what -- 'MaskedInterruptible' state, -- use @mask_ $ forkIO ...@. This is particularly useful if you need -- to establish an exception handler in the forked thread before any --- asynchronous exceptions are received. To create a a new thread in +-- asynchronous exceptions are received. To create a new thread in -- an unmasked state use 'Control.Concurrent.forkIOWithUnmask'. -- mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b diff --git a/libraries/base/GHC/IO.hs-boot b/libraries/base/GHC/IO.hs-boot index 88b09aafb0..aa2e5ccd2d 100644 --- a/libraries/base/GHC/IO.hs-boot +++ b/libraries/base/GHC/IO.hs-boot @@ -4,6 +4,7 @@ module GHC.IO where import GHC.Types +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base failIO :: [Char] -> IO a mplusIO :: IO a -> IO a -> IO a diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs index 33eee6363d..447c574e2b 100644 --- a/libraries/base/GHC/IO/Buffer.hs +++ b/libraries/base/GHC/IO/Buffer.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Trustworthy, BangPatterns #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -192,7 +192,8 @@ type CharBuffer = Buffer Word16 type CharBuffer = Buffer Char #endif -data BufferState = ReadBuffer | WriteBuffer deriving (Eq) +data BufferState = ReadBuffer | WriteBuffer + deriving Eq -- ^ @since 4.2.0.0 withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f @@ -264,7 +265,8 @@ foreign import ccall unsafe "memmove" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) summaryBuffer :: Buffer a -> String -summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" +summaryBuffer !buf -- Strict => slightly better code + = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" -- INVARIANTS on Buffers: -- * r <= w diff --git a/libraries/base/GHC/IO/BufferedIO.hs b/libraries/base/GHC/IO/BufferedIO.hs index 4c81d9a4ec..cd38cefe07 100644 --- a/libraries/base/GHC/IO/BufferedIO.hs +++ b/libraries/base/GHC/IO/BufferedIO.hs @@ -32,8 +32,8 @@ import GHC.IO.Buffer -- | The purpose of 'BufferedIO' is to provide a common interface for I/O -- devices that can read and write data through a buffer. Devices that -- implement 'BufferedIO' include ordinary files, memory-mapped files, --- and bytestrings. The underlying device implementing a 'Handle' must --- provide 'BufferedIO'. +-- and bytestrings. The underlying device implementing a 'System.IO.Handle' +-- must provide 'BufferedIO'. -- class BufferedIO dev where -- | allocate a new buffer. The size of the buffer is at the diff --git a/libraries/base/GHC/IO/Device.hs b/libraries/base/GHC/IO/Device.hs index ddeb861eca..e33dcd02b1 100644 --- a/libraries/base/GHC/IO/Device.hs +++ b/libraries/base/GHC/IO/Device.hs @@ -56,7 +56,7 @@ class RawIO a where writeNonBlocking :: a -> Ptr Word8 -> Int -> IO Int --- | I/O operations required for implementing a 'Handle'. +-- | I/O operations required for implementing a 'System.IO.Handle'. class IODevice a where -- | @ready dev write msecs@ returns 'True' if the device has data -- to read (if @write@ is 'False') or space to write new data (if @@ -154,17 +154,24 @@ data IODeviceType -- read and write operations and may be seekable only -- to positions of certain granularity (block- -- aligned). - deriving (Eq) + deriving ( Eq -- ^ @since 4.2.0.0 + ) -- ----------------------------------------------------------------------------- -- SeekMode type --- | A mode that determines the effect of 'hSeek' @hdl mode i@. +-- | A mode that determines the effect of 'System.IO.hSeek' @hdl mode i@. data SeekMode = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@. | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@ -- from the current position. | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ -- from the end of the file. - deriving (Eq, Ord, Ix, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Ix -- ^ @since 4.2.0.0 + , Enum -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) diff --git a/libraries/base/GHC/IO/Encoding.hs b/libraries/base/GHC/IO/Encoding.hs index 578a420faf..b734f00f5b 100644 --- a/libraries/base/GHC/IO/Encoding.hs +++ b/libraries/base/GHC/IO/Encoding.hs @@ -27,6 +27,7 @@ module GHC.IO.Encoding ( setLocaleEncoding, setFileSystemEncoding, setForeignEncoding, char8, mkTextEncoding, + argvEncoding ) where import GHC.Base @@ -56,7 +57,8 @@ import System.IO.Unsafe (unsafePerformIO) -- | The Latin1 (ISO8859-1) encoding. This encoding maps bytes -- directly to the first 256 Unicode code points, and is thus not a -- complete Unicode encoding. An attempt to write a character greater than --- '\255' to a 'Handle' using the 'latin1' encoding will result in an error. +-- '\255' to a 'System.IO.Handle' using the 'latin1' encoding will result in an +-- error. latin1 :: TextEncoding latin1 = Latin1.latin1_checked @@ -121,7 +123,7 @@ getFileSystemEncoding :: IO TextEncoding -- | The Unicode encoding of the current locale, but where undecodable -- bytes are replaced with their closest visual match. Used for --- the 'CString' marshalling functions in "Foreign.C.String" +-- the 'Foreign.C.String.CString' marshalling functions in "Foreign.C.String" -- -- @since 4.5.0.0 getForeignEncoding :: IO TextEncoding @@ -161,6 +163,17 @@ initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure initForeignEncoding = CodePage.mkLocaleEncoding IgnoreCodingFailure #endif +-- See Note [Windows Unicode Arguments] in rts/RtsFlags.c +-- On Windows we assume hs_init argv is in utf8 encoding. + +-- | Internal encoding of argv +argvEncoding :: IO TextEncoding +#if defined(mingw32_HOST_OS) +argvEncoding = return utf8 +#else +argvEncoding = getFileSystemEncoding +#endif + -- | An encoding in which Unicode code points are translated to bytes -- by taking the code point modulo 256. When decoding, bytes are -- translated directly into the equivalent code point. @@ -175,7 +188,7 @@ char8 = Latin1.latin1 -- | Look up the named Unicode encoding. May fail with -- --- * 'isDoesNotExistError' if the encoding is unknown +-- * 'System.IO.Error.isDoesNotExistError' if the encoding is unknown -- -- The set of known encodings is system-dependent, but includes at least: -- diff --git a/libraries/base/GHC/IO/Encoding/CodePage/API.hs b/libraries/base/GHC/IO/Encoding/CodePage/API.hs index f1d9d93e8f..b31ebe96f5 100644 --- a/libraries/base/GHC/IO/Encoding/CodePage/API.hs +++ b/libraries/base/GHC/IO/Encoding/CodePage/API.hs @@ -285,7 +285,7 @@ cpEncode cp _max_char_size = \ibuf obuf -> do return (why2, mbuf', obuf) #else case why2 of - -- If we succesfully translate all of the UTF-16 buffer, we need to know why + -- If we successfully translate all of the UTF-16 buffer, we need to know why -- we weren't able to get any more UTF-16 out of the UTF-32 buffer InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf) | otherwise -> errorWithoutStackTrace "cpEncode: impossible underflown UTF-16 buffer" @@ -361,7 +361,7 @@ bSearch msg code ibuf mbuf target_to_elems = go -- -- Luckily if we have InvalidSequence/OutputUnderflow and we do not appear to have reached -- the target, what we should do is the same as normal because the fraction of ibuf that our - -- first "code" coded succesfully must be invalid-sequence-free, and ibuf will always + -- first "code" coded successfully must be invalid-sequence-free, and ibuf will always -- have been decoded as far as the first invalid sequence in it. case bufferElems mbuf `compare` target_to_elems of -- Coding n "from" chars from the input yields exactly as many "to" chars diff --git a/libraries/base/GHC/IO/Encoding/Failure.hs b/libraries/base/GHC/IO/Encoding/Failure.hs index 3f9360d731..c8d29f4d50 100644 --- a/libraries/base/GHC/IO/Encoding/Failure.hs +++ b/libraries/base/GHC/IO/Encoding/Failure.hs @@ -34,8 +34,8 @@ import GHC.Real ( fromIntegral ) --import System.Posix.Internals --- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and --- specifies how they handle illegal sequences. +-- | The 'CodingFailureMode' is used to construct 'System.IO.TextEncoding's, +-- and specifies how they handle illegal sequences. data CodingFailureMode = ErrorOnCodingFailure -- ^ Throw an error when an illegal sequence is encountered @@ -48,7 +48,8 @@ data CodingFailureMode | RoundtripFailure -- ^ Use the private-use escape mechanism to attempt to allow -- illegal sequences to be roundtripped. - deriving (Show) + deriving ( Show -- ^ @since 4.4.0.0 + ) -- This will only work properly for those encodings which are -- strict supersets of ASCII in the sense that valid ASCII data -- is also valid in that encoding. This is not true for diff --git a/libraries/base/GHC/IO/Encoding/Types.hs b/libraries/base/GHC/IO/Encoding/Types.hs index daab9d5157..2f8ffd5e59 100644 --- a/libraries/base/GHC/IO/Encoding/Types.hs +++ b/libraries/base/GHC/IO/Encoding/Types.hs @@ -103,11 +103,11 @@ type TextEncoder state = BufferCodec CharBufElem Word8 state -- between sequences of bytes and sequences of Unicode characters. -- -- For example, UTF-8 is an encoding of Unicode characters into a sequence --- of bytes. The 'TextEncoding' for UTF-8 is 'utf8'. +-- of bytes. The 'TextEncoding' for UTF-8 is 'System.IO.utf8'. data TextEncoding = forall dstate estate . TextEncoding { textEncodingName :: String, - -- ^ a string that can be passed to 'mkTextEncoding' to + -- ^ a string that can be passed to 'System.IO.mkTextEncoding' to -- create an equivalent 'TextEncoding'. mkTextDecoder :: IO (TextDecoder dstate), -- ^ Creates a means of decoding bytes into characters: the result must not @@ -129,5 +129,7 @@ data CodingProgress = InputUnderflow -- ^ Stopped because the input contains in | InvalidSequence -- ^ Stopped because there are sufficient free elements in the output -- to output at least one encoded ASCII character, but the input contains -- an invalid or unrepresentable sequence - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs index 9203f46828..bd9a15216d 100644 --- a/libraries/base/GHC/IO/Exception.hs +++ b/libraries/base/GHC/IO/Exception.hs @@ -33,6 +33,7 @@ module GHC.IO.Exception ( ArrayException(..), ExitCode(..), + FixIOException (..), ioException, ioError, @@ -225,7 +226,9 @@ data AsyncException -- ^This exception is raised by default in the main thread of -- the program when the user requests to terminate the program -- via the usual mechanism(s) (e.g. Control-C in the console). - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + ) -- | @since 4.7.0.0 instance Exception AsyncException where @@ -240,7 +243,9 @@ data ArrayException | UndefinedElement String -- ^An attempt was made to evaluate an element of an -- array that had not been initialized. - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + ) -- | @since 4.1.0.0 instance Exception ArrayException @@ -268,6 +273,19 @@ instance Show ArrayException where . (if not (null s) then showString ": " . showString s else id) +-- | The exception thrown when an infinite cycle is detected in +-- 'System.IO.fixIO'. +-- +-- @since 4.11.0.0 +data FixIOException = FixIOException + +-- | @since 4.11.0.0 +instance Exception FixIOException + +-- | @since 4.11.0.0 +instance Show FixIOException where + showsPrec _ FixIOException = showString "cyclic evaluation in fixIO" + -- ----------------------------------------------------------------------------- -- The ExitCode type diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index 8eafe08fdc..d5567f0838 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -45,6 +45,7 @@ import GHC.Conc.IO import GHC.IO.Exception #if defined(mingw32_HOST_OS) import GHC.Windows +import Data.Bool #endif import Foreign @@ -179,14 +180,10 @@ openFile filepath iomode non_blocking = | otherwise = oflags2 in do - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- directories. However, the man pages I've read say that open() - -- always returns EISDIR if the file is a directory and was opened - -- for writing, so I think we're ok with a single open() here... - fd <- throwErrnoIfMinus1Retry "openFile" - (if non_blocking then c_open f oflags 0o666 - else c_safe_open f oflags 0o666) + -- NB. always use a safe open(), because we don't know whether open() + -- will be fast or not. It can be slow on NFS and FUSE filesystems, + -- for example. + fd <- throwErrnoIfMinus1Retry "openFile" $ c_safe_open f oflags 0o666 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-} False{-not a socket-} @@ -405,7 +402,7 @@ ready fd write msecs = do return (toEnum (fromIntegral r)) foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt -- --------------------------------------------------------------------------- -- Terminal-related stuff @@ -566,7 +563,7 @@ isNonBlocking :: FD -> Bool isNonBlocking fd = fdIsNonBlocking fd /= 0 foreign import ccall unsafe "fdReady" - unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt #else /* mingw32_HOST_OS.... */ @@ -593,8 +590,10 @@ asyncReadRawBufferPtr loc !fd !buf !off !len = do (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt @@ -602,34 +601,46 @@ asyncWriteRawBufferPtr loc !fd !buf !off !len = do (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) -- Blocking versions of the read/write primitives, for the threaded RTS blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt blockingReadRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len) + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0 + read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len) + r <- bool read_ret recv_ret (fdIsSocket fd) + when ((fdIsSocket fd) && (r == -1)) c_maperrno + return r + -- We trust read() to give us the correct errno but recv(), as a + -- Winsock function, doesn't do the errno conversion so if the fd + -- is for a socket, we do it from GetLastError() ourselves. blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt blockingWriteRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else do - r <- c_safe_write (fdFD fd) (buf `plusPtr` off) (fromIntegral len) - when (r == -1) c_maperrno - return r - -- we don't trust write() to give us the correct errno, and + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0 + write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len) + r <- bool write_ret send_ret (fdIsSocket fd) + when (r == -1) c_maperrno + return r + -- We don't trust write() to give us the correct errno, and -- instead do the errno conversion from GetLastError() - -- ourselves. The main reason is that we treat ERROR_NO_DATA + -- ourselves. The main reason is that we treat ERROR_NO_DATA -- (pipe is closing) as EPIPE, whereas write() returns EINVAL - -- for this case. We need to detect EPIPE correctly, because it + -- for this case. We need to detect EPIPE correctly, because it -- shouldn't be reported as an error when it happens on stdout. + -- As for send()'s case, Winsock functions don't do errno + -- conversion in any case so we have to do it ourselves. + -- That means we're doing the errno conversion no matter if the + -- fd is from a socket or not. -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs index 648523a11f..01c226dfbd 100644 --- a/libraries/base/GHC/IO/Handle.hs +++ b/libraries/base/GHC/IO/Handle.hs @@ -183,7 +183,7 @@ isEOF = hIsEOF stdin -- -- This operation may fail with: -- --- * 'isEOFError' if the end of file has been reached. +-- * 'System.IO.Error.isEOFError' if the end of file has been reached. hLookAhead :: Handle -> IO Char hLookAhead handle = @@ -208,9 +208,9 @@ hLookAhead handle = -- -- This operation may fail with: -- --- * 'isPermissionError' if the handle has already been used for reading --- or writing and the implementation does not allow the buffering mode --- to be changed. +-- * 'System.IO.Error.isPermissionError' if the handle has already been used +-- for reading or writing and the implementation does not allow the +-- buffering mode to be changed. hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = @@ -251,8 +251,8 @@ hSetBuffering handle mode = -- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding -- for the handle @hdl@ to @encoding@. The default encoding when a 'Handle' is --- created is 'localeEncoding', namely the default encoding for the current --- locale. +-- created is 'System.IO.localeEncoding', namely the default encoding for the +-- current locale. -- -- To create a 'Handle' with no encoding at all, use 'openBinaryFile'. To -- stop further encoding or decoding on an existing 'Handle', use @@ -295,11 +295,11 @@ hGetEncoding hdl = -- -- This operation may fail with: -- --- * 'isFullError' if the device is full; +-- * 'System.IO.Error.isFullError' if the device is full; -- --- * 'isPermissionError' if a system resource limit would be exceeded. --- It is unspecified whether the characters in the buffer are discarded --- or retained under these circumstances. +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. It is unspecified whether the characters in the buffer are +-- discarded or retained under these circumstances. hFlush :: Handle -> IO () hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer @@ -312,14 +312,14 @@ hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer -- -- This operation may fail with: -- --- * 'isFullError' if the device is full; +-- * 'System.IO.Error.isFullError' if the device is full; -- --- * 'isPermissionError' if a system resource limit would be exceeded. --- It is unspecified whether the characters in the buffer are discarded --- or retained under these circumstances; +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. It is unspecified whether the characters in the buffer are +-- discarded or retained under these circumstances; -- --- * 'isIllegalOperation' if @hdl@ has buffered read data, and is not --- seekable. +-- * 'System.IO.Error.isIllegalOperation' if @hdl@ has buffered read data, and +-- is not seekable. hFlushAll :: Handle -> IO () hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer @@ -358,7 +358,8 @@ hGetPosn handle = do -- -- This operation may fail with: -- --- * 'isPermissionError' if a system resource limit would be exceeded. +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. hSetPosn :: HandlePosn -> IO () hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i @@ -391,10 +392,11 @@ hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i -- -- This operation may fail with: -- --- * 'isIllegalOperationError' if the Handle is not seekable, or does --- not support the requested seek mode. +-- * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable, +-- or does not support the requested seek mode. -- --- * 'isPermissionError' if a system resource limit would be exceeded. +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. hSeek :: Handle -> SeekMode -> Integer -> IO () hSeek handle mode offset = @@ -425,7 +427,7 @@ hSeek handle mode offset = -- -- This operation may fail with: -- --- * 'isIllegalOperationError' if the Handle is not seekable. +-- * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable. -- hTell :: Handle -> IO Integer hTell handle = diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs index 786fccc4f1..883bc5fe59 100644 --- a/libraries/base/GHC/IO/Handle/FD.hs +++ b/libraries/base/GHC/IO/Handle/FD.hs @@ -128,11 +128,13 @@ addFilePathToIOError fun fp ioe -- -- This operation may fail with: -- --- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; +-- * 'System.IO.Error.isAlreadyInUseError' if the file is already open and +-- cannot be reopened; -- --- * 'isDoesNotExistError' if the file does not exist; or +-- * 'System.IO.Error.isDoesNotExistError' if the file does not exist; or -- --- * 'isPermissionError' if the user does not have permission to open the file. +-- * 'System.IO.Error.isPermissionError' if the user does not have permission +-- to open the file. -- -- Note: if you will be working with files containing binary data, you'll want to -- be using 'openBinaryFile'. @@ -161,7 +163,7 @@ openFileBlocking fp im = -- this is undesirable; also, as usual under Microsoft operating systems, -- text mode treats control-Z as EOF. Binary mode turns off all special -- treatment of end-of-line and end-of-file characters. --- (See also 'hSetBinaryMode'.) +-- (See also 'System.IO.hSetBinaryMode'.) openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc index ec62f86cc9..ec85ffd25e 100644 --- a/libraries/base/GHC/IO/Handle/Lock.hsc +++ b/libraries/base/GHC/IO/Handle/Lock.hsc @@ -8,6 +8,7 @@ module GHC.IO.Handle.Lock ( , LockMode(..) , hLock , hTryLock + , hUnlock ) where #include "HsBaseConfig.h" @@ -62,8 +63,9 @@ import GHC.Show -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported - deriving Show + deriving Show -- ^ @since 4.10.0.0 +-- ^ @since 4.10.0.0 instance Exception FileLockingNotSupported -- | Indicates a mode in which a file should be locked. @@ -97,9 +99,82 @@ hLock h mode = void $ lockImpl h "hLock" mode True hTryLock :: Handle -> LockMode -> IO Bool hTryLock h mode = lockImpl h "hTryLock" mode False +-- | Release a lock taken with 'hLock' or 'hTryLock'. +hUnlock :: Handle -> IO () +hUnlock = unlockImpl + ---------------------------------------- -#if HAVE_FLOCK +#if HAVE_OFD_LOCKING +-- Linux open file descriptor locking. +-- +-- We prefer this over BSD locking (e.g. flock) since the latter appears to +-- break in some NFS configurations. Note that we intentionally do not try to +-- use ordinary POSIX file locking due to its peculiar semantics under +-- multi-threaded environments. + +foreign import ccall interruptible "fcntl" + c_fcntl :: CInt -> CInt -> Ptr () -> IO CInt + +data FLock = FLock { l_type :: CShort + , l_whence :: CShort + , l_start :: COff + , l_len :: COff + , l_pid :: CPid + } + +instance Storable FLock where + sizeOf _ = #{size flock} + alignment _ = #{alignment flock} + poke ptr x = do + fillBytes ptr 0 (sizeOf x) + #{poke flock, l_type} ptr (l_type x) + #{poke flock, l_whence} ptr (l_whence x) + #{poke flock, l_start} ptr (l_start x) + #{poke flock, l_len} ptr (l_len x) + #{poke flock, l_pid} ptr (l_pid x) + peek ptr = do + FLock <$> #{peek flock, l_type} ptr + <*> #{peek flock, l_whence} ptr + <*> #{peek flock, l_start} ptr + <*> #{peek flock, l_len} ptr + <*> #{peek flock, l_pid} ptr + +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl h ctx mode block = do + FD{fdFD = fd} <- handleToFd h + with flock $ \flock_ptr -> fix $ \retry -> do + ret <- with flock $ fcntl fd mode flock_ptr + case ret of + 0 -> return True + _ -> getErrno >>= \errno -> if + | not block && errno == eWOULDBLOCK -> return False + | errno == eINTR -> retry + | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing + where + flock = FLock { l_type = case mode of + SharedLock -> #{const F_RDLCK} + ExclusiveLock -> #{const F_WRLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + mode + | block = #{const F_SETLKW} + | otherwise = #{const F_SETLK} + +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + let flock = FLock { l_type = #{const F_UNLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + throwErrnoIfMinus1_ "hUnlock" + $ with flock $ c_fcntl fd #{const F_SETLK} + +#elif HAVE_FLOCK lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do @@ -108,7 +183,8 @@ lockImpl h ctx mode block = do fix $ \retry -> c_flock fd flags >>= \case 0 -> return True _ -> getErrno >>= \errno -> if - | not block && errno == eWOULDBLOCK -> return False + | not block + , errno == eAGAIN || errno == eACCES -> return False | errno == eINTR -> retry | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing where @@ -116,6 +192,11 @@ lockImpl h ctx mode block = do SharedLock -> #{const LOCK_SH} ExclusiveLock -> #{const LOCK_EX} +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN} + foreign import ccall interruptible "flock" c_flock :: CInt -> CInt -> IO CInt @@ -146,6 +227,18 @@ lockImpl h ctx mode block = do SharedLock -> 0 ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd + allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do + fillBytes ovrlpd 0 sizeof_OVERLAPPED + c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case + True -> return () + False -> getLastError >>= failWith "hUnlock" + where + sizeof_OVERLAPPED = #{size OVERLAPPED} + -- https://msdn.microsoft.com/en-us/library/aa297958.aspx foreign import ccall unsafe "_get_osfhandle" c_get_osfhandle :: CInt -> IO HANDLE @@ -154,10 +247,18 @@ foreign import ccall unsafe "_get_osfhandle" foreign import WINDOWS_CCONV interruptible "LockFileEx" c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx +foreign import WINDOWS_CCONV interruptible "UnlockFileEx" + c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL + #else -- | No-op implementation. lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl _ _ _ _ = throwIO FileLockingNotSupported +-- | No-op implementation. +unlockImpl :: Handle -> IO () +unlockImpl _ = throwIO FileLockingNotSupported + #endif diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs index 57b9534976..dcf4b7c174 100644 --- a/libraries/base/GHC/IO/Handle/Text.hs +++ b/libraries/base/GHC/IO/Handle/Text.hs @@ -353,10 +353,10 @@ unpack_nl !buf !r !w acc0 -- list returned by 'hGetContents' @hdl@. -- -- Any operation that fails because a handle is closed, --- also fails if a handle is semi-closed. The only exception is 'hClose'. --- A semi-closed handle becomes closed: +-- also fails if a handle is semi-closed. The only exception is +-- 'System.IO.hClose'. A semi-closed handle becomes closed: -- --- * if 'hClose' is applied to it; +-- * if 'System.IO.hClose' is applied to it; -- -- * if an I\/O error occurs when reading an item from the handle; -- @@ -537,6 +537,7 @@ hPutStrLn handle str = hPutStr' handle str True -- overhead of a single putChar '\n', which is quite high now that we -- have to encode eagerly. +{-# NOINLINE hPutStr' #-} hPutStr' :: Handle -> String -> Bool -> IO () hPutStr' handle str add_nl = do @@ -683,7 +684,7 @@ commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..} -- 'hPutBuf' ignores any text encoding that applies to the 'Handle', -- writing the bytes directly to the underlying file or device. -- --- 'hPutBuf' ignores the prevailing 'TextEncoding' and +-- 'hPutBuf' ignores the prevailing 'System.IO.TextEncoding' and -- 'NewlineMode' on the 'Handle', and writes bytes directly. -- -- This operation may fail with: @@ -803,11 +804,11 @@ writeChunkNonBlocking h_@Handle__{..} ptr bytes -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBuf' will behave as if EOF was reached. -- --- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode' +-- 'hGetBuf' ignores the prevailing 'System.IO.TextEncoding' and 'NewlineMode' -- on the 'Handle', and reads bytes directly. hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf h ptr count +hGetBuf h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = @@ -885,11 +886,11 @@ bufReadEmpty h_@Handle__{..} -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBufSome' will behave as if EOF was reached. -- --- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode' --- on the 'Handle', and reads bytes directly. +-- 'hGetBufSome' ignores the prevailing 'System.IO.TextEncoding' and +-- 'NewlineMode' on the 'Handle', and reads bytes directly. hGetBufSome :: Handle -> Ptr a -> Int -> IO Int -hGetBufSome h ptr count +hGetBufSome h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBufSome" count | otherwise = @@ -927,14 +928,14 @@ haFD h_@Handle__{..} = cast haDevice -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. -- --- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and +-- 'hGetBufNonBlocking' ignores the prevailing 'System.IO.TextEncoding' and -- 'NewlineMode' on the 'Handle', and reads bytes directly. -- -- NOTE: on Windows, this function does not work correctly; it -- behaves identically to 'hGetBuf'. hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count +hGetBufNonBlocking h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count | otherwise = diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs index c58a9fb1b0..d38962e77e 100644 --- a/libraries/base/GHC/IO/Handle/Types.hs +++ b/libraries/base/GHC/IO/Handle/Types.hs @@ -247,7 +247,11 @@ data BufferMode -- ^ block-buffering should be enabled if possible. -- The size of the buffer is @n@ items if the argument -- is 'Just' @n@ and is otherwise implementation-dependent. - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) {- [note Buffering Implementation] @@ -349,7 +353,11 @@ and hence it is only possible on a seekable Handle. -- | The representation of a newline in the external file or stream. data Newline = LF -- ^ '\n' | CRLF -- ^ '\r\n' - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | Specifies the translation, if any, of newline characters between -- internal Strings and the external file or stream. Haskell Strings @@ -362,7 +370,11 @@ data NewlineMode outputNL :: Newline -- ^ the representation of newlines on output } - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | The native newline representation for the current platform: 'LF' -- on Unix systems, 'CRLF' on Windows. diff --git a/libraries/base/GHC/IO/IOMode.hs b/libraries/base/GHC/IO/IOMode.hs index 42cc9f31b1..7eb848f50a 100644 --- a/libraries/base/GHC/IO/IOMode.hs +++ b/libraries/base/GHC/IO/IOMode.hs @@ -26,5 +26,11 @@ import GHC.Enum -- | See 'System.IO.openFile' data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Ix -- ^ @since 4.2.0.0 + , Enum -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) diff --git a/libraries/base/GHC/IO/Unsafe.hs b/libraries/base/GHC/IO/Unsafe.hs index c1c07ae2df..039acfe85b 100644 --- a/libraries/base/GHC/IO/Unsafe.hs +++ b/libraries/base/GHC/IO/Unsafe.hs @@ -96,7 +96,8 @@ times (on a multiprocessor), and you should therefore ensure that it gives the same results each time. It may even happen that one of the duplicated IO actions is only run partially, and then interrupted in the middle without an exception being raised. Therefore, functions -like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'. +like 'Control.Exception.bracket' cannot be used safely within +'unsafeDupablePerformIO'. @since 4.4.0.0 -} diff --git a/libraries/base/GHC/IORef.hs b/libraries/base/GHC/IORef.hs index 0832be04cf..d04ae728fd 100644 --- a/libraries/base/GHC/IORef.hs +++ b/libraries/base/GHC/IORef.hs @@ -1,6 +1,7 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -19,7 +20,9 @@ module GHC.IORef ( IORef(..), - newIORef, readIORef, writeIORef, atomicModifyIORef + newIORef, readIORef, writeIORef, atomicModifyIORef2Lazy, + atomicModifyIORef2, atomicModifyIORefLazy_, atomicModifyIORef'_, + atomicModifyIORefP, atomicSwapIORef, atomicModifyIORef' ) where import GHC.Base @@ -31,7 +34,7 @@ import GHC.IO -- |A mutable variable in the 'IO' monad newtype IORef a = IORef (STRef RealWorld a) - deriving Eq + deriving Eq -- ^ @since 4.2.0.0 -- ^ Pointer equality. -- -- @since 4.1.0.0 @@ -48,6 +51,120 @@ readIORef (IORef var) = stToIO (readSTRef var) writeIORef :: IORef a -> a -> IO () writeIORef (IORef var) v = stToIO (writeSTRef var v) -atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s +-- Atomically apply a function to the contents of an 'IORef', +-- installing its first component in the 'IORef' and returning +-- the old contents and the result of applying the function. +-- The result of the function application (the pair) is not forced. +-- As a result, this can lead to memory leaks. It is generally better +-- to use 'atomicModifyIORef2'. +atomicModifyIORef2Lazy :: IORef a -> (a -> (a,b)) -> IO (a, (a, b)) +atomicModifyIORef2Lazy (IORef (STRef r#)) f = + IO (\s -> case atomicModifyMutVar2# r# f s of + (# s', old, res #) -> (# s', (old, res) #)) +-- Atomically apply a function to the contents of an 'IORef', +-- installing its first component in the 'IORef' and returning +-- the old contents and the result of applying the function. +-- The result of the function application (the pair) is forced, +-- but neither of its components is. +atomicModifyIORef2 :: IORef a -> (a -> (a,b)) -> IO (a, (a, b)) +atomicModifyIORef2 ref f = do + r@(_old, (_new, _res)) <- atomicModifyIORef2Lazy ref f + return r + +-- | A version of 'Data.IORef.atomicModifyIORef' that forces +-- the (pair) result of the function. +atomicModifyIORefP :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORefP ref f = do + (_old, (_,r)) <- atomicModifyIORef2 ref f + pure r + +-- | Atomically apply a function to the contents of an +-- 'IORef' and return the old and new values. The result +-- of the function is not forced. As this can lead to a +-- memory leak, it is usually better to use `atomicModifyIORef'_`. +atomicModifyIORefLazy_ :: IORef a -> (a -> a) -> IO (a, a) +atomicModifyIORefLazy_ (IORef (STRef ref)) f = IO $ \s -> + case atomicModifyMutVar_# ref f s of + (# s', old, new #) -> (# s', (old, new) #) + +-- | Atomically apply a function to the contents of an +-- 'IORef' and return the old and new values. The result +-- of the function is forced. +atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO (a, a) +atomicModifyIORef'_ ref f = do + (old, !new) <- atomicModifyIORefLazy_ ref f + return (old, new) + +-- | Atomically replace the contents of an 'IORef', returning +-- the old contents. +atomicSwapIORef :: IORef a -> a -> IO a +-- Bad implementation! This will be a primop shortly. +atomicSwapIORef (IORef (STRef ref)) new = IO $ \s -> + case atomicModifyMutVar2# ref (\_old -> Box new) s of + (# s', old, Box _new #) -> (# s', old #) + +data Box a = Box a + +-- | Strict version of 'Data.IORef.atomicModifyIORef'. This forces both +-- the value stored in the 'IORef' and the value returned. The new value +-- is installed in the 'IORef' before the returned value is forced. +-- So +-- +-- @atomicModifyIORef' ref (\x -> (x+1, undefined))@ +-- +-- will increment the 'IORef' and then throw an exception in the calling +-- thread. +-- +-- @since 4.6.0.0 +atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +-- See Note [atomicModifyIORef' definition] +atomicModifyIORef' ref f = do + (_old, (_new, !res)) <- atomicModifyIORef2 ref $ + \old -> case f old of + r@(!_new, _res) -> r + pure res + +-- Note [atomicModifyIORef' definition] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- atomicModifyIORef' was historically defined +-- +-- atomicModifyIORef' ref f = do +-- b <- atomicModifyIORef ref $ \a -> +-- case f a of +-- v@(a',_) -> a' `seq` v +-- b `seq` return b +-- +-- The most obvious definition, now that we have atomicModifyMutVar2#, +-- would be +-- +-- atomicModifyIORef' ref f = do +-- (_old, (!_new, !res)) <- atomicModifyIORef2 ref f +-- pure res +-- +-- Why do we force the new value on the "inside" instead of afterwards? +-- I initially thought the latter would be okay, but then I realized +-- that if we write +-- +-- atomicModifyIORef' ref $ \x -> (x + 5, x - 5) +-- +-- then we'll end up building a pair of thunks to calculate x + 5 +-- and x - 5. That's no good! With the more complicated definition, +-- we avoid this problem; the result pair is strict in the new IORef +-- contents. Of course, if the function passed to atomicModifyIORef' +-- doesn't inline, we'll build a closure for it. But that was already +-- true for the historical definition of atomicModifyIORef' (in terms +-- of atomicModifyIORef), so we shouldn't lose anything. Note that +-- in keeping with the historical behavior, we *don't* propagate the +-- strict demand on the result inwards. In particular, +-- +-- atomicModifyIORef' ref (\x -> (x + 1, undefined)) +-- +-- will increment the IORef and throw an exception; it will not +-- install an undefined value in the IORef. +-- +-- A clearer version, in my opinion (but one quite incompatible with +-- the traditional one) would only force the new IORef value and not +-- the result. This version would have been relatively inefficient +-- to implement using atomicModifyMutVar#, but is just fine now. diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index ad2a872c39..9bc161105d 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -1082,6 +1082,36 @@ instance Ix Int64 where unsafeIndex (m,_) i = fromIntegral i - fromIntegral m inRange (m,n) i = m <= i && i <= n +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Int8" + fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt +"fromIntegral/Natural->Int16" + fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt +"fromIntegral/Natural->Int32" + fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt + #-} + +{-# RULES +"fromIntegral/Int8->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) +"fromIntegral/Int16->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) +"fromIntegral/Int32->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 & Int==Int64 +{-# RULES +"fromIntegral/Natural->Int64" + fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt +"fromIntegral/Int64->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) + #-} +#endif + {- Note [Order of tests] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs index 70bfbe4de0..92b5952cbe 100644 --- a/libraries/base/GHC/List.hs +++ b/libraries/base/GHC/List.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -23,7 +22,7 @@ module GHC.List ( map, (++), filter, concat, head, last, tail, init, uncons, null, length, (!!), foldl, foldl', foldl1, foldl1', scanl, scanl1, scanl', foldr, foldr1, - scanr, scanr1, iterate, repeat, replicate, cycle, + scanr, scanr1, iterate, iterate', repeat, replicate, cycle, take, drop, sum, product, maximum, minimum, splitAt, takeWhile, dropWhile, span, break, reverse, and, or, any, all, elem, notElem, lookup, @@ -442,7 +441,10 @@ minimum xs = foldl1 min xs -- of @f@ to @x@: -- -- > iterate f x == [x, f x, f (f x), ...] - +-- +-- Note that 'iterate' is lazy, potentially leading to thunk build-up if +-- the consumer doesn't force each iterate. See 'iterate'' for a strict +-- variant of this function. {-# NOINLINE [1] iterate #-} iterate :: (a -> a) -> a -> [a] iterate f x = x : iterate f (f x) @@ -458,6 +460,29 @@ iterateFB c f x0 = go x0 #-} +-- | 'iterate'' is the strict version of 'iterate'. +-- +-- It ensures that the result of each application of force to weak head normal +-- form before proceeding. +{-# NOINLINE [1] iterate' #-} +iterate' :: (a -> a) -> a -> [a] +iterate' f x = + let x' = f x + in x' `seq` (x : iterate' f x') + +{-# INLINE [0] iterate'FB #-} -- See Note [Inline FB functions] +iterate'FB :: (a -> b -> b) -> (a -> a) -> a -> b +iterate'FB c f x0 = go x0 + where go x = + let x' = f x + in x' `seq` (x `c` go x') + +{-# RULES +"iterate'" [~1] forall f x. iterate' f x = build (\c _n -> iterate'FB c f x) +"iterate'FB" [1] iterate'FB (:) = iterate' + #-} + + -- | 'repeat' @x@ is an infinite list, with @x@ the value of every element. repeat :: a -> [a] {-# INLINE [0] repeat #-} @@ -921,12 +946,19 @@ foldr2_left k _z x r (y:ys) = k x y (r ys) ---------------------------------------------- -- | 'zip' takes two lists and returns a list of corresponding pairs. +-- +-- > zip [1, 2] ['a', 'b'] = [(1, 'a'), (2, 'b')] +-- -- If one input list is short, excess elements of the longer list are --- discarded. +-- discarded: +-- +-- > zip [1] ['a', 'b'] = [(1, 'a')] +-- > zip [1, 2] ['a'] = [(1, 'a')] -- -- 'zip' is right-lazy: -- -- > zip [] _|_ = [] +-- > zip _|_ [] = _|_ {-# NOINLINE [1] zip #-} zip :: [a] -> [b] -> [(a,b)] zip [] _bs = [] @@ -966,9 +998,11 @@ zip3 _ _ _ = [] -- > zipWith f [] _|_ = [] {-# NOINLINE [1] zipWith #-} zipWith :: (a->b->c) -> [a]->[b]->[c] -zipWith _f [] _bs = [] -zipWith _f _as [] = [] -zipWith f (a:as) (b:bs) = f a b : zipWith f as bs +zipWith f = go + where + go [] _ = [] + go _ [] = [] + go (x:xs) (y:ys) = f x y : go xs ys -- zipWithFB must have arity 2 since it gets two arguments in the "zipWith" -- rule; it might not get inlined otherwise @@ -985,9 +1019,10 @@ zipWithFB c f = \x y r -> (x `f` y) `c` r -- elements, as well as three lists and returns a list of their point-wise -- combination, analogous to 'zipWith'. zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith3 z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3 z as bs cs -zipWith3 _ _ _ _ = [] +zipWith3 z = go + where + go (a:as) (b:bs) (c:cs) = z a b c : go as bs cs + go _ _ _ = [] -- | 'unzip' transforms a list of pairs into a list of first components -- and a list of second components. diff --git a/libraries/base/GHC/MVar.hs b/libraries/base/GHC/MVar.hs index d367f2ba06..aa5900200a 100644 --- a/libraries/base/GHC/MVar.hs +++ b/libraries/base/GHC/MVar.hs @@ -38,7 +38,7 @@ data MVar a = MVar (MVar# RealWorld a) {- ^ An 'MVar' (pronounced \"em-var\") is a synchronising variable, used for communication between concurrent threads. It can be thought of -as a a box, which may be empty or full. +as a box, which may be empty or full. -} -- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module @@ -90,7 +90,7 @@ takeMVar :: MVar a -> IO a takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# -- |Atomically read the contents of an 'MVar'. If the 'MVar' is --- currently empty, 'readMVar' will wait until its full. +-- currently empty, 'readMVar' will wait until it is full. -- 'readMVar' is guaranteed to receive the next 'putMVar'. -- -- 'readMVar' is multiple-wakeup, so when multiple readers are diff --git a/libraries/base/GHC/Maybe.hs b/libraries/base/GHC/Maybe.hs new file mode 100644 index 0000000000..2bdfac54a2 --- /dev/null +++ b/libraries/base/GHC/Maybe.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Maybe type +module GHC.Maybe + ( Maybe (..) + ) +where + +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base +import GHC.Classes + +default () + +------------------------------------------------------------------------------- +-- Maybe type +------------------------------------------------------------------------------- + +-- | The 'Maybe' type encapsulates an optional value. A value of type +-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic +-- measures such as 'Prelude.error'. +-- +-- The 'Maybe' type is also a monad. It is a simple kind of error +-- monad, where all errors are represented by 'Nothing'. A richer +-- error monad can be built using the 'Data.Either.Either' type. +-- +data Maybe a = Nothing | Just a + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index 0e5abc77bc..71511d37b3 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -1,12 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | @@ -34,44 +30,76 @@ module GHC.Natural -- (i.e. which constructors are available) depends on the -- 'Integer' backend used! Natural(..) + , mkNatural , isValidNatural + -- * Arithmetic + , plusNatural + , minusNatural + , minusNaturalMaybe + , timesNatural + , negateNatural + , signumNatural + , quotRemNatural + , quotNatural + , remNatural +#if defined(MIN_VERSION_integer_gmp) + , gcdNatural + , lcmNatural +#endif + -- * Bits + , andNatural + , orNatural + , xorNatural + , bitNatural + , testBitNatural +#if defined(MIN_VERSION_integer_gmp) + , popCountNatural +#endif + , shiftLNatural + , shiftRNatural -- * Conversions + , naturalToInteger + , naturalToWord + , naturalToInt , naturalFromInteger , wordToNatural + , intToNatural , naturalToWordMaybe - -- * Checked subtraction - , minusNaturalMaybe + , wordToNatural# + , wordToNaturalBase -- * Modular arithmetic , powModNatural ) where #include "MachDeps.h" +import GHC.Classes +import GHC.Maybe +import GHC.Types +import GHC.Prim +import {-# SOURCE #-} GHC.Exception.Type (underflowException, divZeroException) #if defined(MIN_VERSION_integer_gmp) -# define HAVE_GMP_BIGNAT MIN_VERSION_integer_gmp(1,0,0) -#else -# define HAVE_GMP_BIGNAT 0 -#endif - -import GHC.Arr -import GHC.Base -import {-# SOURCE #-} GHC.Exception (underflowException) -#if HAVE_GMP_BIGNAT import GHC.Integer.GMP.Internals -import Data.Word -import Data.Int +#else +import GHC.Integer #endif -import GHC.Num -import GHC.Real -import GHC.Read -import GHC.Show -import GHC.Enum -import GHC.List - -import Data.Bits default () +-- Most high-level operations need to be marked `NOINLINE` as +-- otherwise GHC doesn't recognize them and fails to apply constant +-- folding to `Natural`-typed expression. +-- +-- To this end, the CPP hack below allows to write the pseudo-pragma +-- +-- {-# CONSTANT_FOLDED plusNatural #-} +-- +-- which is simply expanded into a +-- +-- {-# NOINLINE plusNatural #-} +-- +#define CONSTANT_FOLDED NOINLINE + ------------------------------------------------------------------------------- -- Arithmetic underflow ------------------------------------------------------------------------------- @@ -83,17 +111,27 @@ default () underflowError :: a underflowError = raise# underflowException +{-# NOINLINE divZeroError #-} +divZeroError :: a +divZeroError = raise# divZeroException + ------------------------------------------------------------------------------- -- Natural type ------------------------------------------------------------------------------- -#if HAVE_GMP_BIGNAT +#if defined(MIN_VERSION_integer_gmp) -- TODO: if saturated arithmetic is to used, replace 'underflowError' by '0' -- | Type representing arbitrary-precision non-negative integers. -- --- Operations whose result would be negative --- @'throw' ('Underflow' :: 'ArithException')@. +-- >>> 2^100 :: Natural +-- 1267650600228229401496703205376 +-- +-- Operations whose result would be negative @'Control.Exception.throw' +-- ('Control.Exception.Underflow' :: 'Control.Exception.ArithException')@, +-- +-- >>> -1 :: Natural +-- *** Exception: arithmetic underflow -- -- @since 4.8.0.0 data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ @@ -102,8 +140,12 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ -- __Invariant__: 'NatJ#' is used -- /iff/ value doesn't fit in -- 'NatS#' constructor. - deriving (Eq,Ord) -- NB: Order of constructors *must* + -- NB: Order of constructors *must* -- coincide with 'Ord' relation + deriving ( Eq -- ^ @since 4.8.0.0 + , Ord -- ^ @since 4.8.0.0 + ) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- @@ -114,107 +156,32 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ isValidNatural :: Natural -> Bool isValidNatural (NatS# _) = True isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn) - && I# (sizeofBigNat# bn) > 0 - -{-# RULES -"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural -"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer -"fromIntegral/Natural->Word" fromIntegral = naturalToWord -"fromIntegral/Natural->Word8" - fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord -"fromIntegral/Natural->Word16" - fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord -"fromIntegral/Natural->Word32" - fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord -"fromIntegral/Natural->Int8" - fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt -"fromIntegral/Natural->Int16" - fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt -"fromIntegral/Natural->Int32" - fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt - #-} - -{-# RULES -"fromIntegral/Word->Natural" fromIntegral = wordToNatural -"fromIntegral/Word8->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) -"fromIntegral/Word16->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) -"fromIntegral/Word32->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) -"fromIntegral/Int->Natural" fromIntegral = intToNatural -"fromIntegral/Int8->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) -"fromIntegral/Int16->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) -"fromIntegral/Int32->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) - #-} - -#if WORD_SIZE_IN_BITS == 64 --- these RULES are valid for Word==Word64 & Int==Int64 -{-# RULES -"fromIntegral/Natural->Word64" - fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord -"fromIntegral/Natural->Int64" - fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt -"fromIntegral/Word64->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) -"fromIntegral/Int64->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) - #-} -#endif - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec p (NatS# w#) = showsPrec p (W# w#) - showsPrec p (NatJ# bn) = showsPrec p (Jp# bn) - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (fromInteger n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Num Natural where - fromInteger = naturalFromInteger + && isTrue# (sizeofBigNat# bn ># 0#) - (+) = plusNatural - (*) = timesNatural - (-) = minusNatural +signumNatural :: Natural -> Natural +signumNatural (NatS# 0##) = NatS# 0## +signumNatural _ = NatS# 1## +{-# CONSTANT_FOLDED signumNatural #-} - abs = id - - signum (NatS# 0##) = NatS# 0## - signum _ = NatS# 1## - - negate (NatS# 0##) = NatS# 0## - negate _ = underflowError +negateNatural :: Natural -> Natural +negateNatural (NatS# 0##) = NatS# 0## +negateNatural _ = underflowError +{-# CONSTANT_FOLDED negateNatural #-} -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural -naturalFromInteger (S# i#) | I# i# >= 0 = NatS# (int2Word# i#) -naturalFromInteger (Jp# bn) = bigNatToNatural bn -naturalFromInteger _ = underflowError -{-# INLINE naturalFromInteger #-} - --- | @since 4.8.0.0 -instance Real Natural where - toRational (NatS# w) = toRational (W# w) - toRational (NatJ# bn) = toRational (Jp# bn) - -#if OPTIMISE_INTEGER_GCD_LCM -{-# RULES -"gcd/Natural->Natural->Natural" gcd = gcdNatural -"lcm/Natural->Natural->Natural" lcm = lcmNatural - #-} +naturalFromInteger (S# i#) + | isTrue# (i# >=# 0#) = NatS# (int2Word# i#) +naturalFromInteger (Jp# bn) = bigNatToNatural bn +naturalFromInteger _ = underflowError +{-# CONSTANT_FOLDED naturalFromInteger #-} -- | Compute greatest common divisor. gcdNatural :: Natural -> Natural -> Natural gcdNatural (NatS# 0##) y = y gcdNatural x (NatS# 0##) = x -gcdNatural (NatS# 1##) _ = (NatS# 1##) -gcdNatural _ (NatS# 1##) = (NatS# 1##) +gcdNatural (NatS# 1##) _ = NatS# 1## +gcdNatural _ (NatS# 1##) = NatS# 1## gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y) gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y) gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x) @@ -222,149 +189,107 @@ gcdNatural (NatS# x) (NatS# y) = NatS# (gcdWord x y) -- | compute least common multiplier. lcmNatural :: Natural -> Natural -> Natural -lcmNatural (NatS# 0##) _ = (NatS# 0##) -lcmNatural _ (NatS# 0##) = (NatS# 0##) +lcmNatural (NatS# 0##) _ = NatS# 0## +lcmNatural _ (NatS# 0##) = NatS# 0## lcmNatural (NatS# 1##) y = y lcmNatural x (NatS# 1##) = x -lcmNatural x y = (x `quot` (gcdNatural x y)) * y - -#endif - --- | @since 4.8.0.0 -instance Enum Natural where - succ n = n `plusNatural` NatS# 1## - pred n = n `minusNatural` NatS# 1## - - toEnum = intToNatural - - fromEnum (NatS# w) | i >= 0 = i - where - i = fromIntegral (W# w) - fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range" - - enumFrom x = enumDeltaNatural x (NatS# 1##) - enumFromThen x y - | x <= y = enumDeltaNatural x (y-x) - | otherwise = enumNegDeltaToNatural x (x-y) (NatS# 0##) - - enumFromTo x lim = enumDeltaToNatural x (NatS# 1##) lim - enumFromThenTo x y lim - | x <= y = enumDeltaToNatural x (y-x) lim - | otherwise = enumNegDeltaToNatural x (x-y) lim - ----------------------------------------------------------------------------- --- Helpers for 'Enum Natural'; TODO: optimise & make fusion work - -enumDeltaNatural :: Natural -> Natural -> [Natural] -enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d - -enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumDeltaToNatural x0 delta lim = go x0 - where - go x | x > lim = [] - | otherwise = x : go (x+delta) - -enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumNegDeltaToNatural x0 ndelta lim = go x0 - where - go x | x < lim = [] - | x >= ndelta = x : go (x-ndelta) - | otherwise = [x] +lcmNatural x y = (x `quotNatural` (gcdNatural x y)) `timesNatural` y ---------------------------------------------------------------------------- --- | @since 4.8.0.0 -instance Integral Natural where - toInteger (NatS# w) = wordToInteger w - toInteger (NatJ# bn) = Jp# bn - - divMod = quotRem - div = quot - mod = rem - - quotRem _ (NatS# 0##) = divZeroError - quotRem n (NatS# 1##) = (n,NatS# 0##) - quotRem n@(NatS# _) (NatJ# _) = (NatS# 0##, n) - quotRem (NatS# n) (NatS# d) = case quotRem (W# n) (W# d) of - (q,r) -> (wordToNatural q, wordToNatural r) - quotRem (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of - (# q,r #) -> (bigNatToNatural q, NatS# r) - quotRem (NatJ# n) (NatJ# d) = case quotRemBigNat n d of - (# q,r #) -> (bigNatToNatural q, bigNatToNatural r) - - quot _ (NatS# 0##) = divZeroError - quot n (NatS# 1##) = n - quot (NatS# _) (NatJ# _) = NatS# 0## - quot (NatS# n) (NatS# d) = wordToNatural (quot (W# n) (W# d)) - quot (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) - quot (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) - - rem _ (NatS# 0##) = divZeroError - rem _ (NatS# 1##) = NatS# 0## - rem n@(NatS# _) (NatJ# _) = n - rem (NatS# n) (NatS# d) = wordToNatural (rem (W# n) (W# d)) - rem (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) - rem (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) - --- | @since 4.8.0.0 -instance Ix Natural where - range (m,n) = [m..n] - inRange (m,n) i = m <= i && i <= n - unsafeIndex (m,_) i = fromIntegral (i-m) - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Natural" - - --- | @since 4.8.0.0 -instance Bits Natural where - NatS# n .&. NatS# m = wordToNatural (W# n .&. W# m) - NatS# n .&. NatJ# m = wordToNatural (W# n .&. W# (bigNatToWord m)) - NatJ# n .&. NatS# m = wordToNatural (W# (bigNatToWord n) .&. W# m) - NatJ# n .&. NatJ# m = bigNatToNatural (andBigNat n m) - - NatS# n .|. NatS# m = wordToNatural (W# n .|. W# m) - NatS# n .|. NatJ# m = NatJ# (orBigNat (wordToBigNat n) m) - NatJ# n .|. NatS# m = NatJ# (orBigNat n (wordToBigNat m)) - NatJ# n .|. NatJ# m = NatJ# (orBigNat n m) - - NatS# n `xor` NatS# m = wordToNatural (W# n `xor` W# m) - NatS# n `xor` NatJ# m = NatJ# (xorBigNat (wordToBigNat n) m) - NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m)) - NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m) - - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - - bitSizeMaybe _ = Nothing - bitSize = errorWithoutStackTrace "Natural: bitSize" - isSigned _ = False - - bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i) - | otherwise = NatJ# (bitBigNat i#) - - testBit (NatS# w) i = testBit (W# w) i - testBit (NatJ# bn) (I# i#) = testBitBigNat bn i# - - -- TODO: setBit, clearBit, complementBit (needs more primitives) - - shiftL n 0 = n - shiftL (NatS# 0##) _ = NatS# 0## - shiftL (NatS# 1##) i = bit i - shiftL (NatS# w) (I# i#) - = bigNatToNatural $ shiftLBigNat (wordToBigNat w) i# - shiftL (NatJ# bn) (I# i#) - = bigNatToNatural $ shiftLBigNat bn i# - - shiftR n 0 = n - shiftR (NatS# w) i = wordToNatural $ shiftR (W# w) i - shiftR (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) - - rotateL = shiftL - rotateR = shiftR - - popCount (NatS# w) = popCount (W# w) - popCount (NatJ# bn) = I# (popCountBigNat bn) - - zeroBits = NatS# 0## +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural _ (NatS# 0##) = divZeroError +quotRemNatural n (NatS# 1##) = (n,NatS# 0##) +quotRemNatural n@(NatS# _) (NatJ# _) = (NatS# 0##, n) +quotRemNatural (NatS# n) (NatS# d) = case quotRemWord# n d of + (# q, r #) -> (NatS# q, NatS# r) +quotRemNatural (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of + (# q, r #) -> (bigNatToNatural q, NatS# r) +quotRemNatural (NatJ# n) (NatJ# d) = case quotRemBigNat n d of + (# q, r #) -> (bigNatToNatural q, bigNatToNatural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural _ (NatS# 0##) = divZeroError +quotNatural n (NatS# 1##) = n +quotNatural (NatS# _) (NatJ# _) = NatS# 0## +quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d) +quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) +quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural _ (NatS# 0##) = divZeroError +remNatural _ (NatS# 1##) = NatS# 0## +remNatural n@(NatS# _) (NatJ# _) = n +remNatural (NatS# n) (NatS# d) = NatS# (remWord# n d) +remNatural (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) +remNatural (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) +{-# CONSTANT_FOLDED remNatural #-} + +-- | @since 4.X.0.0 +naturalToInteger :: Natural -> Integer +naturalToInteger (NatS# w) = wordToInteger w +naturalToInteger (NatJ# bn) = Jp# bn +{-# CONSTANT_FOLDED naturalToInteger #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (NatS# n) (NatS# m) = NatS# (n `and#` m) +andNatural (NatS# n) (NatJ# m) = NatS# (n `and#` bigNatToWord m) +andNatural (NatJ# n) (NatS# m) = NatS# (bigNatToWord n `and#` m) +andNatural (NatJ# n) (NatJ# m) = bigNatToNatural (andBigNat n m) +{-# CONSTANT_FOLDED andNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (NatS# n) (NatS# m) = NatS# (n `or#` m) +orNatural (NatS# n) (NatJ# m) = NatJ# (orBigNat (wordToBigNat n) m) +orNatural (NatJ# n) (NatS# m) = NatJ# (orBigNat n (wordToBigNat m)) +orNatural (NatJ# n) (NatJ# m) = NatJ# (orBigNat n m) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (NatS# n) (NatS# m) = NatS# (n `xor#` m) +xorNatural (NatS# n) (NatJ# m) = NatJ# (xorBigNat (wordToBigNat n) m) +xorNatural (NatJ# n) (NatS# m) = NatJ# (xorBigNat n (wordToBigNat m)) +xorNatural (NatJ# n) (NatJ# m) = bigNatToNatural (xorBigNat n m) +{-# CONSTANT_FOLDED xorNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = NatS# (1## `uncheckedShiftL#` i#) + | True = NatJ# (bitBigNat i#) +{-# CONSTANT_FOLDED bitNatural #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (NatS# w) (I# i#) + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = + isTrue# ((w `and#` (1## `uncheckedShiftL#` i#)) `neWord#` 0##) + | True = False +testBitNatural (NatJ# bn) (I# i#) = testBitBigNat bn i# +{-# CONSTANT_FOLDED testBitNatural #-} + +popCountNatural :: Natural -> Int +popCountNatural (NatS# w) = I# (word2Int# (popCnt# w)) +popCountNatural (NatJ# bn) = I# (popCountBigNat bn) +{-# CONSTANT_FOLDED popCountNatural #-} + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural n (I# 0#) = n +shiftLNatural (NatS# 0##) _ = NatS# 0## +shiftLNatural (NatS# 1##) (I# i#) = bitNatural i# +shiftLNatural (NatS# w) (I# i#) + = bigNatToNatural (shiftLBigNat (wordToBigNat w) i#) +shiftLNatural (NatJ# bn) (I# i#) + = bigNatToNatural (shiftLBigNat bn i#) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural n (I# 0#) = n +shiftRNatural (NatS# w) (I# i#) + | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = NatS# 0## + | True = NatS# (w `uncheckedShiftRL#` i#) +shiftRNatural (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) +{-# CONSTANT_FOLDED shiftRNatural #-} ---------------------------------------------------------------------------- @@ -379,6 +304,7 @@ plusNatural (NatS# x) (NatS# y) plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x) plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y) plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat x y) +{-# CONSTANT_FOLDED plusNatural #-} -- | 'Natural' multiplication timesNatural :: Natural -> Natural -> Natural @@ -389,12 +315,14 @@ timesNatural (NatS# 1##) y = y timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of (# 0##, 0## #) -> NatS# 0## (# 0##, xy #) -> NatS# xy - (# h , l #) -> NatJ# $ wordToBigNat2 h l -timesNatural (NatS# x) (NatJ# y) = NatJ# $ timesBigNatWord y x -timesNatural (NatJ# x) (NatS# y) = NatJ# $ timesBigNatWord x y -timesNatural (NatJ# x) (NatJ# y) = NatJ# $ timesBigNat x y - --- | 'Natural' subtraction. May @'throw' 'Underflow'@. + (# h , l #) -> NatJ# (wordToBigNat2 h l) +timesNatural (NatS# x) (NatJ# y) = NatJ# (timesBigNatWord y x) +timesNatural (NatJ# x) (NatS# y) = NatJ# (timesBigNatWord x y) +timesNatural (NatJ# x) (NatJ# y) = NatJ# (timesBigNat x y) +{-# CONSTANT_FOLDED timesNatural #-} + +-- | 'Natural' subtraction. May @'Control.Exception.throw' +-- 'Control.Exception.Underflow'@. minusNatural :: Natural -> Natural -> Natural minusNatural x (NatS# 0##) = x minusNatural (NatS# x) (NatS# y) = case subWordC# x y of @@ -402,9 +330,10 @@ minusNatural (NatS# x) (NatS# y) = case subWordC# x y of _ -> underflowError minusNatural (NatS# _) (NatJ# _) = underflowError minusNatural (NatJ# x) (NatS# y) - = bigNatToNatural $ minusBigNatWord x y + = bigNatToNatural (minusBigNatWord x y) minusNatural (NatJ# x) (NatJ# y) - = bigNatToNatural $ minusBigNat x y + = bigNatToNatural (minusBigNat x y) +{-# CONSTANT_FOLDED minusNatural #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- @@ -414,34 +343,27 @@ minusNaturalMaybe x (NatS# 0##) = Just x minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of (# l, 0# #) -> Just (NatS# l) _ -> Nothing - where minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing minusNaturalMaybe (NatJ# x) (NatS# y) - = Just $ bigNatToNatural $ minusBigNatWord x y + = Just (bigNatToNatural (minusBigNatWord x y)) minusNaturalMaybe (NatJ# x) (NatJ# y) | isTrue# (isNullBigNat# res) = Nothing - | otherwise = Just (bigNatToNatural res) + | True = Just (bigNatToNatural res) where res = minusBigNat x y -- | Convert 'BigNat' to 'Natural'. --- Throws 'Underflow' if passed a 'nullBigNat'. +-- Throws 'Control.Exception.Underflow' if passed a 'nullBigNat'. bigNatToNatural :: BigNat -> Natural bigNatToNatural bn | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn) | isTrue# (isNullBigNat# bn) = underflowError - | otherwise = NatJ# bn + | True = NatJ# bn naturalToBigNat :: Natural -> BigNat naturalToBigNat (NatS# w#) = wordToBigNat w# naturalToBigNat (NatJ# bn) = bn --- | Convert 'Int' to 'Natural'. --- Throws 'Underflow' when passed a negative 'Int'. -intToNatural :: Int -> Natural -intToNatural i | i<0 = underflowError -intToNatural (I# i#) = NatS# (int2Word# i#) - naturalToWord :: Natural -> Word naturalToWord (NatS# w#) = W# w# naturalToWord (NatJ# bn) = W# (bigNatToWord bn) @@ -450,182 +372,184 @@ naturalToInt :: Natural -> Int naturalToInt (NatS# w#) = I# (word2Int# w#) naturalToInt (NatJ# bn) = I# (bigNatToInt bn) -#else /* !HAVE_GMP_BIGNAT */ +---------------------------------------------------------------------------- + +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w# = NatS# w# +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w# = NatS# w# + +#else /* !defined(MIN_VERSION_integer_gmp) */ ---------------------------------------------------------------------------- -- Use wrapped 'Integer' as fallback; taken from Edward Kmett's nats package -- | Type representing arbitrary-precision non-negative integers. -- --- Operations whose result would be negative --- @'throw' ('Underflow' :: 'ArithException')@. +-- Operations whose result would be negative @'Control.Exception.throw' +-- ('Control.Exception.Underflow' :: 'Control.Exception.ArithException')@. -- -- @since 4.8.0.0 newtype Natural = Natural Integer -- ^ __Invariant__: non-negative 'Integer' - deriving (Eq,Ord,Ix) + deriving (Eq,Ord) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- -- This operation is mostly useful for test-suites and/or code which --- constructs 'Integer' values directly. +-- constructs 'Natural' values directly. -- -- @since 4.8.0.0 isValidNatural :: Natural -> Bool -isValidNatural (Natural i) = i >= 0 - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (Natural n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec d (Natural i) = showsPrec d i - --- | @since 4.8.0.0 -instance Num Natural where - Natural n + Natural m = Natural (n + m) - {-# INLINE (+) #-} - Natural n * Natural m = Natural (n * m) - {-# INLINE (*) #-} - Natural n - Natural m | result < 0 = underflowError - | otherwise = Natural result - where result = n - m - {-# INLINE (-) #-} - abs (Natural n) = Natural n - {-# INLINE abs #-} - signum (Natural n) = Natural (signum n) - {-# INLINE signum #-} - fromInteger = naturalFromInteger - {-# INLINE fromInteger #-} +isValidNatural (Natural i) = i >= wordToInteger 0## + +-- | Convert a 'Word#' into a 'Natural' +-- +-- Built-in rule ensures that applications of this function to literal 'Word#' +-- are lifted into 'Natural' literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w## = Natural (wordToInteger w##) +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a 'Word#' into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w## = Natural (wordToInteger w##) -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural naturalFromInteger n - | n >= 0 = Natural n - | otherwise = underflowError + | n >= wordToInteger 0## = Natural n + | True = underflowError {-# INLINE naturalFromInteger #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- -- @since 4.8.0.0 minusNaturalMaybe :: Natural -> Natural -> Maybe Natural -minusNaturalMaybe x y - | x >= y = Just (x - y) - | otherwise = Nothing - --- | @since 4.8.0.0 -instance Bits Natural where - Natural n .&. Natural m = Natural (n .&. m) - {-# INLINE (.&.) #-} - Natural n .|. Natural m = Natural (n .|. m) - {-# INLINE (.|.) #-} - xor (Natural n) (Natural m) = Natural (xor n m) - {-# INLINE xor #-} - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - {-# INLINE complement #-} - shift (Natural n) = Natural . shift n - {-# INLINE shift #-} - rotate (Natural n) = Natural . rotate n - {-# INLINE rotate #-} - bit = Natural . bit - {-# INLINE bit #-} - setBit (Natural n) = Natural . setBit n - {-# INLINE setBit #-} - clearBit (Natural n) = Natural . clearBit n - {-# INLINE clearBit #-} - complementBit (Natural n) = Natural . complementBit n - {-# INLINE complementBit #-} - testBit (Natural n) = testBit n - {-# INLINE testBit #-} - bitSizeMaybe _ = Nothing - {-# INLINE bitSizeMaybe #-} - bitSize = errorWithoutStackTrace "Natural: bitSize" - {-# INLINE bitSize #-} - isSigned _ = False - {-# INLINE isSigned #-} - shiftL (Natural n) = Natural . shiftL n - {-# INLINE shiftL #-} - shiftR (Natural n) = Natural . shiftR n - {-# INLINE shiftR #-} - rotateL (Natural n) = Natural . rotateL n - {-# INLINE rotateL #-} - rotateR (Natural n) = Natural . rotateR n - {-# INLINE rotateR #-} - popCount (Natural n) = popCount n - {-# INLINE popCount #-} - zeroBits = Natural 0 - --- | @since 4.8.0.0 -instance Real Natural where - toRational (Natural a) = toRational a - {-# INLINE toRational #-} - --- | @since 4.8.0.0 -instance Enum Natural where - pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" - pred (Natural n) = Natural (pred n) - {-# INLINE pred #-} - succ (Natural n) = Natural (succ n) - {-# INLINE succ #-} - fromEnum (Natural n) = fromEnum n - {-# INLINE fromEnum #-} - toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" - | otherwise = Natural (toEnum n) - {-# INLINE toEnum #-} - - enumFrom = coerce (enumFrom :: Integer -> [Integer]) - enumFromThen x y - | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y - | otherwise = enumFromThenTo x y 0 - - enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) - enumFromThenTo - = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) - --- | @since 4.8.0.0 -instance Integral Natural where - quot (Natural a) (Natural b) = Natural (quot a b) - {-# INLINE quot #-} - rem (Natural a) (Natural b) = Natural (rem a b) - {-# INLINE rem #-} - div (Natural a) (Natural b) = Natural (div a b) - {-# INLINE div #-} - mod (Natural a) (Natural b) = Natural (mod a b) - {-# INLINE mod #-} - divMod (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = divMod a b - {-# INLINE divMod #-} - quotRem (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = quotRem a b - {-# INLINE quotRem #-} - toInteger (Natural a) = a - {-# INLINE toInteger #-} +minusNaturalMaybe (Natural x) (Natural y) + | x >= y = Just (Natural (x `minusInteger` y)) + | True = Nothing + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural (Natural n) (I# i) = Natural (n `shiftLInteger` i) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural (Natural n) (I# i) = Natural (n `shiftRInteger` i) +{-# CONSTANT_FOLDED shiftRNatural #-} + +plusNatural :: Natural -> Natural -> Natural +plusNatural (Natural x) (Natural y) = Natural (x `plusInteger` y) +{-# CONSTANT_FOLDED plusNatural #-} + +minusNatural :: Natural -> Natural -> Natural +minusNatural (Natural x) (Natural y) = Natural (x `minusInteger` y) +{-# CONSTANT_FOLDED minusNatural #-} + +timesNatural :: Natural -> Natural -> Natural +timesNatural (Natural x) (Natural y) = Natural (x `timesInteger` y) +{-# CONSTANT_FOLDED timesNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (Natural x) (Natural y) = Natural (x `orInteger` y) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (Natural x) (Natural y) = Natural (x `xorInteger` y) +{-# CONSTANT_FOLDED xorNatural #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (Natural x) (Natural y) = Natural (x `andInteger` y) +{-# CONSTANT_FOLDED andNatural #-} + +naturalToInt :: Natural -> Int +naturalToInt (Natural i) = I# (integerToInt i) + +naturalToWord :: Natural -> Word +naturalToWord (Natural i) = W# (integerToWord i) + +naturalToInteger :: Natural -> Integer +naturalToInteger (Natural i) = i +{-# CONSTANT_FOLDED naturalToInteger #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (Natural n) (I# i) = testBitInteger n i +{-# CONSTANT_FOLDED testBitNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = wordToNaturalBase (1## `uncheckedShiftL#` i#) + | True = Natural (1 `shiftLInteger` i#) +{-# CONSTANT_FOLDED bitNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = n + | True = Natural (x `quotInteger` y) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural (Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = wordToNaturalBase 0## + | True = Natural (x `remInteger` y) +{-# CONSTANT_FOLDED remNatural #-} + +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = (n,wordToNaturalBase 0##) + | True = case quotRemInteger x y of + (# k, r #) -> (Natural k, Natural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +signumNatural :: Natural -> Natural +signumNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = wordToNaturalBase 1## +{-# CONSTANT_FOLDED signumNatural #-} + +negateNatural :: Natural -> Natural +negateNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = underflowError +{-# CONSTANT_FOLDED negateNatural #-} + #endif -- | Construct 'Natural' from 'Word' value. -- -- @since 4.8.0.0 wordToNatural :: Word -> Natural -#if HAVE_GMP_BIGNAT -wordToNatural (W# w#) = NatS# w# -#else -wordToNatural w = Natural (fromIntegral w) -#endif +wordToNatural (W# w#) = wordToNatural# w# -- | Try downcasting 'Natural' to 'Word' value. -- Returns 'Nothing' if value doesn't fit in 'Word'. -- -- @since 4.8.0.0 naturalToWordMaybe :: Natural -> Maybe Word -#if HAVE_GMP_BIGNAT +#if defined(MIN_VERSION_integer_gmp) naturalToWordMaybe (NatS# w#) = Just (W# w#) naturalToWordMaybe (NatJ# _) = Nothing #else naturalToWordMaybe (Natural i) - | i <= maxw = Just (fromIntegral i) - | otherwise = Nothing + | i < maxw = Just (W# (integerToWord i)) + | True = Nothing where - maxw = toInteger (maxBound :: Word) + maxw = 1 `shiftLInteger` WORD_SIZE_IN_BITS# #endif -- | \"@'powModNatural' /b/ /e/ /m/@\" computes base @/b/@ raised to @@ -633,7 +557,7 @@ naturalToWordMaybe (Natural i) -- -- @since 4.8.0.0 powModNatural :: Natural -> Natural -> Natural -> Natural -#if HAVE_GMP_BIGNAT +#if defined(MIN_VERSION_integer_gmp) powModNatural _ _ (NatS# 0##) = divZeroError powModNatural _ _ (NatS# 1##) = NatS# 0## powModNatural _ (NatS# 0##) _ = NatS# 1## @@ -646,18 +570,38 @@ powModNatural b e (NatJ# m) = bigNatToNatural (powModBigNat (naturalToBigNat b) (naturalToBigNat e) m) #else -- Portable reference fallback implementation -powModNatural _ _ 0 = divZeroError -powModNatural _ _ 1 = 0 -powModNatural _ 0 _ = 1 -powModNatural 0 _ _ = 0 -powModNatural 1 _ _ = 1 -powModNatural b0 e0 m = go b0 e0 1 +powModNatural (Natural b0) (Natural e0) (Natural m) + | m == wordToInteger 0## = divZeroError + | m == wordToInteger 1## = wordToNaturalBase 0## + | e0 == wordToInteger 0## = wordToNaturalBase 1## + | b0 == wordToInteger 0## = wordToNaturalBase 0## + | b0 == wordToInteger 1## = wordToNaturalBase 1## + | True = go b0 e0 (wordToInteger 1##) where go !b e !r - | odd e = go b' e' (r*b `mod` m) - | e == 0 = r - | otherwise = go b' e' r + | e `testBitInteger` 0# = go b' e' ((r `timesInteger` b) `modInteger` m) + | e == wordToInteger 0## = naturalFromInteger r + | True = go b' e' r where - b' = b*b `mod` m - e' = e `unsafeShiftR` 1 -- slightly faster than "e `div` 2" + b' = (b `timesInteger` b) `modInteger` m + e' = e `shiftRInteger` 1# -- slightly faster than "e `div` 2" #endif + + +-- | Construct 'Natural' value from list of 'Word's. +-- +-- This function is used by GHC for constructing 'Natural' literals. +mkNatural :: [Word] -- ^ value expressed in 32 bit chunks, least + -- significant first + -> Natural +mkNatural [] = wordToNaturalBase 0## +mkNatural (W# i : is') = wordToNaturalBase (i `and#` 0xffffffff##) `orNatural` + shiftLNatural (mkNatural is') 32 +{-# CONSTANT_FOLDED mkNatural #-} + +-- | Convert 'Int' to 'Natural'. +-- Throws 'Control.Exception.Underflow' when passed a negative 'Int'. +intToNatural :: Int -> Natural +intToNatural (I# i#) + | isTrue# (i# <# 0#) = underflowError + | True = wordToNaturalBase (int2Word# i#) diff --git a/libraries/base/GHC/Num.hs b/libraries/base/GHC/Num.hs index fd98c19f20..1fa63fbb00 100644 --- a/libraries/base/GHC/Num.hs +++ b/libraries/base/GHC/Num.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -16,10 +16,17 @@ -- ----------------------------------------------------------------------------- -module GHC.Num (module GHC.Num, module GHC.Integer) where + +module GHC.Num (module GHC.Num, module GHC.Integer, module GHC.Natural) where + +#include "MachDeps.h" import GHC.Base import GHC.Integer +import GHC.Natural +#if !defined(MIN_VERSION_integer_gmp) +import {-# SOURCE #-} GHC.Exception.Type (underflowException) +#endif infixl 7 * infixl 6 +, - @@ -28,6 +35,23 @@ default () -- Double isn't available yet, -- and we shouldn't be using defaults anyway -- | Basic numeric class. +-- +-- The Haskell Report defines no laws for 'Num'. However, '(+)' and '(*)' are +-- customarily expected to define a ring and have the following properties: +-- +-- [__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@ +-- [__Commutativity of (+)__]: @x + y@ = @y + x@ +-- [__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@ +-- [__'negate' gives the additive inverse__]: @x + negate x@ = @fromInteger 0@ +-- [__Associativity of (*)__]: @(x * y) * z@ = @x * (y * z)@ +-- [__@fromInteger 1@ is the multiplicative identity__]: +-- @x * fromInteger 1@ = @x@ and @fromInteger 1 * x@ = @x@ +-- [__Distributivity of (*) with respect to (+)__]: +-- @a * (b + c)@ = @(a * b) + (a * c)@ and @(b + c) * a@ = @(b * a) + (c * a)@ +-- +-- Note that it /isn't/ customarily expected that a type instance of both 'Num' +-- and 'Ord' implement an ordered ring. Indeed, in @base@ only 'Integer' and +-- 'Data.Ratio.Rational' do. class Num a where {-# MINIMAL (+), (*), abs, signum, fromInteger, (negate | (-)) #-} @@ -100,3 +124,41 @@ instance Num Integer where abs = absInteger signum = signumInteger + +#if defined(MIN_VERSION_integer_gmp) +-- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an +-- additive inverse. It is a semiring though. +-- +-- @since 4.8.0.0 +instance Num Natural where + (+) = plusNatural + (-) = minusNatural + (*) = timesNatural + negate = negateNatural + fromInteger = naturalFromInteger + + abs = id + signum = signumNatural + +#else +-- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an +-- additive inverse. It is a semiring though. +-- +-- @since 4.8.0.0 +instance Num Natural where + Natural n + Natural m = Natural (n + m) + {-# INLINE (+) #-} + Natural n * Natural m = Natural (n * m) + {-# INLINE (*) #-} + Natural n - Natural m + | m > n = raise# underflowException + | otherwise = Natural (n - m) + {-# INLINE (-) #-} + abs (Natural n) = Natural n + {-# INLINE abs #-} + signum (Natural n) = Natural (signum n) + {-# INLINE signum #-} + fromInteger = naturalFromInteger + {-# INLINE fromInteger #-} + +#endif diff --git a/libraries/base/GHC/PArr.hs b/libraries/base/GHC/PArr.hs deleted file mode 100644 index 67d25bcb85..0000000000 --- a/libraries/base/GHC/PArr.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ParallelArrays, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.PArr --- Copyright : (c) 2001-2011 The Data Parallel Haskell team --- License : see libraries/base/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- BIG UGLY HACK: The desugarer special cases this module. Despite the uses of '-XParallelArrays', --- the desugarer does not load 'Data.Array.Parallel' into its global state. (Hence, --- the present module may not use any other piece of '-XParallelArray' syntax.) --- --- This will be cleaned up when we change the internal represention of '[::]' to not --- rely on a wired-in type constructor. - -module GHC.PArr where - -import GHC.Base - --- Representation of parallel arrays --- --- Vanilla representation of parallel Haskell based on standard GHC arrays that is used if the --- vectorised is /not/ used. --- --- NB: This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! --- -data [::] e = PArr !Int (Array# e) - -type PArr = [::] -- this synonym is to get access to '[::]' without using the special syntax diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs index 93f6d64ae5..f7caf164af 100644 --- a/libraries/base/GHC/Ptr.hs +++ b/libraries/base/GHC/Ptr.hs @@ -42,7 +42,10 @@ import Numeric ( showHex ) -- redundant role annotation checks that this doesn't change type role Ptr phantom -data Ptr a = Ptr Addr# deriving (Eq, Ord) +data Ptr a = Ptr Addr# + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) -- ^ A value of type @'Ptr' a@ represents a pointer to an object, or an -- array of objects, which may be marshalled to or from Haskell values -- of type @a@. diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc index 7bb10b60cb..12cb828e6a 100644 --- a/libraries/base/GHC/RTS/Flags.hsc +++ b/libraries/base/GHC/RTS/Flags.hsc @@ -51,7 +51,7 @@ import GHC.IO import GHC.Real import GHC.Show --- | @'Time'@ is defined as a @'StgWord64'@ in @stg/Types.h@ +-- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ -- -- @since 4.8.2.0 type RtsTime = Word64 @@ -66,7 +66,8 @@ data GiveGCStats | OneLineGCStats | SummaryGCStats | VerboseGCStats - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum GiveGCStats where @@ -115,7 +116,8 @@ data GCFlags = GCFlags , allocLimitGrace :: Word , numa :: Bool , numaMask :: Word - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters concerning context switching -- @@ -123,7 +125,8 @@ data GCFlags = GCFlags data ConcFlags = ConcFlags { ctxtSwitchTime :: RtsTime , ctxtSwitchTicks :: Int - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Miscellaneous parameters -- @@ -131,32 +134,38 @@ data ConcFlags = ConcFlags data MiscFlags = MiscFlags { tickInterval :: RtsTime , installSignalHandlers :: Bool + , installSEHHandlers :: Bool + , generateCrashDumpFile :: Bool + , generateStackTrace :: Bool , machineReadable :: Bool + , internalCounters :: Bool , linkerMemBase :: Word -- ^ address to ask the OS for memory for the linker, 0 ==> off - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Flags to control debugging output & extra checking in various -- subsystems. -- -- @since 4.8.0.0 data DebugFlags = DebugFlags - { scheduler :: Bool -- ^ 's' - , interpreter :: Bool -- ^ 'i' - , weak :: Bool -- ^ 'w' - , gccafs :: Bool -- ^ 'G' - , gc :: Bool -- ^ 'g' - , block_alloc :: Bool -- ^ 'b' - , sanity :: Bool -- ^ 'S' - , stable :: Bool -- ^ 't' - , prof :: Bool -- ^ 'p' - , linker :: Bool -- ^ 'l' the object linker - , apply :: Bool -- ^ 'a' - , stm :: Bool -- ^ 'm' - , squeeze :: Bool -- ^ 'z' stack squeezing & lazy blackholing - , hpc :: Bool -- ^ 'c' coverage - , sparks :: Bool -- ^ 'r' - } deriving (Show) + { scheduler :: Bool -- ^ @s@ + , interpreter :: Bool -- ^ @i@ + , weak :: Bool -- ^ @w@ + , gccafs :: Bool -- ^ @G@ + , gc :: Bool -- ^ @g@ + , block_alloc :: Bool -- ^ @b@ + , sanity :: Bool -- ^ @S@ + , stable :: Bool -- ^ @t@ + , prof :: Bool -- ^ @p@ + , linker :: Bool -- ^ @l@ the object linker + , apply :: Bool -- ^ @a@ + , stm :: Bool -- ^ @m@ + , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing + , hpc :: Bool -- ^ @c@ coverage + , sparks :: Bool -- ^ @r@ + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Should the RTS produce a cost-center summary? -- @@ -167,7 +176,8 @@ data DoCostCentres | CostCentresVerbose | CostCentresAll | CostCentresJSON - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoCostCentres where @@ -191,7 +201,8 @@ data CCFlags = CCFlags { doCostCentres :: DoCostCentres , profilerTicks :: Int , msecsPerTick :: Int - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | What sort of heap profile are we collecting? -- @@ -205,7 +216,8 @@ data DoHeapProfile | HeapByRetainer | HeapByLDV | HeapByClosureType - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoHeapProfile where @@ -246,7 +258,8 @@ data ProfFlags = ProfFlags , ccsSelector :: Maybe String , retainerSelector :: Maybe String , bioSelector :: Maybe String - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Is event tracing enabled? -- @@ -255,7 +268,8 @@ data DoTrace = TraceNone -- ^ no tracing | TraceEventLog -- ^ send tracing events to the event log | TraceStderr -- ^ send tracing events to @stderr@ - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoTrace where @@ -279,7 +293,8 @@ data TraceFlags = TraceFlags , sparksSampled :: Bool -- ^ trace spark events by a sampled method , sparksFull :: Bool -- ^ trace spark events 100% accurately , user :: Bool -- ^ trace user events (emitted from Haskell code) - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters pertaining to ticky-ticky profiler -- @@ -287,7 +302,8 @@ data TraceFlags = TraceFlags data TickyFlags = TickyFlags { showTickyStats :: Bool , tickyFile :: Maybe FilePath - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters pertaining to parallelism -- @@ -304,7 +320,8 @@ data ParFlags = ParFlags , parGcThreads :: Word32 , setAffinity :: Bool } - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters of the runtime system -- @@ -319,7 +336,8 @@ data RTSFlags = RTSFlags , traceFlags :: TraceFlags , tickyFlags :: TickyFlags , parFlags :: ParFlags - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) foreign import ccall "&RtsFlags" rtsFlagsPtr :: Ptr RTSFlags @@ -362,20 +380,27 @@ getGCFlags = do <*> #{peek GC_FLAGS, nurseryChunkSize} ptr <*> #{peek GC_FLAGS, minOldGenSize} ptr <*> #{peek GC_FLAGS, heapSizeSuggestion} ptr - <*> #{peek GC_FLAGS, heapSizeSuggestionAuto} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, heapSizeSuggestionAuto} ptr :: IO CBool)) <*> #{peek GC_FLAGS, oldGenFactor} ptr <*> #{peek GC_FLAGS, pcFreeHeap} ptr <*> #{peek GC_FLAGS, generations} ptr - <*> #{peek GC_FLAGS, squeezeUpdFrames} ptr - <*> #{peek GC_FLAGS, compact} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, squeezeUpdFrames} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek GC_FLAGS, compact} ptr :: IO CBool)) <*> #{peek GC_FLAGS, compactThreshold} ptr - <*> #{peek GC_FLAGS, sweep} ptr - <*> #{peek GC_FLAGS, ringBell} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, sweep} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek GC_FLAGS, ringBell} ptr :: IO CBool)) <*> #{peek GC_FLAGS, idleGCDelayTime} ptr - <*> #{peek GC_FLAGS, doIdleGC} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, doIdleGC} ptr :: IO CBool)) <*> #{peek GC_FLAGS, heapBase} ptr <*> #{peek GC_FLAGS, allocLimitGrace} ptr - <*> #{peek GC_FLAGS, numa} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, numa} ptr :: IO CBool)) <*> #{peek GC_FLAGS, numaMask} ptr getParFlags :: IO ParFlags @@ -383,15 +408,19 @@ getParFlags = do let ptr = (#ptr RTS_FLAGS, ParFlags) rtsFlagsPtr ParFlags <$> #{peek PAR_FLAGS, nCapabilities} ptr - <*> #{peek PAR_FLAGS, migrate} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, migrate} ptr :: IO CBool)) <*> #{peek PAR_FLAGS, maxLocalSparks} ptr - <*> #{peek PAR_FLAGS, parGcEnabled} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, parGcEnabled} ptr :: IO CBool)) <*> #{peek PAR_FLAGS, parGcGen} ptr - <*> #{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr :: IO CBool)) <*> #{peek PAR_FLAGS, parGcLoadBalancingGen} ptr <*> #{peek PAR_FLAGS, parGcNoSyncWithIdle} ptr <*> #{peek PAR_FLAGS, parGcThreads} ptr - <*> #{peek PAR_FLAGS, setAffinity} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, setAffinity} ptr :: IO CBool)) getConcFlags :: IO ConcFlags getConcFlags = do @@ -403,28 +432,53 @@ getMiscFlags :: IO MiscFlags getMiscFlags = do let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr - <*> #{peek MISC_FLAGS, install_signal_handlers} ptr - <*> #{peek MISC_FLAGS, machineReadable} ptr + <*> (toBool <$> + (#{peek MISC_FLAGS, install_signal_handlers} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, install_seh_handlers} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, generate_dump_file} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, generate_stack_trace} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, machineReadable} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, internalCounters} ptr :: IO CBool)) <*> #{peek MISC_FLAGS, linkerMemBase} ptr getDebugFlags :: IO DebugFlags getDebugFlags = do let ptr = (#ptr RTS_FLAGS, DebugFlags) rtsFlagsPtr - DebugFlags <$> #{peek DEBUG_FLAGS, scheduler} ptr - <*> #{peek DEBUG_FLAGS, interpreter} ptr - <*> #{peek DEBUG_FLAGS, weak} ptr - <*> #{peek DEBUG_FLAGS, gccafs} ptr - <*> #{peek DEBUG_FLAGS, gc} ptr - <*> #{peek DEBUG_FLAGS, block_alloc} ptr - <*> #{peek DEBUG_FLAGS, sanity} ptr - <*> #{peek DEBUG_FLAGS, stable} ptr - <*> #{peek DEBUG_FLAGS, prof} ptr - <*> #{peek DEBUG_FLAGS, linker} ptr - <*> #{peek DEBUG_FLAGS, apply} ptr - <*> #{peek DEBUG_FLAGS, stm} ptr - <*> #{peek DEBUG_FLAGS, squeeze} ptr - <*> #{peek DEBUG_FLAGS, hpc} ptr - <*> #{peek DEBUG_FLAGS, sparks} ptr + DebugFlags <$> (toBool <$> + (#{peek DEBUG_FLAGS, scheduler} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, interpreter} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, weak} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, gccafs} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, gc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, block_alloc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, sanity} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, stable} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, prof} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, linker} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, apply} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, stm} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, squeeze} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool)) getCCFlags :: IO CCFlags getCCFlags = do @@ -440,8 +494,10 @@ getProfFlags = do ProfFlags <$> (toEnum <$> #{peek PROFILING_FLAGS, doHeapProfile} ptr) <*> #{peek PROFILING_FLAGS, heapProfileInterval} ptr <*> #{peek PROFILING_FLAGS, heapProfileIntervalTicks} ptr - <*> #{peek PROFILING_FLAGS, includeTSOs} ptr - <*> #{peek PROFILING_FLAGS, showCCSOnException} ptr + <*> (toBool <$> + (#{peek PROFILING_FLAGS, includeTSOs} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek PROFILING_FLAGS, showCCSOnException} ptr :: IO CBool)) <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr <*> #{peek PROFILING_FLAGS, ccsLength} ptr <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, modSelector} ptr) @@ -457,15 +513,22 @@ getTraceFlags = do let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr TraceFlags <$> (toEnum . fromIntegral <$> (#{peek TRACE_FLAGS, tracing} ptr :: IO CInt)) - <*> #{peek TRACE_FLAGS, timestamp} ptr - <*> #{peek TRACE_FLAGS, scheduler} ptr - <*> #{peek TRACE_FLAGS, gc} ptr - <*> #{peek TRACE_FLAGS, sparks_sampled} ptr - <*> #{peek TRACE_FLAGS, sparks_full} ptr - <*> #{peek TRACE_FLAGS, user} ptr + <*> (toBool <$> + (#{peek TRACE_FLAGS, timestamp} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, scheduler} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, gc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, sparks_sampled} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, sparks_full} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, user} ptr :: IO CBool)) getTickyFlags :: IO TickyFlags getTickyFlags = do let ptr = (#ptr RTS_FLAGS, TickyFlags) rtsFlagsPtr - TickyFlags <$> #{peek TICKY_FLAGS, showTickyStats} ptr + TickyFlags <$> (toBool <$> + (#{peek TICKY_FLAGS, showTickyStats} ptr :: IO CBool)) <*> (peekFilePath =<< #{peek TICKY_FLAGS, tickyFile} ptr) diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs index 49c0606878..ef9d8df2e5 100644 --- a/libraries/base/GHC/Read.hs +++ b/libraries/base/GHC/Read.hs @@ -36,6 +36,9 @@ module GHC.Read , choose , readListDefault, readListPrecDefault , readNumber + , readField + , readFieldHash + , readSymField -- Temporary , readParen @@ -69,6 +72,7 @@ import GHC.Show import GHC.Base import GHC.Arr import GHC.Word +import GHC.List (filter) -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with @@ -359,10 +363,71 @@ choose sps = foldr ((+++) . try_one) pfail sps L.Symbol s' | s==s' -> p _other -> pfail } +-- See Note [Why readField] + +-- | 'Read' parser for a record field, of the form @fieldName=value@. The +-- @fieldName@ must be an alphanumeric identifier; for symbols (operator-style) +-- field names, e.g. @(#)@, use 'readSymField'). The second argument is a +-- parser for the field value. +readField :: String -> ReadPrec a -> ReadPrec a +readField fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Punc "=") + readVal +{-# NOINLINE readField #-} + +-- See Note [Why readField] + +-- | 'Read' parser for a record field, of the form @fieldName#=value@. That is, +-- an alphanumeric identifier @fieldName@ followed by the symbol @#@. The +-- second argument is a parser for the field value. +-- +-- Note that 'readField' does not suffice for this purpose due to +-- <https://ghc.haskell.org/trac/ghc/ticket/5041 Trac #5041>. +readFieldHash :: String -> ReadPrec a -> ReadPrec a +readFieldHash fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Symbol "#") + expectP (L.Punc "=") + readVal +{-# NOINLINE readFieldHash #-} + +-- See Note [Why readField] + +-- | 'Read' parser for a symbol record field, of the form @(###)=value@ (where +-- @###@ is the field name). The field name must be a symbol (operator-style), +-- e.g. @(#)@. For regular (alphanumeric) field names, use 'readField'. The +-- second argument is a parser for the field value. +readSymField :: String -> ReadPrec a -> ReadPrec a +readSymField fieldName readVal = do + expectP (L.Punc "(") + expectP (L.Symbol fieldName) + expectP (L.Punc ")") + expectP (L.Punc "=") + readVal +{-# NOINLINE readSymField #-} + + +-- Note [Why readField] +-- +-- Previously, the code for automatically deriving Read instance (in +-- typecheck/TcGenDeriv.hs) would generate inline code for parsing fields; +-- this, however, turned out to produce massive amounts of intermediate code, +-- and produced a considerable performance hit in the code generator. +-- Since Read instances are not generally supposed to be perfomance critical, +-- the readField and readSymField functions have been factored out, and the +-- code generator now just generates calls rather than manually inlining the +-- parsers. For large record types (e.g. 500 fields), this produces a +-- significant performance boost. +-- +-- See also Trac #14364. + + -------------------------------------------------------------- -- Simple instances of Read -------------------------------------------------------------- +-- | @since 2.01 deriving instance Read GeneralCategory -- | @since 2.01 @@ -412,6 +477,9 @@ instance Read Ordering where readListPrec = readListPrecDefault readList = readListDefault +-- | @since 4.11.0.0 +deriving instance Read a => Read (NonEmpty a) + -------------------------------------------------------------- -- Structure instances of Read: Maybe, List etc -------------------------------------------------------------- @@ -549,6 +617,19 @@ instance Read Integer where readListPrec = readListPrecDefault readList = readListDefault + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (fromInteger n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#else +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (Natural n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#endif + -- | @since 2.01 instance Read Float where readPrec = readNumber convertFrac diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index 1154091dd5..c96959f55b 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -20,12 +20,16 @@ module GHC.Real where +#include "MachDeps.h" + import GHC.Base import GHC.Num import GHC.List import GHC.Enum import GHC.Show -import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException, ratioZeroDenomException ) +import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException + , underflowException + , ratioZeroDenomException ) #if defined(OPTIMISE_INTEGER_GCD_LCM) # if defined(MIN_VERSION_integer_gmp) @@ -61,12 +65,21 @@ ratioZeroDenominatorError = raise# ratioZeroDenomException overflowError :: a overflowError = raise# overflowException +{-# NOINLINE underflowError #-} +underflowError :: a +underflowError = raise# underflowException + + -------------------------------------------------------------- -- The Ratio and Rational types -------------------------------------------------------------- -- | Rational numbers, with numerator and denominator of some 'Integral' type. -data Ratio a = !a :% !a deriving (Eq) +-- +-- Note that `Ratio`'s instances inherit the deficiencies from the type +-- parameter's. For example, @Ratio Natural@'s 'Num' instance has similar +-- problems to `Numeric.Natural.Natural`'s. +data Ratio a = !a :% !a deriving Eq -- ^ @since 2.01 -- | Arbitrary-precision rational numbers, represented as a ratio of -- two 'Integer' values. A rational number may be constructed using @@ -122,6 +135,19 @@ class (Num a, Ord a) => Real a where toRational :: a -> Rational -- | Integral numbers, supporting integer division. +-- +-- The Haskell Report defines no laws for 'Integral'. However, 'Integral' +-- instances are customarily expected to define a Euclidean domain and have the +-- following properties for the 'div'/'mod' and 'quot'/'rem' pairs, given +-- suitable Euclidean functions @f@ and @g@: +-- +-- * @x@ = @y * quot x y + rem x y@ with @rem x y@ = @fromInteger 0@ or +-- @g (rem x y)@ < @g y@ +-- * @x@ = @y * div x y + mod x y@ with @mod x y@ = @fromInteger 0@ or +-- @f (mod x y)@ < @f y@ +-- +-- An example of a suitable Euclidean function, for `Integer`'s instance, is +-- 'abs'. class (Real a, Enum a) => Integral a where -- | integer division truncated toward zero quot :: a -> a -> a @@ -155,6 +181,16 @@ class (Real a, Enum a) => Integral a where where qr@(q,r) = quotRem n d -- | Fractional numbers, supporting real division. +-- +-- The Haskell Report defines no laws for 'Fractional'. However, '(+)' and +-- '(*)' are customarily expected to define a division ring and have the +-- following properties: +-- +-- [__'recip' gives the multiplicative inverse__]: +-- @x * recip x@ = @recip x * x@ = @fromInteger 1@ +-- +-- Note that it /isn't/ customarily expected that a type instance of +-- 'Fractional' implement a field. However, all instances in @base@ do. class (Num a) => Fractional a where {-# MINIMAL fromRational, (recip | (/)) #-} @@ -216,10 +252,19 @@ class (Real a, Fractional a) => RealFrac a where -- These 'numeric' enumerations come straight from the Report numericEnumFrom :: (Fractional a) => a -> [a] -numericEnumFrom n = n `seq` (n : numericEnumFrom (n + 1)) +numericEnumFrom n = go 0 + where + -- See Note [Numeric Stability of Enumerating Floating Numbers] + go !k = let !n' = n + k + in n' : go (k + 1) numericEnumFromThen :: (Fractional a) => a -> a -> [a] -numericEnumFromThen n m = n `seq` m `seq` (n : numericEnumFromThen m (m+m-n)) +numericEnumFromThen n m = go 0 + where + step = m - n + -- See Note [Numeric Stability of Enumerating Floating Numbers] + go !k = let !n' = n + k * step + in n' : go (k + 1) numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a] numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n) @@ -232,6 +277,49 @@ numericEnumFromThenTo e1 e2 e3 predicate | e2 >= e1 = (<= e3 + mid) | otherwise = (>= e3 + mid) +{- Note [Numeric Stability of Enumerating Floating Numbers] +----------------------------------------------------------- +When enumerate floating numbers, we could add the increment to the last number +at every run (as what we did previously): + + numericEnumFrom n = n `seq` (n : numericEnumFrom (n + 1)) + +This approach is concise and really fast, only needs an addition operation. +However when a floating number is large enough, for `n`, `n` and `n+1` will +have the same binary representation. For example (all number has type +`Double`): + + 9007199254740990 is: 0x433ffffffffffffe + 9007199254740990 + 1 is: 0x433fffffffffffff + (9007199254740990 + 1) + 1 is: 0x4340000000000000 + ((9007199254740990 + 1) + 1) + 1 is: 0x4340000000000000 + +When we evaluate ([9007199254740990..9007199254740991] :: Double), we would +never reach the condition in `numericEnumFromTo` + + 9007199254740990 + 1 + 1 + ... > 9007199254740991 + 1/2 + +We would fall into infinite loop (as reported in Trac #15081). + +To remedy the situation, we record the number of `1` that needed to be added +to the start number, rather than increasing `1` at every time. This approach +can improvement the numeric stability greatly at the cost of a multiplication. + +Furthermore, we use the type of the enumerated number, `Fractional a => a`, +as the type of multiplier. In rare situations, the multiplier could be very +large and will lead to the enumeration to infinite loop, too, which should +be very rare. Consider the following example: + + [1..9007199254740994] + +We could fix that by using an Integer as multiplier but we don't do that. +The benchmark on T7954.hs shows that this approach leads to significant +degeneration on performance (33% increase allocation and 300% increase on +elapsed time). + +See Trac #15081 and Phab:D4650 for the related discussion about this problem. +-} + -------------------------------------------------------------- -- Instances for Int -------------------------------------------------------------- @@ -324,6 +412,18 @@ instance Integral Word where instance Real Integer where toRational x = x :% 1 +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Real Natural where + toRational (NatS# w) = toRational (W# w) + toRational (NatJ# bn) = toRational (Jp# bn) +#else +-- | @since 4.8.0.0 +instance Real Natural where + toRational (Natural a) = toRational a + {-# INLINE toRational #-} +#endif + -- Note [Integer division constant folding] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -366,6 +466,39 @@ instance Integral Integer where n `quotRem` d = case n `quotRemInteger` d of (# q, r #) -> (q, r) +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Integral Natural where + toInteger = naturalToInteger + + divMod = quotRemNatural + div = quotNatural + mod = remNatural + + quotRem = quotRemNatural + quot = quotNatural + rem = remNatural +#else +-- | @since 4.8.0.0 +instance Integral Natural where + quot (Natural a) (Natural b) = Natural (quot a b) + {-# INLINE quot #-} + rem (Natural a) (Natural b) = Natural (rem a b) + {-# INLINE rem #-} + div (Natural a) (Natural b) = Natural (div a b) + {-# INLINE div #-} + mod (Natural a) (Natural b) = Natural (mod a b) + {-# INLINE mod #-} + divMod (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = divMod a b + {-# INLINE divMod #-} + quotRem (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = quotRem a b + {-# INLINE quotRem #-} + toInteger (Natural a) = a + {-# INLINE toInteger #-} +#endif + -------------------------------------------------------------- -- Instances for @Ratio@ -------------------------------------------------------------- @@ -454,6 +587,17 @@ fromIntegral = fromInteger . toInteger "fromIntegral/Word->Word" fromIntegral = id :: Word -> Word #-} +{-# RULES +"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural +"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer +"fromIntegral/Natural->Word" fromIntegral = naturalToWord + #-} + +{-# RULES +"fromIntegral/Word->Natural" fromIntegral = wordToNatural +"fromIntegral/Int->Natural" fromIntegral = intToNatural + #-} + -- | general coercion to fractional types realToFrac :: (Real a, Fractional b) => a -> b {-# NOINLINE [1] realToFrac #-} @@ -493,17 +637,23 @@ x0 ^ y0 | y0 < 0 = errorWithoutStackTrace "Negative exponent" where -- f : x0 ^ y0 = x ^ y f x y | even y = f (x * x) (y `quot` 2) | y == 1 = x - | otherwise = g (x * x) ((y - 1) `quot` 2) x + | otherwise = g (x * x) (y `quot` 2) x -- See Note [Half of y - 1] -- g : x0 ^ y0 = (x ^ y) * z g x y z | even y = g (x * x) (y `quot` 2) z | y == 1 = x * z - | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) + | otherwise = g (x * x) (y `quot` 2) (x * z) -- See Note [Half of y - 1] -- | raise a number to an integral power (^^) :: (Fractional a, Integral b) => a -> b -> a {-# INLINABLE [1] (^^) #-} -- See Note [Inlining (^) x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) +{- 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. +-} + {- Note [Inlining (^) ~~~~~~~~~~~~~~~~~~~~~ The INLINABLE pragma allows (^) to be specialised at its call sites. @@ -527,9 +677,7 @@ x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) be statically resolved to 0 or 1 are rare. It might be desirable to have corresponding rules also for - exponents of other types, in particular Word, but we can't - have those rules here (importing GHC.Word or GHC.Int would - create a cyclic module dependency), and it's doubtful they + exponents of other types (e. g., Word), but it's doubtful they would fire, since the exponents of other types tend to get floated out before the rule has a chance to fire. @@ -631,6 +779,7 @@ gcd x y = gcd' (abs x) (abs y) -- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide. lcm :: (Integral a) => a -> a -> a {-# SPECIALISE lcm :: Int -> Int -> Int #-} +{-# SPECIALISE lcm :: Word -> Word -> Word #-} {-# NOINLINE [1] lcm #-} lcm _ 0 = 0 lcm 0 _ = 0 @@ -641,12 +790,13 @@ lcm x y = abs ((x `quot` (gcd x y)) * y) "gcd/Int->Int->Int" gcd = gcdInt' "gcd/Integer->Integer->Integer" gcd = gcdInteger "lcm/Integer->Integer->Integer" lcm = lcmInteger +"gcd/Natural->Natural->Natural" gcd = gcdNatural +"lcm/Natural->Natural->Natural" lcm = lcmNatural #-} gcdInt' :: Int -> Int -> Int gcdInt' (I# x) (I# y) = I# (gcdInt x y) -#if MIN_VERSION_integer_gmp(1,0,0) {-# RULES "gcd/Word->Word->Word" gcd = gcdWord' #-} @@ -654,7 +804,6 @@ gcdInt' (I# x) (I# y) = I# (gcdInt x y) gcdWord' :: Word -> Word -> Word gcdWord' (W# x) (W# y) = W# (gcdWord x y) #endif -#endif integralEnumFrom :: (Integral a, Bounded a) => a -> [a] integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)] diff --git a/libraries/base/GHC/Real.hs-boot b/libraries/base/GHC/Real.hs-boot new file mode 100644 index 0000000000..b462c1c299 --- /dev/null +++ b/libraries/base/GHC/Real.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Real where + +import GHC.Types () + +class Integral a diff --git a/libraries/base/GHC/ResponseFile.hs b/libraries/base/GHC/ResponseFile.hs new file mode 100644 index 0000000000..804bd44ff7 --- /dev/null +++ b/libraries/base/GHC/ResponseFile.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ResponseFile +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : portable +-- +-- GCC style response files. +-- +-- @since 4.12.0.0 +---------------------------------------------------------------------------- + +-- Migrated from Haddock. + +module GHC.ResponseFile ( + getArgsWithResponseFiles, + unescapeArgs, + escapeArgs, + expandResponse + ) where + +import Control.Exception +import Data.Char (isSpace) +import Data.Foldable (foldl') +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--\'two\' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\"" +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechasnism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\"" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like '@foo' will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs index 4e00c0e85f..ccc123d303 100644 --- a/libraries/base/GHC/ST.hs +++ b/libraries/base/GHC/ST.hs @@ -18,7 +18,7 @@ module GHC.ST ( ST(..), STret(..), STRep, - fixST, runST, + runST, -- * Unsafe functions liftST, unsafeInterleaveST, unsafeDupableInterleaveST @@ -26,16 +26,17 @@ module GHC.ST ( import GHC.Base import GHC.Show +import qualified Control.Monad.Fail as Fail default () --- The state-transformer monad proper. By default the monad is strict; +-- The 'ST' monad proper. By default the monad is strict; -- too many people got bitten by space leaks when it was lazy. --- | The strict state-transformer monad. --- A computation of type @'ST' s a@ transforms an internal state indexed --- by @s@, and returns a value of type @a@. --- The @s@ parameter is either +-- | The strict 'ST' monad. +-- The 'ST' monad allows for destructive updates, but is escapable (unlike IO). +-- A computation of type @'ST' s a@ returns a value of type @a@, and +-- execute in "thread" @s@. The @s@ parameter is either -- -- * an uninstantiated type variable (inside invocations of 'runST'), or -- @@ -77,10 +78,21 @@ instance Monad (ST s) where case (k r) of { ST k2 -> (k2 new_s) }}) +-- | @since 4.11.0.0 +instance Fail.MonadFail (ST s) where + fail s = errorWithoutStackTrace s + +-- | @since 4.11.0.0 +instance Semigroup a => Semigroup (ST s a) where + (<>) = liftA2 (<>) + +-- | @since 4.11.0.0 +instance Monoid a => Monoid (ST s a) where + mempty = pure mempty + data STret s a = STret (State# s) a --- liftST is useful when we want a lifted result from an ST computation. See --- fixST below. +-- liftST is useful when we want a lifted result from an ST computation. liftST :: ST s a -> State# s -> STret s a liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r @@ -113,23 +125,13 @@ unsafeDupableInterleaveST (ST m) = ST ( \ s -> (# s, r #) ) --- | Allow the result of a state transformer computation to be used (lazily) --- inside the computation. --- Note that if @f@ is strict, @'fixST' f = _|_@. -fixST :: (a -> ST s a) -> ST s a -fixST k = ST $ \ s -> - let ans = liftST (k r) s - STret _ r = ans - in - case ans of STret s' x -> (# s', x #) - -- | @since 2.01 instance Show (ST s a) where showsPrec _ _ = showString "<<ST action>>" showList = showList__ (showsPrec 0) {-# INLINE runST #-} --- | Return the value computed by a state transformer computation. +-- | Return the value computed by a state thread. -- The @forall@ ensures that the internal state used by the 'ST' -- computation is inaccessible to the rest of the program. runST :: (forall s. ST s a) -> a diff --git a/libraries/base/GHC/STRef.hs b/libraries/base/GHC/STRef.hs index a6e4292ddb..6ee9e7bab7 100644 --- a/libraries/base/GHC/STRef.hs +++ b/libraries/base/GHC/STRef.hs @@ -24,9 +24,21 @@ module GHC.STRef ( import GHC.ST import GHC.Base +-- $setup +-- import Prelude + data STRef s a = STRef (MutVar# s a) -- ^ a value of type @STRef s a@ is a mutable variable in state thread @s@, -- containing a value of type @a@ +-- +-- >>> :{ +-- runST (do +-- ref <- newSTRef "hello" +-- x <- readSTRef ref +-- writeSTRef ref (x ++ "world") +-- readSTRef ref ) +-- :} +-- "helloworld" -- |Build a new 'STRef' in the current state thread newSTRef :: a -> ST s (STRef s a) diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 6965335e64..a41bf81cb3 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -53,6 +53,8 @@ import GHC.Base import GHC.List ((!!), foldr1, break) import GHC.Num import GHC.Stack.Types +import GHC.Types (TypeLitSort (..)) + -- | The @shows@ functions return a function that prepends the -- output 'String' to an existing 'String'. This allows constant-time @@ -163,6 +165,7 @@ appPrec1 = I# 11# -- appPrec + 1 -- Simple Instances -------------------------------------------------------------- +-- | @since 2.01 deriving instance Show () -- | @since 2.01 @@ -172,7 +175,10 @@ instance Show a => Show [a] where {-# SPECIALISE instance Show [Int] #-} showsPrec _ = showList +-- | @since 2.01 deriving instance Show Bool + +-- | @since 2.01 deriving instance Show Ordering -- | @since 2.01 @@ -197,15 +203,19 @@ showWord w# cs c# -> showWord (w# `quotWord#` 10##) (C# c# : cs) +-- | @since 2.01 deriving instance Show a => Show (Maybe a) +-- | @since 4.11.0.0 +deriving instance Show a => Show (NonEmpty a) + -- | @since 2.01 instance Show TyCon where showsPrec p (TyCon _ _ _ tc_name _ _) = showsPrec p tc_name -- | @since 4.9.0.0 instance Show TrName where - showsPrec _ (TrNameS s) = showString (unpackCString# s) + showsPrec _ (TrNameS s) = showString (unpackCStringUtf8# s) showsPrec _ (TrNameD s) = showString s -- | @since 4.9.0.0 @@ -216,6 +226,7 @@ instance Show Module where instance Show CallStack where showsPrec _ = shows . getCallStack +-- | @since 4.9.0.0 deriving instance Show SrcLoc -------------------------------------------------------------- @@ -468,7 +479,14 @@ instance Show Integer where | otherwise = integerToString n r showList = showList__ (showsPrec 0) --- Divide an conquer implementation of string conversion +-- | @since 4.8.0.0 +instance Show Natural where +#if defined(MIN_VERSION_integer_gmp) + showsPrec p (NatS# w#) = showsPrec p (W# w#) +#endif + showsPrec p i = showsPrec p (naturalToInteger i) + +-- Divide and conquer implementation of string conversion integerToString :: Integer -> String -> String integerToString n0 cs0 | n0 < 0 = '-' : integerToString' (- n0) cs0 @@ -546,3 +564,46 @@ integerToString n0 cs0 c@(C# _) -> jblock' (d - 1) q (c : cs) where (q, r) = n `quotRemInt` 10 + +instance Show KindRep where + showsPrec d (KindRepVar v) = showParen (d > 10) $ + showString "KindRepVar " . showsPrec 11 v + showsPrec d (KindRepTyConApp p q) = showParen (d > 10) $ + showString "KindRepTyConApp " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + showsPrec d (KindRepApp p q) = showParen (d > 10) $ + showString "KindRepApp " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + showsPrec d (KindRepFun p q) = showParen (d > 10) $ + showString "KindRepFun " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + showsPrec d (KindRepTYPE rep) = showParen (d > 10) $ + showString "KindRepTYPE " . showsPrec 11 rep + showsPrec d (KindRepTypeLitS p q) = showParen (d > 10) $ + showString "KindRepTypeLitS " + . showsPrec 11 p + . showString " " + . showsPrec 11 (unpackCString# q) + showsPrec d (KindRepTypeLitD p q) = showParen (d > 10) $ + showString "KindRepTypeLitD " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + +-- | @since 4.11.0.0 +deriving instance Show RuntimeRep + +-- | @since 4.11.0.0 +deriving instance Show VecCount + +-- | @since 4.11.0.0 +deriving instance Show VecElem + +-- | @since 4.11.0.0 +deriving instance Show TypeLitSort diff --git a/libraries/base/GHC/Stable.hs b/libraries/base/GHC/Stable.hs index 73095bd44a..dd585c363b 100644 --- a/libraries/base/GHC/Stable.hs +++ b/libraries/base/GHC/Stable.hs @@ -57,7 +57,7 @@ newStablePtr a = IO $ \ s -> -- | -- Obtain the Haskell value referenced by a stable pointer, i.e., the -- same value that was passed to the corresponding call to --- 'makeStablePtr'. If the argument to 'deRefStablePtr' has +-- 'newStablePtr'. If the argument to 'deRefStablePtr' has -- already been freed using 'freeStablePtr', the behaviour of -- 'deRefStablePtr' is undefined. -- @@ -101,7 +101,7 @@ castStablePtrToPtr (StablePtr s) = Ptr (unsafeCoerce# s) castPtrToStablePtr :: Ptr () -> StablePtr a castPtrToStablePtr (Ptr a) = StablePtr (unsafeCoerce# a) --- | @since 2.1 +-- | @since 2.01 instance Eq (StablePtr a) where (StablePtr sp1) == (StablePtr sp2) = case eqStablePtr# sp1 sp2 of diff --git a/libraries/base/GHC/StableName.hs b/libraries/base/GHC/StableName.hs new file mode 100644 index 0000000000..7369f41d72 --- /dev/null +++ b/libraries/base/GHC/StableName.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Mem.StableName +-- 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 +-- +-- Stable names are a way of performing fast (O(1)), not-quite-exact +-- comparison between objects. +-- +-- Stable names solve the following problem: suppose you want to build +-- a hash table with Haskell objects as keys, but you want to use +-- pointer equality for comparison; maybe because the keys are large +-- and hashing would be slow, or perhaps because the keys are infinite +-- in size. We can\'t build a hash table using the address of the +-- object as the key, because objects get moved around by the garbage +-- collector, meaning a re-hash would be necessary after every garbage +-- collection. +-- +------------------------------------------------------------------------------- + +module GHC.StableName ( + -- * Stable Names + StableName (..), + makeStableName, + hashStableName, + eqStableName + ) where + +import GHC.IO ( IO(..) ) +import GHC.Base ( Int(..), StableName#, makeStableName# + , eqStableName#, stableNameToInt# ) + +----------------------------------------------------------------------------- +-- Stable Names + +{-| + An abstract name for an object, that supports equality and hashing. + + Stable names have the following property: + + * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@ + then @sn1@ and @sn2@ were created by calls to @makeStableName@ on + the same object. + + The reverse is not necessarily true: if two stable names are not + equal, then the objects they name may still be equal. Note in particular + that `makeStableName` may return a different `StableName` after an + object is evaluated. + + Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), + but differ in the following ways: + + * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s. + Stable names are reclaimed by the runtime system when they are no + longer needed. + + * There is no @deRefStableName@ operation. You can\'t get back from + a stable name to the original Haskell object. The reason for + this is that the existence of a stable name for an object does not + guarantee the existence of the object itself; it can still be garbage + collected. +-} + +data StableName a = StableName (StableName# a) + +-- | Makes a 'StableName' for an arbitrary object. The object passed as +-- the first argument is not evaluated by 'makeStableName'. +makeStableName :: a -> IO (StableName a) +makeStableName a = IO $ \ s -> + case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) + +-- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not +-- necessarily unique; several 'StableName's may map to the same 'Int' +-- (in practice however, the chances of this are small, so the result +-- of 'hashStableName' makes a good hash key). +hashStableName :: StableName a -> Int +hashStableName (StableName sn) = I# (stableNameToInt# sn) + +-- | @since 2.01 +instance Eq (StableName a) where + (StableName sn1) == (StableName sn2) = + case eqStableName# sn1 sn2 of + 0# -> False + _ -> True + +-- | Equality on 'StableName' that does not require that the types of +-- the arguments match. +-- +-- @since 4.7.0.0 +eqStableName :: StableName a -> StableName b -> Bool +eqStableName (StableName sn1) (StableName sn2) = + case eqStableName# sn1 sn2 of + 0# -> False + _ -> True + -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to + -- use it for implementing observable sharing. + diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs index f5b175c0bb..1f102c9f9b 100644 --- a/libraries/base/GHC/Stack.hs +++ b/libraries/base/GHC/Stack.hs @@ -85,7 +85,10 @@ popCallStack stk = case stk of -- -- @since 4.9.0.0 callStack :: HasCallStack => CallStack -callStack = popCallStack ?callStack +callStack = + case ?callStack of + EmptyCallStack -> EmptyCallStack + _ -> popCallStack ?callStack {-# INLINE callStack #-} -- | Perform some computation without adding new entries to the 'CallStack'. diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc index 51eb6244a4..ba384a13b4 100644 --- a/libraries/base/GHC/Stack/CCS.hsc +++ b/libraries/base/GHC/Stack/CCS.hsc @@ -48,34 +48,50 @@ import GHC.List ( concatMap, reverse ) #define PROFILING #include "Rts.h" +-- | A cost-centre stack from GHC's cost-center profiler. data CostCentreStack + +-- | A cost-centre from GHC's cost-center profiler. data CostCentre +-- | Returns the current 'CostCentreStack' (value is @nullPtr@ if the current +-- program was not compiled with profiling support). Takes a dummy argument +-- which can be used to avoid the call to @getCurrentCCS@ being floated out by +-- the simplifier, which would result in an uninformative stack ("CAF"). getCurrentCCS :: dummy -> IO (Ptr CostCentreStack) getCurrentCCS dummy = IO $ \s -> case getCurrentCCS## dummy s of (## s', addr ##) -> (## s', Ptr addr ##) +-- | Get the 'CostCentreStack' associated with the given value. getCCSOf :: a -> IO (Ptr CostCentreStack) getCCSOf obj = IO $ \s -> case getCCSOf## obj s of (## s', addr ##) -> (## s', Ptr addr ##) +-- | Run a computation with an empty cost-center stack. For example, this is +-- used by the interpreter to run an interpreted computation without the call +-- stack showing that it was invoked from GHC. clearCCS :: IO a -> IO a clearCCS (IO m) = IO $ \s -> clearCCS## m s +-- | Get the 'CostCentre' at the head of a 'CostCentreStack'. ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) ccsCC p = (# peek CostCentreStack, cc) p +-- | Get the tail of a 'CostCentreStack'. ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack) ccsParent p = (# peek CostCentreStack, prevStack) p +-- | Get the label of a 'CostCentre'. ccLabel :: Ptr CostCentre -> IO CString ccLabel p = (# peek CostCentre, label) p +-- | Get the module of a 'CostCentre'. ccModule :: Ptr CostCentre -> IO CString ccModule p = (# peek CostCentre, module) p +-- | Get the source span of a 'CostCentre'. ccSrcSpan :: Ptr CostCentre -> IO CString ccSrcSpan p = (# peek CostCentre, srcloc) p @@ -92,6 +108,7 @@ ccSrcSpan p = (# peek CostCentre, srcloc) p currentCallStack :: IO [String] currentCallStack = ccsToStrings =<< getCurrentCCS () +-- | Format a 'CostCentreStack' as a list of lines. ccsToStrings :: Ptr CostCentreStack -> IO [String] ccsToStrings ccs0 = go ccs0 [] where diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs index 54352b19de..45b11216a5 100644 --- a/libraries/base/GHC/Stack/Types.hs +++ b/libraries/base/GHC/Stack/Types.hs @@ -51,8 +51,9 @@ import GHC.Classes (Eq) import GHC.Types (Char, Int) -- Make implicit dependency known to build system -import GHC.Tuple () -import GHC.Integer () +import GHC.Tuple () -- See Note [Depend on GHC.Tuple] in GHC.Base +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base +import GHC.Natural () -- See Note [Depend on GHC.Natural] in GHC.Base ---------------------------------------------------------------------- -- Explicit call-stacks built via ImplicitParams @@ -75,25 +76,28 @@ type HasCallStack = (?callStack :: CallStack) -- For example, we can define -- -- @ --- errorWithCallStack :: HasCallStack => String -> a +-- putStrLnWithCallStack :: HasCallStack => String -> IO () -- @ -- --- as a variant of @error@ that will get its call-site. We can access the --- call-stack inside @errorWithCallStack@ with 'GHC.Stack.callStack'. +-- as a variant of @putStrLn@ that will get its call-site and print it, +-- along with the string given as argument. We can access the +-- call-stack inside @putStrLnWithCallStack@ with 'GHC.Stack.callStack'. -- -- @ --- errorWithCallStack :: HasCallStack => String -> a --- errorWithCallStack msg = error (msg ++ "\n" ++ prettyCallStack callStack) +-- putStrLnWithCallStack :: HasCallStack => String -> IO () +-- putStrLnWithCallStack msg = do +-- putStrLn msg +-- putStrLn (prettyCallStack callStack) -- @ -- --- Thus, if we call @errorWithCallStack@ we will get a formatted call-stack --- alongside our error message. +-- Thus, if we call @putStrLnWithCallStack@ we will get a formatted call-stack +-- alongside our string. -- -- --- >>> errorWithCallStack "die" --- *** Exception: die +-- >>> putStrLnWithCallStack "hello" +-- hello -- CallStack (from HasCallStack): --- errorWithCallStack, called at <interactive>:2:1 in interactive:Ghci1 +-- putStrLnWithCallStack, called at <interactive>:2:1 in interactive:Ghci1 -- -- -- GHC solves 'HasCallStack' constraints in three steps: @@ -212,4 +216,4 @@ data SrcLoc = SrcLoc , srcLocStartCol :: Int , srcLocEndLine :: Int , srcLocEndCol :: Int - } deriving Eq + } deriving Eq -- ^ @since 4.9.0.0 diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs index 65ec483577..42ca0927dc 100644 --- a/libraries/base/GHC/StaticPtr.hs +++ b/libraries/base/GHC/StaticPtr.hs @@ -28,6 +28,11 @@ -- table is known as the Static Pointer Table. The reference can then be -- dereferenced to obtain the value. -- +-- The various communicating processes need to aggree on the keys used to refer +-- to the values in the Static Pointer Table, or lookups will fail. Only +-- processes launched from the same program binary are guaranteed to use the +-- same set of keys. +-- ----------------------------------------------------------------------------- module GHC.StaticPtr @@ -54,7 +59,7 @@ import GHC.Word (Word64(..)) #include "MachDeps.h" --- | A reference to a value of type 'a'. +-- | A reference to a value of type @a@. #if WORD_SIZE_IN_BITS < 64 data StaticPtr a = StaticPtr Word64# Word64# -- The flattened Fingerprint is -- convenient in the compiler. @@ -67,7 +72,7 @@ data StaticPtr a = StaticPtr Word# Word# deRefStaticPtr :: StaticPtr a -> a deRefStaticPtr (StaticPtr _ _ _ v) = v --- | A key for `StaticPtrs` that can be serialized and used with +-- | A key for 'StaticPtr's that can be serialized and used with -- 'unsafeLookupStaticPtr'. type StaticKey = Fingerprint @@ -110,7 +115,7 @@ data StaticPtrInfo = StaticPtrInfo -- @(Line, Column)@ pair. , spInfoSrcLoc :: (Int, Int) } - deriving (Show) + deriving Show -- ^ @since 4.8.0.0 -- | 'StaticPtrInfo' of the given 'StaticPtr'. staticPtrInfo :: StaticPtr a -> StaticPtrInfo diff --git a/libraries/base/GHC/Stats.hsc b/libraries/base/GHC/Stats.hsc index 58fb12592f..58b5e22d04 100644 --- a/libraries/base/GHC/Stats.hsc +++ b/libraries/base/GHC/Stats.hsc @@ -18,20 +18,12 @@ module GHC.Stats RTSStats(..), GCDetails(..), RtsTime , getRTSStats , getRTSStatsEnabled - - -- * DEPRECATED, don't use - , GCStats(..) - , getGCStats - , getGCStatsEnabled ) where -import Control.Applicative import Control.Monad import Data.Int import Data.Word import GHC.Base -import GHC.Num (Num(..)) -import GHC.Real (quot, fromIntegral, (/)) import GHC.Read ( Read ) import GHC.Show ( Show ) import GHC.IO.Exception @@ -45,14 +37,14 @@ foreign import ccall "getRTSStats" getRTSStats_ :: Ptr () -> IO () -- | Returns whether GC stats have been enabled (with @+RTS -T@, for example). -- --- @since 4.9.0.0 +-- @since 4.10.0.0 foreign import ccall "getRTSStatsEnabled" getRTSStatsEnabled :: IO Bool -- -- | Statistics about runtime activity since the start of the -- program. This is a mirror of the C @struct RTSStats@ in @RtsAPI.h@ -- --- @since 4.9.0.0 +-- @since 4.10.0.0 -- data RTSStats = RTSStats { -- ----------------------------------- @@ -64,7 +56,8 @@ data RTSStats = RTSStats { , major_gcs :: Word32 -- | Total bytes allocated , allocated_bytes :: Word64 - -- | Maximum live data (including large objects + compact regions) + -- | Maximum live data (including large objects + compact regions) in the + -- heap. Updated after a major GC. , max_live_bytes :: Word64 -- | Maximum live data in large objects , max_large_objects_bytes :: Word64 @@ -91,6 +84,12 @@ data RTSStats = RTSStats { -- (we use signed values here because due to inaccuracies in timers -- the values can occasionally go slightly negative) + -- | Total CPU time used by the init phase + -- @since 4.12.0.0 + , init_cpu_ns :: RtsTime + -- | Total elapsed time used by the init phase + -- @since 4.12.0.0 + , init_elapsed_ns :: RtsTime -- | Total CPU time used by the mutator , mutator_cpu_ns :: RtsTime -- | Total elapsed time used by the mutator @@ -106,7 +105,9 @@ data RTSStats = RTSStats { -- | Details about the most recent GC , gc :: GCDetails - } deriving (Read, Show) + } deriving ( Read -- ^ @since 4.10.0.0 + , Show -- ^ @since 4.10.0.0 + ) -- -- | Statistics about a single GC. This is a mirror of the C @struct @@ -120,7 +121,9 @@ data GCDetails = GCDetails { , gcdetails_threads :: Word32 -- | Number of bytes allocated since the previous GC , gcdetails_allocated_bytes :: Word64 - -- | Total amount of live data in the heap (incliudes large + compact data) + -- | Total amount of live data in the heap (incliudes large + compact data). + -- Updated after every GC. Data in uncollected generations (in minor GCs) + -- are considered live. , gcdetails_live_bytes :: Word64 -- | Total amount of live data in large objects , gcdetails_large_objects_bytes :: Word64 @@ -143,21 +146,25 @@ data GCDetails = GCDetails { , gcdetails_cpu_ns :: RtsTime -- | The time elapsed during GC itself , gcdetails_elapsed_ns :: RtsTime - } deriving (Read, Show) + } deriving ( Read -- ^ @since 4.10.0.0 + , Show -- ^ @since 4.10.0.0 + ) -- | Time values from the RTS, using a fixed resolution of nanoseconds. type RtsTime = Int64 --- @since 4.9.0.0 +-- | Get current runtime system statistics. +-- +-- @since 4.10.0.0 -- getRTSStats :: IO RTSStats getRTSStats = do - statsEnabled <- getGCStatsEnabled + statsEnabled <- getRTSStatsEnabled unless statsEnabled . ioError $ IOError Nothing UnsupportedOperation "" - "getGCStats: GC stats not enabled. Use `+RTS -T -RTS' to enable them." + "GHC.Stats.getRTSStats: GC stats not enabled. Use `+RTS -T -RTS' to enable them." Nothing Nothing allocaBytes (#size RTSStats) $ \p -> do @@ -177,6 +184,8 @@ getRTSStats = do (# peek RTSStats, cumulative_par_max_copied_bytes) p cumulative_par_balanced_copied_bytes <- (# peek RTSStats, cumulative_par_balanced_copied_bytes) p + init_cpu_ns <- (# peek RTSStats, init_cpu_ns) p + init_elapsed_ns <- (# peek RTSStats, init_elapsed_ns) p mutator_cpu_ns <- (# peek RTSStats, mutator_cpu_ns) p mutator_elapsed_ns <- (# peek RTSStats, mutator_elapsed_ns) p gc_cpu_ns <- (# peek RTSStats, gc_cpu_ns) p @@ -204,136 +213,3 @@ getRTSStats = do gcdetails_elapsed_ns <- (# peek GCDetails, elapsed_ns) pgc return GCDetails{..} return RTSStats{..} - --- ----------------------------------------------------------------------------- --- DEPRECATED API - --- I'm probably violating a bucket of constraints here... oops. - --- | Statistics about memory usage and the garbage collector. Apart from --- 'currentBytesUsed' and 'currentBytesSlop' all are cumulative values since --- the program started. --- --- @since 4.5.0.0 -{-# DEPRECATED GCStats "Use RTSStats instead. This will be removed in GHC 8.4.1" #-} -data GCStats = GCStats - { -- | Total number of bytes allocated - bytesAllocated :: !Int64 - -- | Number of garbage collections performed (any generation, major and - -- minor) - , numGcs :: !Int64 - -- | Maximum number of live bytes seen so far - , maxBytesUsed :: !Int64 - -- | Number of byte usage samples taken, or equivalently - -- the number of major GCs performed. - , numByteUsageSamples :: !Int64 - -- | Sum of all byte usage samples, can be used with - -- 'numByteUsageSamples' to calculate averages with - -- arbitrary weighting (if you are sampling this record multiple - -- times). - , cumulativeBytesUsed :: !Int64 - -- | Number of bytes copied during GC - , bytesCopied :: !Int64 - -- | Number of live bytes at the end of the last major GC - , currentBytesUsed :: !Int64 - -- | Current number of bytes lost to slop - , currentBytesSlop :: !Int64 - -- | Maximum number of bytes lost to slop at any one time so far - , maxBytesSlop :: !Int64 - -- | Maximum number of megabytes allocated - , peakMegabytesAllocated :: !Int64 - -- | CPU time spent running mutator threads. This does not include - -- any profiling overhead or initialization. - , mblocksAllocated :: !Int64 -- ^ Number of allocated megablocks - , mutatorCpuSeconds :: !Double - - -- | Wall clock time spent running mutator threads. This does not - -- include initialization. - , mutatorWallSeconds :: !Double - -- | CPU time spent running GC - , gcCpuSeconds :: !Double - -- | Wall clock time spent running GC - , gcWallSeconds :: !Double - -- | Total CPU time elapsed since program start - , cpuSeconds :: !Double - -- | Total wall clock time elapsed since start - , wallSeconds :: !Double - -- | Number of bytes copied during GC, minus space held by mutable - -- lists held by the capabilities. Can be used with - -- 'parMaxBytesCopied' to determine how well parallel GC utilized - -- all cores. - , parTotBytesCopied :: !Int64 - - -- | Sum of number of bytes copied each GC by the most active GC - -- thread each GC. The ratio of 'parTotBytesCopied' divided by - -- 'parMaxBytesCopied' approaches 1 for a maximally sequential - -- run and approaches the number of threads (set by the RTS flag - -- @-N@) for a maximally parallel run. This is included for - -- backwards compatibility; to compute work balance use - -- `parBalancedBytesCopied`. - , parMaxBytesCopied :: !Int64 - - -- | Sum of number of balanced bytes copied on each thread of each GC. - -- Balanced bytes are those up to a - -- limit = (parTotBytesCopied / num_gc_threads). - -- This number is normalized so that when balance is perfect - -- @parBalancedBytesCopied = parTotBytesCopied@ and when all - -- gc is done by a single thread @parBalancedBytesCopied = 0@. - , parBalancedBytesCopied :: !Int64 - - } deriving (Show, Read) - --- | Retrieves garbage collection and memory statistics as of the last --- garbage collection. If you would like your statistics as recent as --- possible, first run a 'System.Mem.performGC'. --- --- @since 4.5.0.0 -{-# DEPRECATED getGCStats - "Use getRTSStats instead. This will be removed in GHC 8.4.1" #-} -getGCStats :: IO GCStats -getGCStats = do - statsEnabled <- getGCStatsEnabled - unless statsEnabled . ioError $ IOError - Nothing - UnsupportedOperation - "" - "getGCStats: GC stats not enabled. Use `+RTS -T -RTS' to enable them." - Nothing - Nothing - allocaBytes (#size RTSStats) $ \p -> do - getRTSStats_ p - bytesAllocated <- (# peek RTSStats, allocated_bytes) p - numGcs <- (# peek RTSStats, gcs ) p - numByteUsageSamples <- (# peek RTSStats, major_gcs ) p - maxBytesUsed <- (# peek RTSStats, max_live_bytes ) p - cumulativeBytesUsed <- (# peek RTSStats, cumulative_live_bytes ) p - bytesCopied <- (# peek RTSStats, copied_bytes ) p - currentBytesUsed <- (# peek RTSStats, gc.live_bytes ) p - currentBytesSlop <- (# peek RTSStats, gc.slop_bytes) p - maxBytesSlop <- (# peek RTSStats, max_slop_bytes) p - peakMegabytesAllocated <- do - bytes <- (# peek RTSStats, max_mem_in_use_bytes ) p - return (bytes `quot` (1024*1024)) - mblocksAllocated <- do - bytes <- (# peek RTSStats, gc.mem_in_use_bytes) p - return (bytes `quot` (1024*1024)) - mutatorCpuSeconds <- nsToSecs <$> (# peek RTSStats, mutator_cpu_ns) p - mutatorWallSeconds <- - nsToSecs <$> (# peek RTSStats, mutator_elapsed_ns) p - gcCpuSeconds <- nsToSecs <$> (# peek RTSStats, gc_cpu_ns) p - gcWallSeconds <- nsToSecs <$> (# peek RTSStats, gc_elapsed_ns) p - cpuSeconds <- nsToSecs <$> (# peek RTSStats, cpu_ns) p - wallSeconds <- nsToSecs <$> (# peek RTSStats, elapsed_ns) p - parTotBytesCopied <- (# peek RTSStats, par_copied_bytes) p - parMaxBytesCopied <- (# peek RTSStats, cumulative_par_max_copied_bytes) p - parBalancedBytesCopied <- - (# peek RTSStats, cumulative_par_balanced_copied_bytes) p - return GCStats { .. } - -nsToSecs :: Int64 -> Double -nsToSecs ns = fromIntegral ns / (# const TIME_RESOLUTION) - -{-# DEPRECATED getGCStatsEnabled - "use getRTSStatsEnabled instead. This will be removed in GHC 8.4.1" #-} -getGCStatsEnabled :: IO Bool -getGCStatsEnabled = getRTSStatsEnabled diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs index 0964db98ba..7e3e514be9 100644 --- a/libraries/base/GHC/TypeLits.hs +++ b/libraries/base/GHC/TypeLits.hs @@ -9,7 +9,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -- for compiling instances of (==) {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} @@ -35,6 +34,7 @@ module GHC.TypeLits -- * Functions on type literals , type (N.<=), type (N.<=?), type (N.+), type (N.*), type (N.^), type (N.-) + , type N.Div, type N.Mod, type N.Log2 , AppendSymbol , N.CmpNat, CmpSymbol @@ -44,7 +44,7 @@ module GHC.TypeLits ) where -import GHC.Base(Eq(..), Ord(..), Bool(True,False), Ordering(..), otherwise) +import GHC.Base(Eq(..), Ord(..), Ordering(..), otherwise) import GHC.Types( Nat, Symbol ) import GHC.Num(Integer, fromInteger) import GHC.Base(String) @@ -54,7 +54,7 @@ import GHC.Real(toInteger) import GHC.Prim(magicDict, Proxy#) import Data.Maybe(Maybe(..)) import Data.Proxy (Proxy(..)) -import Data.Type.Equality(type (==), (:~:)(Refl)) +import Data.Type.Equality((:~:)(Refl)) import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats (KnownNat) @@ -122,11 +122,6 @@ instance Show SomeSymbol where instance Read SomeSymbol where readsPrec p xs = [ (someSymbolVal a, ys) | (a,ys) <- readsPrec p xs ] -type family EqSymbol (a :: Symbol) (b :: Symbol) where - EqSymbol a a = 'True - EqSymbol a b = 'False -type instance a == b = EqSymbol a b - -------------------------------------------------------------------------------- -- | Comparison of type-level symbols, as a function. @@ -158,7 +153,7 @@ data {-kind-} ErrorMessage = Text Symbol infixl 5 :$$: infixl 6 :<>: --- | The type-level equivalent of 'error'. +-- | The type-level equivalent of 'Prelude.error'. -- -- The polymorphic kind of this type allows it to be used in several settings. -- For instance, it can be used as a constraint, e.g. to provide a better error diff --git a/libraries/base/GHC/TypeNats.hs b/libraries/base/GHC/TypeNats.hs index cb75367ac8..b78608af89 100644 --- a/libraries/base/GHC/TypeNats.hs +++ b/libraries/base/GHC/TypeNats.hs @@ -3,13 +3,13 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -- for compiling instances of (==) {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} @@ -34,10 +34,11 @@ module GHC.TypeNats -- * Functions on type literals , type (<=), type (<=?), type (+), type (*), type (^), type (-) , CmpNat + , Div, Mod, Log2 ) where -import GHC.Base(Eq(..), Ord(..), Bool(True,False), Ordering(..), otherwise) +import GHC.Base(Eq(..), Ord(..), Bool(True), Ordering(..), otherwise) import GHC.Types( Nat ) import GHC.Natural(Natural) import GHC.Show(Show(..)) @@ -45,7 +46,7 @@ import GHC.Read(Read(..)) import GHC.Prim(magicDict, Proxy#) import Data.Maybe(Maybe(..)) import Data.Proxy (Proxy(..)) -import Data.Type.Equality(type (==), (:~:)(Refl)) +import Data.Type.Equality((:~:)(Refl)) import Unsafe.Coerce(unsafeCoerce) -------------------------------------------------------------------------------- @@ -95,19 +96,16 @@ instance Read SomeNat where readsPrec p xs = do (a,ys) <- readsPrec p xs [(someNatVal a, ys)] -type family EqNat (a :: Nat) (b :: Nat) where - EqNat a a = 'True - EqNat a b = 'False -type instance a == b = EqNat a b - -------------------------------------------------------------------------------- infix 4 <=?, <= infixl 6 +, - -infixl 7 * +infixl 7 *, `Div`, `Mod` infixr 8 ^ -- | Comparison of type-level naturals, as a constraint. +-- +-- @since 4.7.0.0 type x <= y = (x <=? y) ~ 'True -- | Comparison of type-level naturals, as a function. @@ -122,12 +120,18 @@ Please let us know, if you encounter discrepancies between the two. -} type family (m :: Nat) <=? (n :: Nat) :: Bool -- | Addition of type-level naturals. +-- +-- @since 4.7.0.0 type family (m :: Nat) + (n :: Nat) :: Nat -- | Multiplication of type-level naturals. +-- +-- @since 4.7.0.0 type family (m :: Nat) * (n :: Nat) :: Nat -- | Exponentiation of type-level naturals. +-- +-- @since 4.7.0.0 type family (m :: Nat) ^ (n :: Nat) :: Nat -- | Subtraction of type-level naturals. @@ -135,6 +139,24 @@ type family (m :: Nat) ^ (n :: Nat) :: Nat -- @since 4.7.0.0 type family (m :: Nat) - (n :: Nat) :: Nat +-- | Division (round down) of natural numbers. +-- @Div x 0@ is undefined (i.e., it cannot be reduced). +-- +-- @since 4.11.0.0 +type family Div (m :: Nat) (n :: Nat) :: Nat + +-- | Modulus of natural numbers. +-- @Mod x 0@ is undefined (i.e., it cannot be reduced). +-- +-- @since 4.11.0.0 +type family Mod (m :: Nat) (n :: Nat) :: Nat + +-- | Log base 2 (round down) of natural numbers. +-- @Log 0@ is undefined (i.e., it cannot be reduced). +-- +-- @since 4.11.0.0 +type family Log2 (m :: Nat) :: Nat + -------------------------------------------------------------------------------- -- | We either get evidence that this function was instantiated with the diff --git a/libraries/base/GHC/Unicode.hs b/libraries/base/GHC/Unicode.hs index 0e2ce4c0ef..6d453cbc9a 100644 --- a/libraries/base/GHC/Unicode.hs +++ b/libraries/base/GHC/Unicode.hs @@ -7,7 +7,7 @@ -- Module : GHC.Unicode -- Copyright : (c) The University of Glasgow, 2003 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC extensions) @@ -71,7 +71,7 @@ import GHC.Show ( Show ) -- >>> enumFromTo ModifierLetter SpacingCombiningMark -- [ModifierLetter,OtherLetter,NonSpacingMark,SpacingCombiningMark] -- --- 'Read' instance: +-- 'Text.Read.Read' instance: -- -- >>> read "DashPunctuation" :: GeneralCategory -- DashPunctuation @@ -129,7 +129,13 @@ data GeneralCategory | Surrogate -- ^ Cs: Other, Surrogate | PrivateUse -- ^ Co: Other, Private Use | NotAssigned -- ^ Cn: Other, Not Assigned - deriving (Show, Eq, Ord, Enum, Bounded, Ix) + deriving ( Show -- ^ @since 2.01 + , Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Enum -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Ix -- ^ @since 2.01 + ) -- | The Unicode general category of the character. This relies on the -- 'Enum' instance of 'GeneralCategory', which must remain in the @@ -214,11 +220,12 @@ isLower :: Char -> Bool -- This function is equivalent to 'Data.Char.isLetter'. isAlpha :: Char -> Bool --- | Selects alphabetic or numeric digit Unicode characters. +-- | Selects alphabetic or numeric Unicode characters. -- --- Note that numeric digits outside the ASCII range are selected by this --- function but not by 'isDigit'. Such digits may be part of identifiers --- but are not used by the printer and reader to represent numbers. +-- Note that numeric digits outside the ASCII range, as well as numeric +-- characters which aren't digits, are selected by this function but not by +-- 'isDigit'. Such characters may be part of identifiers but are not used by +-- the printer and reader to represent numbers. isAlphaNum :: Char -> Bool -- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@. @@ -394,4 +401,3 @@ foreign import ccall unsafe "u_towtitle" foreign import ccall unsafe "u_gencat" wgencat :: Int -> Int - diff --git a/libraries/base/GHC/Weak.hs b/libraries/base/GHC/Weak.hs index 8f886a6d23..6a53096828 100644 --- a/libraries/base/GHC/Weak.hs +++ b/libraries/base/GHC/Weak.hs @@ -149,8 +149,9 @@ runFinalizerBatch (I# n) arr = 0# -> (# s, () #) _ -> let !m' = m -# 1# in case indexArray# arr m' of { (# io #) -> - case io s of { s' -> - unIO (go m') s' + case catch# (\p -> (# io p, () #)) + (\_ s'' -> (# s'', () #)) s of { + (# s', _ #) -> unIO (go m') s' }} in go n diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 1df9d14693..18cc4dbcc4 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -972,3 +972,33 @@ byteSwap64 (W64# w#) = W64# (byteSwap64# w#) byteSwap64 :: Word64 -> Word64 byteSwap64 (W64# w#) = W64# (byteSwap# w#) #endif + +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Word8" + fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord +"fromIntegral/Natural->Word16" + fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord +"fromIntegral/Natural->Word32" + fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord + #-} + +{-# RULES +"fromIntegral/Word8->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) +"fromIntegral/Word16->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) +"fromIntegral/Word32->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 +{-# RULES +"fromIntegral/Natural->Word64" + fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord +"fromIntegral/Word64->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) + #-} +#endif diff --git a/libraries/base/Numeric.hs b/libraries/base/Numeric.hs index e8b0b91eed..00e5f674de 100644 --- a/libraries/base/Numeric.hs +++ b/libraries/base/Numeric.hs @@ -33,6 +33,7 @@ module Numeric ( showFFloatAlt, showGFloatAlt, showFloat, + showHFloat, floatToDigits, @@ -69,6 +70,7 @@ import GHC.Show import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail ) import qualified Text.Read.Lex as L + -- ----------------------------------------------------------------------------- -- Reading @@ -81,15 +83,24 @@ readInt :: Num a readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit) -- | Read an unsigned number in octal notation. +-- +-- >>> readOct "0644" +-- [(420,"")] readOct :: (Eq a, Num a) => ReadS a readOct = readP_to_S L.readOctP -- | Read an unsigned number in decimal notation. +-- +-- >>> readDec "0644" +-- [(644,"")] readDec :: (Eq a, Num a) => ReadS a readDec = readP_to_S L.readDecP -- | Read an unsigned number in hexadecimal notation. -- Both upper or lower case letters are allowed. +-- +-- >>> readHex "deadbeef" +-- [(3735928559,"")] readHex :: (Eq a, Num a) => ReadS a readHex = readP_to_S L.readHexP @@ -204,6 +215,52 @@ showGFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS showFFloatAlt d x = showString (formatRealFloatAlt FFFixed d True x) showGFloatAlt d x = showString (formatRealFloatAlt FFGeneric d True x) +{- | Show a floating-point value in the hexadecimal format, +similar to the @%a@ specifier in C's printf. + + >>> showHFloat (212.21 :: Double) "" + "0x1.a86b851eb851fp7" + >>> showHFloat (-12.76 :: Float) "" + "-0x1.9851ecp3" + >>> showHFloat (-0 :: Double) "" + "-0x0p+0" +-} +showHFloat :: RealFloat a => a -> ShowS +showHFloat = showString . fmt + where + fmt x + | isNaN x = "NaN" + | isInfinite x = (if x < 0 then "-" else "") ++ "Infinity" + | x < 0 || isNegativeZero x = '-' : cvt (-x) + | otherwise = cvt x + + cvt x + | x == 0 = "0x0p+0" + | otherwise = + case floatToDigits 2 x of + r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r + (d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e-1) + + -- Given binary digits, convert them to hex in blocks of 4 + -- Special case: If all 0's, just drop it. + frac digits + | allZ digits = "" + | otherwise = "." ++ hex digits + where + hex ds = + case ds of + [] -> "" + [a] -> hexDigit a 0 0 0 "" + [a,b] -> hexDigit a b 0 0 "" + [a,b,c] -> hexDigit a b c 0 "" + a : b : c : d : r -> hexDigit a b c d (hex r) + + hexDigit a b c d = showHex (8*a + 4*b + 2*c + d) + + allZ xs = case xs of + x : more -> x == 0 && allZ more + [] -> True + -- --------------------------------------------------------------------------- -- Integer printing functions diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs index 158cc0a8ff..15e392f271 100644 --- a/libraries/base/Prelude.hs +++ b/libraries/base/Prelude.hs @@ -66,7 +66,8 @@ module Prelude ( subtract, even, odd, gcd, lcm, (^), (^^), fromIntegral, realToFrac, - -- ** Monoids + -- ** Semigroups and Monoids + Semigroup((<>)), Monoid(mempty, mappend, mconcat), -- ** Monads and functors diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs index 56e6961f8a..5604ca2b03 100644 --- a/libraries/base/System/Environment.hs +++ b/libraries/base/System/Environment.hs @@ -38,13 +38,13 @@ import Control.Exception.Base (bracket) #endif -- import GHC.IO import GHC.IO.Exception -import GHC.IO.Encoding (getFileSystemEncoding) import qualified GHC.Foreign as GHC import Control.Monad #if defined(mingw32_HOST_OS) -import GHC.Environment +import GHC.IO.Encoding (argvEncoding) import GHC.Windows #else +import GHC.IO.Encoding (getFileSystemEncoding, argvEncoding) import System.Posix.Internals (withFilePath) #endif @@ -65,89 +65,21 @@ import System.Environment.ExecutablePath -- --------------------------------------------------------------------------- -- getArgs, getProgName, getEnv -#if defined(mingw32_HOST_OS) - -{- -Note [Ignore hs_init argv] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ignore the arguments to hs_init on Windows for the sake of Unicode compat - -Instead on Windows we get the list of arguments from getCommandLineW and -filter out arguments which the RTS would not have passed along. - -This is done to ensure we get the arguments in proper Unicode Encoding which -the RTS at this moment does not seem provide. The filtering has to match the -one done by the RTS to avoid inconsistencies like #13287. --} - -getWin32ProgArgv_certainly :: IO [String] -getWin32ProgArgv_certainly = do - mb_argv <- getWin32ProgArgv - case mb_argv of - -- see Note [Ignore hs_init argv] - Nothing -> fmap dropRTSArgs getFullArgs - Just argv -> return argv - -withWin32ProgArgv :: [String] -> IO a -> IO a -withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act) - where - begin = do - mb_old_argv <- getWin32ProgArgv - setWin32ProgArgv (Just argv) - return mb_old_argv - -getWin32ProgArgv :: IO (Maybe [String]) -getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do - c_getWin32ProgArgv p_argc p_argv - argc <- peek p_argc - argv_p <- peek p_argv - if argv_p == nullPtr - then return Nothing - else do - argv_ps <- peekArray (fromIntegral argc) argv_p - fmap Just $ mapM peekCWString argv_ps - -setWin32ProgArgv :: Maybe [String] -> IO () -setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr -setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do - c_setWin32ProgArgv (fromIntegral argc) argv_p - -foreign import ccall unsafe "getWin32ProgArgv" - c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO () - -foreign import ccall unsafe "setWin32ProgArgv" - c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO () - --- See Note [Ignore hs_init argv] -dropRTSArgs :: [String] -> [String] -dropRTSArgs [] = [] -dropRTSArgs rest@("--":_) = rest -dropRTSArgs ("+RTS":rest) = dropRTSArgs (dropWhile (/= "-RTS") rest) -dropRTSArgs ("--RTS":rest) = rest -dropRTSArgs ("-RTS":rest) = dropRTSArgs rest -dropRTSArgs (arg:rest) = arg : dropRTSArgs rest - -#endif - -- | Computation 'getArgs' returns a list of the program's command -- line arguments (not including the program name). getArgs :: IO [String] - -#if defined(mingw32_HOST_OS) -getArgs = fmap tail getWin32ProgArgv_certainly -#else getArgs = alloca $ \ p_argc -> alloca $ \ p_argv -> do getProgArgv p_argc p_argv p <- fromIntegral `liftM` peek p_argc argv <- peek p_argv - enc <- getFileSystemEncoding + enc <- argvEncoding peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc) + foreign import ccall unsafe "getProgArgv" getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () -#endif {-| Computation 'getProgName' returns the name of the program as it was @@ -160,10 +92,7 @@ between platforms: on Windows, for example, a program invoked as foo is probably really @FOO.EXE@, and that is what 'getProgName' will return. -} getProgName :: IO String -#if defined(mingw32_HOST_OS) -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat -getProgName = fmap (basename . head) getWin32ProgArgv_certainly -#else getProgName = alloca $ \ p_argc -> alloca $ \ p_argv -> do @@ -173,10 +102,9 @@ getProgName = unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] unpackProgName argv = do - enc <- getFileSystemEncoding + enc <- argvEncoding s <- peekElemOff argv 0 >>= GHC.peekCString enc return (basename s) -#endif basename :: FilePath -> FilePath basename f = go f f @@ -195,8 +123,8 @@ basename f = go f f -- | Computation 'getEnv' @var@ returns the value --- of the environment variable @var@. For the inverse, POSIX users --- can use 'System.Posix.Env.putEnv'. +-- of the environment variable @var@. For the inverse, the +-- `System.Environment.setEnv` function can be used. -- -- This computation may fail with: -- @@ -262,9 +190,10 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv" -- | @setEnv name value@ sets the specified environment variable to @value@. -- --- On Windows setting an environment variable to the /empty string/ removes +-- Early versions of this function operated under the mistaken belief that +-- setting an environment variable to the /empty string/ on Windows removes -- that environment variable from the environment. For the sake of --- compatibility we adopt that behavior. In particular +-- compatibility, it adopted that behavior on POSIX. In particular -- -- @ -- setEnv name \"\" @@ -276,9 +205,8 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv" -- `unsetEnv` name -- @ -- --- If you don't care about Windows support and want to set an environment --- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@ --- package instead. +-- If you'd like to be able to set environment variables to blank strings, +-- use `System.Environment.Blank.setEnv`. -- -- Throws `Control.Exception.IOException` if @name@ is the empty string or -- contains an equals sign. @@ -371,15 +299,7 @@ withProgName nm act = do -- the duration of an action. withArgv :: [String] -> IO a -> IO a - -#if defined(mingw32_HOST_OS) --- We have to reflect the updated arguments in the RTS-side variables as --- well, because the RTS still consults them for error messages and the like. --- If we don't do this then ghc-e005 fails. -withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act -#else withArgv = withProgArgv -#endif withProgArgv :: [String] -> IO a -> IO a withProgArgv new_args act = do @@ -391,7 +311,7 @@ withProgArgv new_args act = do setProgArgv :: [String] -> IO () setProgArgv argv = do - enc <- getFileSystemEncoding + enc <- argvEncoding GHC.withCStringsLen enc argv $ \len css -> c_setProgArgv (fromIntegral len) css diff --git a/libraries/base/System/Environment/Blank.hsc b/libraries/base/System/Environment/Blank.hsc new file mode 100644 index 0000000000..637a039809 --- /dev/null +++ b/libraries/base/System/Environment/Blank.hsc @@ -0,0 +1,193 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE CApiFFI #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Environment.Blank +-- Copyright : (c) Habib Alamin 2017 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A setEnv implementation that allows blank environment variables. Mimics +-- the `System.Posix.Env` module from the @unix@ package, but with support +-- for Windows too. +-- +-- The matrix of platforms that: +-- +-- * support @putenv("FOO")@ to unset environment variables, +-- * support @putenv("FOO=")@ to unset environment variables or set them +-- to blank values, +-- * support @unsetenv@ to unset environment variables, +-- * support @setenv@ to set environment variables, +-- * etc. +-- +-- is very complicated. Some platforms don't support unsetting of environment +-- variables at all. +-- +----------------------------------------------------------------------------- + +module System.Environment.Blank + ( + module System.Environment, + getEnv, + getEnvDefault, + setEnv, + unsetEnv, + ) where + +import Foreign.C +#ifdef mingw32_HOST_OS +import Foreign.Ptr +import GHC.Windows +import Control.Monad +#else +import System.Posix.Internals +#endif +import GHC.IO.Exception +import System.IO.Error +import Control.Exception.Base +import Data.Maybe + +import System.Environment + ( + getArgs, + getProgName, + getExecutablePath, + withArgs, + withProgName, + getEnvironment + ) +#ifndef mingw32_HOST_OS +import qualified System.Environment as Environment +#endif + +-- TODO: include windows_cconv.h when it's merged, instead of duplicating +-- this C macro block. +#if defined(mingw32_HOST_OS) +# if defined(i386_HOST_ARCH) +## define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +## define WINDOWS_CCONV ccall +# else +## error Unknown mingw32 arch +# endif +#endif + +#include "HsBaseConfig.h" + +throwInvalidArgument :: String -> IO a +throwInvalidArgument from = + throwIO (mkIOError InvalidArgument from Nothing Nothing) + +-- | Similar to 'System.Environment.lookupEnv'. +getEnv :: String -> IO (Maybe String) +#ifdef mingw32_HOST_OS +getEnv = (<$> getEnvironment) . lookup +#else +getEnv = Environment.lookupEnv +#endif + +-- | Get an environment value or a default value. +getEnvDefault :: + String {- ^ variable name -} -> + String {- ^ fallback value -} -> + IO String {- ^ variable value or fallback value -} +getEnvDefault name fallback = fromMaybe fallback <$> getEnv name + +-- | Like 'System.Environment.setEnv', but allows blank environment values +-- and mimics the function signature of 'System.Posix.Env.setEnv' from the +-- @unix@ package. +setEnv :: + String {- ^ variable name -} -> + String {- ^ variable value -} -> + Bool {- ^ overwrite -} -> + IO () +setEnv key_ value_ overwrite + | null key = throwInvalidArgument "setEnv" + | '=' `elem` key = throwInvalidArgument "setEnv" + | otherwise = + if overwrite + then setEnv_ key value + else do + env_var <- getEnv key + case env_var of + Just _ -> return () + Nothing -> setEnv_ key value + where + key = takeWhile (/= '\NUL') key_ + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () +#if defined(mingw32_HOST_OS) +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool +#else +setEnv_ key value = + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum True)) + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt +#endif + +-- | Like 'System.Environment.unsetEnv', but allows for the removal of +-- blank environment variables. May throw an exception if the underlying +-- platform doesn't support unsetting of environment variables. +unsetEnv :: String -> IO () +#if defined(mingw32_HOST_OS) +unsetEnv key = withCWString key $ \k -> do + success <- c_SetEnvironmentVariable k nullPtr + unless success $ do + -- We consider unsetting an environment variable that does not exist not as + -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND. + err <- c_GetLastError + unless (err == eRROR_ENVVAR_NOT_FOUND) $ do + throwGetLastError "unsetEnv" + +eRROR_ENVVAR_NOT_FOUND :: DWORD +eRROR_ENVVAR_NOT_FOUND = 203 + +foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" + c_GetLastError:: IO DWORD +#elif HAVE_UNSETENV +# if !UNSETENV_RETURNS_VOID +unsetEnv name = withFilePath name $ \ s -> + throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) + +-- POSIX.1-2001 compliant unsetenv(3) +foreign import capi unsafe "HsBase.h unsetenv" + c_unsetenv :: CString -> IO CInt +# else +unsetEnv name = withFilePath name c_unsetenv + +-- pre-POSIX unsetenv(3) returning @void@ +foreign import capi unsafe "HsBase.h unsetenv" + c_unsetenv :: CString -> IO () +# endif +#else +unsetEnv name = + if '=' `elem` name + then throwInvalidArgument "unsetEnv" + else putEnv name + +putEnv :: String -> IO () +putEnv keyvalue = do + s <- getFileSystemEncoding >>= (`newCString` keyvalue) + -- IMPORTANT: Do not free `s` after calling putenv! + -- + -- According to SUSv2, the string passed to putenv becomes part of the + -- environment. #7342 + throwErrnoIf_ (/= 0) "putenv" (c_putenv s) + +foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt +#endif diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc index 8b6c7b6c57..095b25c236 100644 --- a/libraries/base/System/Environment/ExecutablePath.hsc +++ b/libraries/base/System/Environment/ExecutablePath.hsc @@ -33,11 +33,14 @@ import Foreign.C import Foreign.Marshal.Array import System.Posix.Internals #elif defined(mingw32_HOST_OS) +import Control.Exception +import Data.List import Data.Word import Foreign.C import Foreign.Marshal.Array import Foreign.Ptr -import System.Posix.Internals +#include <windows.h> +#include <stdint.h> #else import Foreign.C import Foreign.Marshal.Alloc @@ -54,6 +57,10 @@ import System.Posix.Internals -- Note that for scripts and interactive sessions, this is the path to -- the interpreter (e.g. ghci.) -- +-- Since base 4.11.0.0, 'getExecutablePath' resolves symlinks on Windows. +-- If an executable is launched through a symlink, 'getExecutablePath' +-- returns the absolute path of the original executable. +-- -- @since 4.6.0.0 getExecutablePath :: IO FilePath @@ -137,18 +144,87 @@ getExecutablePath = readSymbolicLink $ "/proc/self/exe" # error Unknown mingw32 arch # endif -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 - getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 where go size = allocaArray (fromIntegral size) $ \ buf -> do ret <- c_GetModuleFileName nullPtr buf size case ret of 0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error" - _ | ret < size -> peekFilePath buf + _ | ret < size -> do + path <- peekCWString buf + real <- getFinalPath path + exists <- withCWString real c_pathFileExists + if exists + then return real + else fail path | otherwise -> go (size * 2) +-- | Returns the final path of the given path. If the given +-- path is a symbolic link, the returned value is the +-- path the (possibly chain of) symbolic link(s) points to. +-- Otherwise, the original path is returned, even when the filepath +-- is incorrect. +-- +-- Adapted from: +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa364962.aspx +getFinalPath :: FilePath -> IO FilePath +getFinalPath path = withCWString path $ \s -> + bracket (createFile s) c_closeHandle $ \h -> do + let invalid = h == wordPtrToPtr (#const (intptr_t)INVALID_HANDLE_VALUE) + if invalid then pure path else go h bufSize + + where go h sz = allocaArray (fromIntegral sz) $ \outPath -> do + ret <- c_getFinalPathHandle h outPath sz (#const FILE_NAME_OPENED) + if ret < sz + then sanitize . rejectUNCPath <$> peekCWString outPath + else go h (2 * sz) + + sanitize s + | "\\\\?\\" `isPrefixOf` s = drop 4 s + | otherwise = s + + -- see https://ghc.haskell.org/trac/ghc/ticket/14460 + rejectUNCPath s + | "\\\\?\\UNC\\" `isPrefixOf` s = path + | otherwise = s + + -- the initial size of the buffer in which we store the + -- final path; if this is not enough, we try with a buffer of + -- size 2^k * bufSize, for k = 1, 2, 3, ... until the buffer + -- is large enough. + bufSize = 1024 + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 + +foreign import WINDOWS_CCONV unsafe "windows.h PathFileExistsW" + c_pathFileExists :: CWString -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" + c_createFile :: CWString + -> Word32 + -> Word32 + -> Ptr () + -> Word32 + -> Word32 + -> Ptr () + -> IO (Ptr ()) + +createFile :: CWString -> IO (Ptr ()) +createFile file = + c_createFile file (#const GENERIC_READ) + (#const FILE_SHARE_READ) + nullPtr + (#const OPEN_EXISTING) + (#const FILE_ATTRIBUTE_NORMAL) + nullPtr + +foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle" + c_closeHandle :: Ptr () -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetFinalPathNameByHandleW" + c_getFinalPathHandle :: Ptr () -> CWString -> Word32 -> Word32 -> IO Word32 + -------------------------------------------------------------------------------- -- Fallback to argv[0] diff --git a/libraries/base/System/Exit.hs b/libraries/base/System/Exit.hs index 4f73665c0e..e4f7b13e33 100644 --- a/libraries/base/System/Exit.hs +++ b/libraries/base/System/Exit.hs @@ -47,7 +47,7 @@ import GHC.IO.Exception -- -- As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses -- the error handling in the 'IO' monad and cannot be intercepted by --- 'catch' from the "Prelude". However it is a 'SomeException', and can +-- 'catch' from the "Prelude". However it is a 'Control.Exception.SomeException', and can -- be caught using the functions of "Control.Exception". This means -- that cleanup computations added with 'Control.Exception.bracket' -- (from "Control.Exception") are also executed properly on 'exitWith'. diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index fde5bb66e5..900963a045 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -226,6 +226,9 @@ import Data.Maybe import Foreign.C.Error #if defined(mingw32_HOST_OS) import Foreign.C.String +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Storable #endif import Foreign.C.Types import System.Posix.Internals @@ -233,7 +236,9 @@ import System.Posix.Types import GHC.Base import GHC.List +#ifndef mingw32_HOST_OS import GHC.IORef +#endif import GHC.Num import GHC.IO hiding ( bracket, onException ) import GHC.IO.IOMode @@ -376,7 +381,8 @@ hReady h = hWaitForInput h 0 -- -- * 'System.IO.Error.isFullError' if the device is full; or -- --- * 'System.IO.Error.isPermissionError' if another system resource limit would be exceeded. +-- * 'System.IO.Error.isPermissionError' if another system resource limit +-- would be exceeded. hPrint :: Show a => Handle -> a -> IO () hPrint hdl = hPutStrLn hdl . show @@ -386,7 +392,7 @@ hPrint hdl = hPutStrLn hdl . show -- closed on exit from 'withFile', whether by normal termination or by -- raising an exception. If closing the handle raises an exception, then -- this exception will be raised by 'withFile' rather than any exception --- raised by 'act'. +-- raised by @act@. withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r withFile name mode = bracket (openFile name mode) hClose @@ -400,10 +406,15 @@ withBinaryFile name mode = bracket (openBinaryFile name mode) hClose -- --------------------------------------------------------------------------- -- fixIO +-- | The implementation of 'Control.Monad.Fix.mfix' for 'IO'. If the function +-- passed to 'fixIO' inspects its argument, the resulting action will throw +-- 'FixIOException'. fixIO :: (a -> IO a) -> IO a fixIO k = do m <- newEmptyMVar - ans <- unsafeDupableInterleaveIO (readMVar m) + ans <- unsafeDupableInterleaveIO + (readMVar m `catch` \BlockedIndefinitelyOnMVar -> + throwIO FixIOException) result <- k ans putMVar m result return result @@ -473,14 +484,14 @@ openBinaryTempFileWithDefaultPermissions tmp_dir template openTempFile' :: String -> FilePath -> String -> Bool -> CMode -> IO (FilePath, Handle) openTempFile' loc tmp_dir template binary mode - | pathSeparator `elem` template + | pathSeparator template = fail $ "openTempFile': Template string must not contain path separator characters: "++template | otherwise = findTempName where -- We split off the last extension, so we can use .foo.ext files -- for temporary files (hidden on Unix OSes). Unfortunately we're -- below filepath in the hierarchy here. - (prefix,suffix) = + (prefix, suffix) = case break (== '.') $ reverse template of -- First case: template contains no '.'s. Just re-reverse it. (rev_suffix, "") -> (reverse rev_suffix, "") @@ -493,7 +504,52 @@ openTempFile' loc tmp_dir template binary mode -- always return a pair with either the empty string or a string -- beginning with '.' as the second component. _ -> errorWithoutStackTrace "bug in System.IO.openTempFile" - +#if defined(mingw32_HOST_OS) + findTempName = do + let label = if null prefix then "ghc" else prefix + withCWString tmp_dir $ \c_tmp_dir -> + withCWString label $ \c_template -> + withCWString suffix $ \c_suffix -> + -- NOTE: revisit this when new I/O manager in place and use a UUID + -- based one when we are no longer MAX_PATH bound. + allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do + res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0 + c_str + if not res + then do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + else do filename <- peekCWString c_str + handleResults filename + + handleResults filename = do + let oflags1 = rw_flags .|. o_EXCL + binary_flags + | binary = o_BINARY + | otherwise = 0 + oflags = oflags1 .|. binary_flags + fd <- withFilePath filename $ \ f -> c_open f oflags mode + case fd < 0 of + True -> do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + False -> + do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} + False{-is_socket-} + True{-is_nonblock-} + + enc <- getLocaleEncoding + h <- mkHandleFromFD fD fd_type filename ReadWriteMode + False{-set non-block-} (Just enc) + + return (filename, h) + +foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo + :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool + +pathSeparator :: String -> Bool +pathSeparator template = any (\x-> x == '/' || x == '\\') template + +output_flags = std_flags +#else /* else mingw32_HOST_OS */ findTempName = do rs <- rand_string let filename = prefix ++ rs ++ suffix @@ -517,8 +573,8 @@ openTempFile' loc tmp_dir template binary mode combine a b | null b = a | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b + | pathSeparator [last a] = a ++ b + | otherwise = a ++ [pathSeparatorChar] ++ b tempCounter :: IORef Int tempCounter = unsafePerformIO $ newIORef 0 @@ -528,7 +584,7 @@ tempCounter = unsafePerformIO $ newIORef 0 rand_string :: IO String rand_string = do r1 <- c_getpid - r2 <- atomicModifyIORef tempCounter (\n -> (n+1, n)) + (r2, _) <- atomicModifyIORef'_ tempCounter (+1) return $ show r1 ++ "-" ++ show r2 data OpenNewFileResult @@ -552,41 +608,22 @@ openNewFile filepath binary mode = do errno <- getErrno case errno of _ | errno == eEXIST -> return FileExists -#if defined(mingw32_HOST_OS) - -- If c_open throws EACCES on windows, it could mean that filepath is a - -- directory. In this case, we want to return FileExists so that the - -- enclosing openTempFile can try again instead of failing outright. - -- See bug #4968. - _ | errno == eACCES -> do - withCString filepath $ \path -> do - -- There is a race here: the directory might have been moved or - -- deleted between the c_open call and the next line, but there - -- doesn't seem to be any direct way to detect that the c_open call - -- failed because of an existing directory. - exists <- c_fileExists path - return $ if exists - then FileExists - else OpenNewError errno -#endif _ -> return (OpenNewError errno) else return (NewFileCreated fd) -#if defined(mingw32_HOST_OS) -foreign import ccall "file_exists" c_fileExists :: CString -> IO Bool -#endif - -- XXX Should use filepath library -pathSeparator :: Char -#if defined(mingw32_HOST_OS) -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif +pathSeparatorChar :: Char +pathSeparatorChar = '/' + +pathSeparator :: String -> Bool +pathSeparator template = pathSeparatorChar `elem` template + +output_flags = std_flags .|. o_CREAT +#endif /* mingw32_HOST_OS */ -- XXX Copied from GHC.Handle std_flags, output_flags, rw_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT rw_flags = output_flags .|. o_RDWR -- $locking @@ -606,4 +643,3 @@ rw_flags = output_flags .|. o_RDWR -- It follows that an attempt to write to a file (using 'writeFile', for -- example) that was earlier opened by 'readFile' will usually result in -- failure with 'System.IO.Error.isAlreadyInUseError'. - diff --git a/libraries/base/System/Mem/StableName.hs b/libraries/base/System/Mem/StableName.hs index dcd527307b..064d928865 100644 --- a/libraries/base/System/Mem/StableName.hs +++ b/libraries/base/System/Mem/StableName.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -35,72 +32,4 @@ module System.Mem.StableName ( eqStableName ) where -import GHC.IO ( IO(..) ) -import GHC.Base ( Int(..), StableName#, makeStableName# - , eqStableName#, stableNameToInt# ) - ------------------------------------------------------------------------------ --- Stable Names - -{-| - An abstract name for an object, that supports equality and hashing. - - Stable names have the following property: - - * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@ - then @sn1@ and @sn2@ were created by calls to @makeStableName@ on - the same object. - - The reverse is not necessarily true: if two stable names are not - equal, then the objects they name may still be equal. Note in particular - that `makeStableName` may return a different `StableName` after an - object is evaluated. - - Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), - but differ in the following ways: - - * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s. - Stable names are reclaimed by the runtime system when they are no - longer needed. - - * There is no @deRefStableName@ operation. You can\'t get back from - a stable name to the original Haskell object. The reason for - this is that the existence of a stable name for an object does not - guarantee the existence of the object itself; it can still be garbage - collected. --} - -data StableName a = StableName (StableName# a) - --- | Makes a 'StableName' for an arbitrary object. The object passed as --- the first argument is not evaluated by 'makeStableName'. -makeStableName :: a -> IO (StableName a) -makeStableName a = IO $ \ s -> - case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) - --- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not --- necessarily unique; several 'StableName's may map to the same 'Int' --- (in practice however, the chances of this are small, so the result --- of 'hashStableName' makes a good hash key). -hashStableName :: StableName a -> Int -hashStableName (StableName sn) = I# (stableNameToInt# sn) - --- | @since 2.01 -instance Eq (StableName a) where - (StableName sn1) == (StableName sn2) = - case eqStableName# sn1 sn2 of - 0# -> False - _ -> True - --- | Equality on 'StableName' that does not require that the types of --- the arguments match. --- --- @since 4.7.0.0 -eqStableName :: StableName a -> StableName b -> Bool -eqStableName (StableName sn1) (StableName sn2) = - case eqStableName# sn1 sn2 of - 0# -> False - _ -> True - -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to - -- use it for implementing observable sharing. - +import GHC.StableName diff --git a/libraries/base/System/Timeout.hs b/libraries/base/System/Timeout.hs index d34082e64f..e2b85658bb 100644 --- a/libraries/base/System/Timeout.hs +++ b/libraries/base/System/Timeout.hs @@ -35,9 +35,9 @@ import Data.Unique (Unique, newUnique) -- interrupt the running IO computation when the timeout has -- expired. -newtype Timeout = Timeout Unique deriving (Eq) +newtype Timeout = Timeout Unique deriving Eq -- ^ @since 4.0 --- | @since 3.0 +-- | @since 4.0 instance Show Timeout where show _ = "<<timeout>>" @@ -53,6 +53,12 @@ instance Exception Timeout where -- timeout interval means \"wait indefinitely\". When specifying long timeouts, -- be careful not to exceed @maxBound :: Int@. -- +-- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time") +-- Just "finished on time" +-- +-- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time") +-- Nothing +-- -- The design of this combinator was guided by the objective that @timeout n f@ -- should behave exactly the same as @f@ as long as @f@ doesn't time out. This -- means that @f@ has the same 'myThreadId' it would have without the timeout @@ -75,7 +81,6 @@ instance Exception Timeout where -- because the runtime system uses scheduling mechanisms like @select(2)@ to -- perform asynchronous I\/O, so it is possible to interrupt standard socket -- I\/O or file I\/O using this combinator. - timeout :: Int -> IO a -> IO (Maybe a) timeout n f | n < 0 = fmap Just f diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs index fd7c677bd9..063c08910a 100644 --- a/libraries/base/Text/ParserCombinators/ReadP.hs +++ b/libraries/base/Text/ParserCombinators/ReadP.hs @@ -100,7 +100,7 @@ data P a | Fail | Result a (P a) | Final [(a,String)] -- invariant: list is non-empty! - deriving Functor + deriving Functor -- ^ @since 4.8.0.0 -- Monad, MonadPlus @@ -161,8 +161,6 @@ instance Alternative P where newtype ReadP a = R (forall b . (a -> P b) -> P b) --- Functor, Monad, MonadPlus - -- | @since 2.01 instance Functor ReadP where fmap h (R f) = R (\k -> f (k . h)) @@ -171,7 +169,7 @@ instance Functor ReadP where instance Applicative ReadP where pure x = R (\k -> k x) (<*>) = ap - liftA2 = liftM2 + -- liftA2 = liftM2 -- | @since 2.01 instance Monad ReadP where @@ -439,85 +437,68 @@ The following are QuickCheck specifications of what the combinators do. These can be seen as formal specifications of the behavior of the combinators. -We use bags to give semantics to the combinators. +For some values, we only care about the lists contents, not their order, -> type Bag a = [a] +> (=~) :: Ord a => [a] -> [a] -> Bool +> xs =~ ys = sort xs == sort ys -Equality on bags does not care about the order of elements. +Here follow the properties: -> (=~) :: Ord a => Bag a -> Bag a -> Bool -> xs =~ ys = sort xs == sort ys +>>> readP_to_S get [] +[] -A special equality operator to avoid unresolved overloading -when testing the properties. +prop> \c str -> readP_to_S get (c:str) == [(c, str)] -> (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool -> (=~.) = (=~) +prop> \str -> readP_to_S look str == [(str, str)] -Here follow the properties: +prop> \str -> readP_to_S pfail str == [] -> prop_Get_Nil = -> readP_to_S get [] =~ [] -> -> prop_Get_Cons c s = -> readP_to_S get (c:s) =~ [(c,s)] -> -> prop_Look s = -> readP_to_S look s =~ [(s,s)] -> -> prop_Fail s = -> readP_to_S pfail s =~. [] -> -> prop_Return x s = -> readP_to_S (return x) s =~. [(x,s)] -> -> prop_Bind p k s = -> readP_to_S (p >>= k) s =~. +prop> \x str -> readP_to_S (return x) s == [(x,s)] + +> prop_Bind p k s = +> readP_to_S (p >>= k) s =~ > [ ys'' > | (x,s') <- readP_to_S p s > , ys'' <- readP_to_S (k (x::Int)) s' > ] -> -> prop_Plus p q s = -> readP_to_S (p +++ q) s =~. -> (readP_to_S p s ++ readP_to_S q s) -> -> prop_LeftPlus p q s = -> readP_to_S (p <++ q) s =~. -> (readP_to_S p s +<+ readP_to_S q s) -> where -> [] +<+ ys = ys -> xs +<+ _ = xs -> -> prop_Gather s = -> forAll readPWithoutReadS $ \p -> -> readP_to_S (gather p) s =~ -> [ ((pre,x::Int),s') -> | (x,s') <- readP_to_S p s -> , let pre = take (length s - length s') s -> ] -> -> prop_String_Yes this s = -> readP_to_S (string this) (this ++ s) =~ -> [(this,s)] -> -> prop_String_Maybe this s = -> readP_to_S (string this) s =~ -> [(this, drop (length this) s) | this `isPrefixOf` s] -> -> prop_Munch p s = -> readP_to_S (munch p) s =~ -> [(takeWhile p s, dropWhile p s)] -> -> prop_Munch1 p s = -> readP_to_S (munch1 p) s =~ -> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] -> -> prop_Choice ps s = -> readP_to_S (choice ps) s =~. -> readP_to_S (foldr (+++) pfail ps) s -> -> prop_ReadS r s = -> readP_to_S (readS_to_P r) s =~. r s --} +> prop_Plus p q s = +> readP_to_S (p +++ q) s =~ +> (readP_to_S p s ++ readP_to_S q s) + +> prop_LeftPlus p q s = +> readP_to_S (p <++ q) s =~ +> (readP_to_S p s +<+ readP_to_S q s) +> where +> [] +<+ ys = ys +> xs +<+ _ = xs + +> prop_Gather s = +> forAll readPWithoutReadS $ \p -> +> readP_to_S (gather p) s =~ +> [ ((pre,x::Int),s') +> | (x,s') <- readP_to_S p s +> , let pre = take (length s - length s') s +> ] + +prop> \this str -> readP_to_S (string this) (this ++ str) == [(this,str)] + +> prop_String_Maybe this s = +> readP_to_S (string this) s =~ +> [(this, drop (length this) s) | this `isPrefixOf` s] + +> prop_Munch p s = +> readP_to_S (munch p) s =~ +> [(takeWhile p s, dropWhile p s)] + +> prop_Munch1 p s = +> readP_to_S (munch1 p) s =~ +> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] + +> prop_Choice ps s = +> readP_to_S (choice ps) s =~ +> readP_to_S (foldr (+++) pfail ps) s + +> prop_ReadS r s = +> readP_to_S (readS_to_P r) s =~ r s +-} diff --git a/libraries/base/Text/Printf.hs b/libraries/base/Text/Printf.hs index 0914aa7b5c..177e8f2230 100644 --- a/libraries/base/Text/Printf.hs +++ b/libraries/base/Text/Printf.hs @@ -102,6 +102,10 @@ import System.IO ------------------- -- | Format a variable number of arguments with the C-style formatting string. +-- +-- >>> printf "%s, %d, %.4f" "hello" 123 pi +-- hello, 123, 3.1416 +-- -- The return value is either 'String' or @('IO' a)@ (which -- should be @('IO' '()')@, but Haskell's type system -- makes this hard). @@ -133,11 +137,11 @@ import System.IO -- A conversion specification begins with the -- character @%@, followed by zero or more of the following flags: -- --- > - left adjust (default is right adjust) --- > + always use a sign (+ or -) for signed conversions --- > space leading space for positive numbers in signed conversions --- > 0 pad with zeros rather than spaces --- > # use an \"alternate form\": see below +-- > - left adjust (default is right adjust) +-- > + always use a sign (+ or -) for signed conversions +-- > space leading space for positive numbers in signed conversions +-- > 0 pad with zeros rather than spaces +-- > # use an \"alternate form\": see below -- -- When both flags are given, @-@ overrides @0@ and @+@ overrides space. -- A negative width specifier in a @*@ conversion is treated as @@ -146,32 +150,32 @@ import System.IO -- The \"alternate form\" for unsigned radix conversions is -- as in C @printf(3)@: -- --- > %o prefix with a leading 0 if needed --- > %x prefix with a leading 0x if nonzero --- > %X prefix with a leading 0X if nonzero --- > %b prefix with a leading 0b if nonzero --- > %[eEfFgG] ensure that the number contains a decimal point +-- > %o prefix with a leading 0 if needed +-- > %x prefix with a leading 0x if nonzero +-- > %X prefix with a leading 0X if nonzero +-- > %b prefix with a leading 0b if nonzero +-- > %[eEfFgG] ensure that the number contains a decimal point -- -- Any flags are followed optionally by a field width: -- --- > num field width --- > * as num, but taken from argument list +-- > num field width +-- > * as num, but taken from argument list -- -- The field width is a minimum, not a maximum: it will be -- expanded as needed to avoid mutilating a value. -- -- Any field width is followed optionally by a precision: -- --- > .num precision --- > . same as .0 --- > .* as num, but taken from argument list +-- > .num precision +-- > . same as .0 +-- > .* as num, but taken from argument list -- -- Negative precision is taken as 0. The meaning of the -- precision depends on the conversion type. -- --- > Integral minimum number of digits to show --- > RealFloat number of digits after the decimal point --- > String maximum number of characters +-- > Integral minimum number of digits to show +-- > RealFloat number of digits after the decimal point +-- > String maximum number of characters -- -- The precision for Integral types is accomplished by zero-padding. -- If both precision and zero-pad are given for an Integral field, @@ -182,29 +186,29 @@ import System.IO -- to set the implicit size of the operand for conversion of -- a negative operand to unsigned: -- --- > hh Int8 --- > h Int16 --- > l Int32 --- > ll Int64 --- > L Int64 +-- > hh Int8 +-- > h Int16 +-- > l Int32 +-- > ll Int64 +-- > L Int64 -- -- The specification ends with a format character: -- --- > c character Integral --- > d decimal Integral --- > o octal Integral --- > x hexadecimal Integral --- > X hexadecimal Integral --- > b binary Integral --- > u unsigned decimal Integral --- > f floating point RealFloat --- > F floating point RealFloat --- > g general format float RealFloat --- > G general format float RealFloat --- > e exponent format float RealFloat --- > E exponent format float RealFloat --- > s string String --- > v default format any type +-- > c character Integral +-- > d decimal Integral +-- > o octal Integral +-- > x hexadecimal Integral +-- > X hexadecimal Integral +-- > b binary Integral +-- > u unsigned decimal Integral +-- > f floating point RealFloat +-- > F floating point RealFloat +-- > g general format float RealFloat +-- > G general format float RealFloat +-- > e exponent format float RealFloat +-- > E exponent format float RealFloat +-- > s string String +-- > v default format any type -- -- The \"%v\" specifier is provided for all built-in types, -- and should be provided for user-defined type formatters @@ -212,11 +216,11 @@ import System.IO -- type. For the built-in types the \"%v\" specifier is -- converted as follows: -- --- > c Char --- > u other unsigned Integral --- > d other signed Integral --- > g RealFloat --- > s String +-- > c Char +-- > u other unsigned Integral +-- > d other signed Integral +-- > g RealFloat +-- > s String -- -- Mismatch between the argument types and the format -- string, as well as any other syntactic or semantic errors @@ -246,16 +250,6 @@ import System.IO -- -- * Haskell 'printf' will place a zero after a decimal point when -- possible. --- --- ==== __Examples__ --- --- > > printf "%d\n" (23::Int) --- > 23 --- > > printf "%s %s\n" "Hello" "World" --- > Hello World --- > > printf "%.2f\n" pi --- > 3.14 --- printf :: (PrintfType r) => String -> r printf fmts = spr fmts [] diff --git a/libraries/base/Text/Read.hs b/libraries/base/Text/Read.hs index 2479eb529a..c79b7c15b2 100644 --- a/libraries/base/Text/Read.hs +++ b/libraries/base/Text/Read.hs @@ -62,6 +62,12 @@ reads = readsPrec minPrec -- Succeeds if there is exactly one valid result. -- A 'Left' value indicates a parse error. -- +-- >>> readEither "123" :: Either String Int +-- Right 123 +-- +-- >>> readEither "hello" :: Either String Int +-- Left "Prelude.read: no parse" +-- -- @since 4.6.0.0 readEither :: Read a => String -> Either String a readEither s = @@ -78,6 +84,12 @@ readEither s = -- | Parse a string using the 'Read' instance. -- Succeeds if there is exactly one valid result. -- +-- >>> readMaybe "123" :: Maybe Int +-- Just 123 +-- +-- >>> readMaybe "hello" :: Maybe Int +-- Nothing +-- -- @since 4.6.0.0 readMaybe :: Read a => String -> Maybe a readMaybe s = case readEither s of @@ -85,6 +97,14 @@ readMaybe s = case readEither s of Right a -> Just a -- | The 'read' function reads input from a string, which must be --- completely consumed by the input process. +-- completely consumed by the input process. 'read' fails with an 'error' if the +-- parse is unsuccessful, and it is therefore discouraged from being used in +-- real applications. Use 'readMaybe' or 'readEither' for safe alternatives. +-- +-- >>> read "123" :: Int +-- 123 +-- +-- >>> read "hello" :: Int +-- *** Exception: Prelude.read: no parse read :: Read a => String -> a read s = either errorWithoutStackTrace id (readEither s) diff --git a/libraries/base/Text/Read/Lex.hs b/libraries/base/Text/Read/Lex.hs index d0d39c6648..7568f9afaf 100644 --- a/libraries/base/Text/Read/Lex.hs +++ b/libraries/base/Text/Read/Lex.hs @@ -68,15 +68,19 @@ data Lexeme | Symbol String -- ^ Haskell symbol, e.g. @>>@, @:%@ | Number Number -- ^ @since 4.6.0.0 | EOF - deriving (Eq, Show) + deriving ( Eq -- ^ @since 2.01 + , Show -- ^ @since 2.01 + ) --- | @since 4.7.0.0 +-- | @since 4.6.0.0 data Number = MkNumber Int -- Base Digits -- Integral part | MkDecimal Digits -- Integral part (Maybe Digits) -- Fractional part (Maybe Integer) -- Exponent - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + ) -- | @since 4.5.1.0 numberToInteger :: Number -> Maybe Integer diff --git a/libraries/base/Type/Reflection.hs b/libraries/base/Type/Reflection.hs index 9e87c5f73b..80842a4084 100644 --- a/libraries/base/Type/Reflection.hs +++ b/libraries/base/Type/Reflection.hs @@ -19,7 +19,7 @@ -- Dimitrios Vytiniotis. "A reflection on types." /Proc. Philip Wadler's 60th -- birthday Festschrift/, Edinburgh (April 2016). -- --- The interface provides 'TypeRep', a type representation which can +-- The interface provides 'I.TypeRep', a type representation which can -- be safely decomposed and composed. See "Data.Dynamic" for an example of this. -- -- @since 4.10.0.0 diff --git a/libraries/base/Type/Reflection/Unsafe.hs b/libraries/base/Type/Reflection/Unsafe.hs index c0f2327706..a109400412 100644 --- a/libraries/base/Type/Reflection/Unsafe.hs +++ b/libraries/base/Type/Reflection/Unsafe.hs @@ -12,6 +12,7 @@ -- type representations. -- ----------------------------------------------------------------------------- +{-# LANGUAGE PolyKinds, DataKinds, ScopedTypeVariables #-} module Type.Reflection.Unsafe ( -- * Type representations @@ -22,4 +23,12 @@ module Type.Reflection.Unsafe ( , TyCon, mkTrCon, tyConKindRep, tyConKindArgs, tyConFingerprint ) where -import Data.Typeable.Internal +import Data.Typeable.Internal hiding (mkTrApp) +import qualified Data.Typeable.Internal as TI + +-- | Construct a representation for a type application. +mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + TypeRep (a :: k1 -> k2) + -> TypeRep (b :: k1) + -> TypeRep (a b) +mkTrApp = TI.mkTrAppChecked diff --git a/libraries/base/Unsafe/Coerce.hs b/libraries/base/Unsafe/Coerce.hs index df1c109e0e..5bcbb01e1a 100644 --- a/libraries/base/Unsafe/Coerce.hs +++ b/libraries/base/Unsafe/Coerce.hs @@ -31,7 +31,8 @@ module Unsafe.Coerce (unsafeCoerce) where -import GHC.Integer () -- for build ordering +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base +import GHC.Natural () -- See Note [Depend on GHC.Natural] in GHC.Base import GHC.Prim (unsafeCoerce#) local_id :: a -> a diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 9429de05c3..f02ff0827c 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -1,18 +1,19 @@ +cabal-version: 2.1 name: base -version: 4.10.0.0 +version: 4.12.0.0 -- NOTE: Don't forget to update ./changelog.md -license: BSD3 + +license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/base synopsis: Basic libraries category: Prelude +build-type: Configure description: - This package contains the "Prelude" and its support libraries, + This package contains the Standard Haskell "Prelude" and its support libraries, and a large collection of useful libraries ranging from data structures to parsing combinators and debugging utilities. -cabal-version: >=1.10 -build-type: Configure extra-tmp-files: autom4te.cache @@ -35,6 +36,7 @@ extra-source-files: include/HsBaseConfig.h.in include/ieee-flpt.h include/md5.h + include/fs.h install-sh source-repository head @@ -93,17 +95,17 @@ Library UnliftedFFITypes Unsafe - build-depends: rts == 1.0.*, ghc-prim == 0.5.* + build-depends: rts == 1.0, ghc-prim ^>= 0.5.1.0 -- sanity-check to ensure exactly one flag is set if !((flag(integer-gmp) && !flag(integer-simple)) || (!flag(integer-gmp) && flag(integer-simple))) build-depends: invalid-cabal-flag-settings<0 if flag(integer-simple) - build-depends: integer-simple >= 0.1.1 && < 0.2 + build-depends: integer-simple ^>= 0.1.1 if flag(integer-gmp) - build-depends: integer-gmp >= 1.0 && < 1.1 + build-depends: integer-gmp ^>= 1.0.1 cpp-options: -DOPTIMISE_INTEGER_GCD_LCM exposed-modules: @@ -147,6 +149,7 @@ Library Data.Function Data.Functor Data.Functor.Classes + Data.Functor.Contravariant Data.Functor.Compose Data.Functor.Const Data.Functor.Identity @@ -204,6 +207,7 @@ Library GHC.Base GHC.ByteOrder GHC.Char + GHC.Clock GHC.Conc GHC.Conc.IO GHC.Conc.Signal @@ -215,6 +219,7 @@ Library GHC.Environment GHC.Err GHC.Exception + GHC.Exception.Type GHC.ExecutionStack GHC.ExecutionStack.Internal GHC.Exts @@ -254,24 +259,26 @@ Library GHC.IORef GHC.Int GHC.List + GHC.Maybe GHC.MVar GHC.Natural GHC.Num GHC.OldList GHC.OverloadedLabels - GHC.PArr GHC.Pack GHC.Profiling GHC.Ptr GHC.Read GHC.Real GHC.Records + GHC.ResponseFile GHC.RTS.Flags GHC.ST GHC.StaticPtr GHC.STRef GHC.Show GHC.Stable + GHC.StableName GHC.Stack GHC.Stack.CCS GHC.Stack.Types @@ -289,6 +296,7 @@ Library System.CPUTime System.Console.GetOpt System.Environment + System.Environment.Blank System.Exit System.IO System.IO.Error @@ -316,6 +324,7 @@ Library Control.Monad.ST.Lazy.Imp Data.Functor.Utils Data.OldList + Data.Semigroup.Internal Data.Typeable.Internal Foreign.ForeignPtr.Imp GHC.StaticPtr.Internal @@ -334,6 +343,10 @@ Library cbits/md5.c cbits/primFloat.c cbits/sysconf.c + cbits/fs.c + + cmm-sources: + cbits/CastFloatWord.cmm include-dirs: include includes: @@ -367,7 +380,6 @@ Library other-modules: GHC.Event.Arr GHC.Event.Array - GHC.Event.Clock GHC.Event.Control GHC.Event.EPoll GHC.Event.IntTable @@ -388,3 +400,6 @@ Library -- We need to set the unit id to base (without a version number) -- as it's magic. ghc-options: -this-unit-id base + + -- Make sure we don't accidentally regress into anti-patterns + ghc-options: -Wcompat -Wnoncanonical-monad-instances diff --git a/libraries/base/cbits/README.Unicode b/libraries/base/cbits/README.Unicode index 363aa4dc97..6cc18464cd 100644 --- a/libraries/base/cbits/README.Unicode +++ b/libraries/base/cbits/README.Unicode @@ -5,4 +5,4 @@ WCsubst.c is generated with: where UnicodeData.txt came from - http://www.unicode.org/Public/6.0.0/ucd/UnicodeData.txt + https://www.unicode.org/Public/12.0.0/ucd/UnicodeData-12.0.0d4.txt diff --git a/libraries/base/cbits/WCsubst.c b/libraries/base/cbits/WCsubst.c index c4b0645aa2..9940405a8e 100644 --- a/libraries/base/cbits/WCsubst.c +++ b/libraries/base/cbits/WCsubst.c @@ -1,6 +1,6 @@ /*------------------------------------------------------------------------- This is an automatically generated file: do not edit -Generated by ubconfc at Wed Oct 15 14:24:39 EDT 2014 +Generated by ubconfc at Tue Aug 14 10:04:18 UTC 2018 @generated -------------------------------------------------------------------------*/ @@ -90,110 +90,126 @@ struct _charblock_ #define GENCAT_MN 2097152 #define GENCAT_LO 16384 #define MAX_UNI_CHAR 1114109 -#define NUM_BLOCKS 3073 -#define NUM_CONVBLOCKS 1276 +#define NUM_BLOCKS 3349 +#define NUM_CONVBLOCKS 1326 #define NUM_SPACEBLOCKS 7 #define NUM_LAT1BLOCKS 63 -#define NUM_RULES 181 -static const struct _convrule_ rule169={GENCAT_LU, NUMCAT_LU, 1, 0, -35332, 0}; -static const struct _convrule_ rule157={GENCAT_SO, NUMCAT_SO, 1, -26, 0, -26}; -static const struct _convrule_ rule168={GENCAT_LL, NUMCAT_LL, 1, -7264, 0, -7264}; -static const struct _convrule_ rule173={GENCAT_LU, NUMCAT_LU, 1, 0, -42315, 0}; -static const struct _convrule_ rule129={GENCAT_LL, NUMCAT_LL, 1, 8, 0, 8}; -static const struct _convrule_ rule88={GENCAT_LL, NUMCAT_LL, 1, 42258, 0, 42258}; +#define NUM_RULES 205 +static const struct _convrule_ rule183={GENCAT_LU, NUMCAT_LU, 1, 0, -35332, 0}; +static const struct _convrule_ rule171={GENCAT_SO, NUMCAT_SO, 1, -26, 0, -26}; +static const struct _convrule_ rule182={GENCAT_LL, NUMCAT_LL, 1, -7264, 0, -7264}; +static const struct _convrule_ rule188={GENCAT_LU, NUMCAT_LU, 1, 0, -42315, 0}; +static const struct _convrule_ rule143={GENCAT_LL, NUMCAT_LL, 1, 8, 0, 8}; +static const struct _convrule_ rule127={GENCAT_LU, NUMCAT_LU, 1, 0, 38864, 0}; +static const struct _convrule_ rule90={GENCAT_LL, NUMCAT_LL, 1, 42258, 0, 42258}; static const struct _convrule_ rule20={GENCAT_LL, NUMCAT_LL, 0, 0, 0, 0}; static const struct _convrule_ rule76={GENCAT_LL, NUMCAT_LL, 1, 10743, 0, 10743}; static const struct _convrule_ rule61={GENCAT_LL, NUMCAT_LL, 1, 10783, 0, 10783}; +static const struct _convrule_ rule132={GENCAT_LL, NUMCAT_LL, 1, -6242, 0, -6242}; static const struct _convrule_ rule37={GENCAT_LU, NUMCAT_LU, 1, 0, 211, 0}; +static const struct _convrule_ rule197={GENCAT_LL, NUMCAT_LL, 1, -928, 0, -928}; static const struct _convrule_ rule80={GENCAT_LL, NUMCAT_LL, 1, -214, 0, -214}; static const struct _convrule_ rule75={GENCAT_LL, NUMCAT_LL, 1, -211, 0, -211}; -static const struct _convrule_ rule121={GENCAT_LL, NUMCAT_LL, 1, -48, 0, -48}; +static const struct _convrule_ rule123={GENCAT_LL, NUMCAT_LL, 1, -48, 0, -48}; static const struct _convrule_ rule52={GENCAT_LU, NUMCAT_LU, 1, 0, -56, 0}; -static const struct _convrule_ rule135={GENCAT_LL, NUMCAT_LL, 1, 112, 0, 112}; +static const struct _convrule_ rule149={GENCAT_LL, NUMCAT_LL, 1, 112, 0, 112}; static const struct _convrule_ rule71={GENCAT_LL, NUMCAT_LL, 1, -207, 0, -207}; -static const struct _convrule_ rule123={GENCAT_LU, NUMCAT_LU, 1, 0, 7264, 0}; -static const struct _convrule_ rule152={GENCAT_LU, NUMCAT_LU, 1, 0, 28, 0}; -static const struct _convrule_ rule159={GENCAT_LU, NUMCAT_LU, 1, 0, -3814, 0}; +static const struct _convrule_ rule125={GENCAT_LU, NUMCAT_LU, 1, 0, 7264, 0}; +static const struct _convrule_ rule166={GENCAT_LU, NUMCAT_LU, 1, 0, 28, 0}; +static const struct _convrule_ rule173={GENCAT_LU, NUMCAT_LU, 1, 0, -3814, 0}; static const struct _convrule_ rule45={GENCAT_LU, NUMCAT_LU, 1, 0, 219, 0}; static const struct _convrule_ rule7={GENCAT_PD, NUMCAT_PD, 0, 0, 0, 0}; -static const struct _convrule_ rule180={GENCAT_LL, NUMCAT_LL, 1, -40, 0, -40}; -static const struct _convrule_ rule97={GENCAT_LL, NUMCAT_LL, 1, -38, 0, -38}; -static const struct _convrule_ rule95={GENCAT_LU, NUMCAT_LU, 1, 0, 64, 0}; +static const struct _convrule_ rule202={GENCAT_LL, NUMCAT_LL, 1, -40, 0, -40}; +static const struct _convrule_ rule99={GENCAT_LL, NUMCAT_LL, 1, -38, 0, -38}; +static const struct _convrule_ rule97={GENCAT_LU, NUMCAT_LU, 1, 0, 64, 0}; static const struct _convrule_ rule1={GENCAT_ZS, NUMCAT_ZS, 0, 0, 0, 0}; +static const struct _convrule_ rule89={GENCAT_LL, NUMCAT_LL, 1, 42261, 0, 42261}; static const struct _convrule_ rule29={GENCAT_LU, NUMCAT_LU, 1, 0, 210, 0}; static const struct _convrule_ rule35={GENCAT_LU, NUMCAT_LU, 1, 0, 207, 0}; -static const struct _convrule_ rule154={GENCAT_NL, NUMCAT_NL, 1, 0, 16, 0}; +static const struct _convrule_ rule168={GENCAT_NL, NUMCAT_NL, 1, 0, 16, 0}; static const struct _convrule_ rule13={GENCAT_SO, NUMCAT_SO, 0, 0, 0, 0}; -static const struct _convrule_ rule149={GENCAT_LU, NUMCAT_LU, 1, 0, -7517, 0}; -static const struct _convrule_ rule128={GENCAT_LU, NUMCAT_LU, 1, 0, -7615, 0}; -static const struct _convrule_ rule98={GENCAT_LL, NUMCAT_LL, 1, -37, 0, -37}; +static const struct _convrule_ rule163={GENCAT_LU, NUMCAT_LU, 1, 0, -7517, 0}; +static const struct _convrule_ rule142={GENCAT_LU, NUMCAT_LU, 1, 0, -7615, 0}; +static const struct _convrule_ rule137={GENCAT_LU, NUMCAT_LU, 1, 0, -3008, 0}; +static const struct _convrule_ rule100={GENCAT_LL, NUMCAT_LL, 1, -37, 0, -37}; static const struct _convrule_ rule2={GENCAT_PO, NUMCAT_PO, 0, 0, 0, 0}; static const struct _convrule_ rule69={GENCAT_LL, NUMCAT_LL, 1, 42319, 0, 42319}; static const struct _convrule_ rule56={GENCAT_LU, NUMCAT_LU, 1, 0, 10792, 0}; static const struct _convrule_ rule25={GENCAT_LL, NUMCAT_LL, 1, -232, 0, -232}; static const struct _convrule_ rule43={GENCAT_LU, NUMCAT_LU, 1, 0, 218, 0}; -static const struct _convrule_ rule165={GENCAT_LU, NUMCAT_LU, 1, 0, -10783, 0}; -static const struct _convrule_ rule133={GENCAT_LL, NUMCAT_LL, 1, 100, 0, 100}; -static const struct _convrule_ rule96={GENCAT_LU, NUMCAT_LU, 1, 0, 63, 0}; -static const struct _convrule_ rule90={GENCAT_MN, NUMCAT_MN, 0, 0, 0, 0}; +static const struct _convrule_ rule179={GENCAT_LU, NUMCAT_LU, 1, 0, -10783, 0}; +static const struct _convrule_ rule147={GENCAT_LL, NUMCAT_LL, 1, 100, 0, 100}; +static const struct _convrule_ rule98={GENCAT_LU, NUMCAT_LU, 1, 0, 63, 0}; +static const struct _convrule_ rule92={GENCAT_MN, NUMCAT_MN, 0, 0, 0, 0}; static const struct _convrule_ rule12={GENCAT_LL, NUMCAT_LL, 1, -32, 0, -32}; -static const struct _convrule_ rule93={GENCAT_LU, NUMCAT_LU, 1, 0, 38, 0}; -static const struct _convrule_ rule99={GENCAT_LL, NUMCAT_LL, 1, -31, 0, -31}; -static const struct _convrule_ rule105={GENCAT_LU, NUMCAT_LU, 0, 0, 0, 0}; +static const struct _convrule_ rule95={GENCAT_LU, NUMCAT_LU, 1, 0, 38, 0}; +static const struct _convrule_ rule140={GENCAT_LL, NUMCAT_LL, 1, 35384, 0, 35384}; +static const struct _convrule_ rule101={GENCAT_LL, NUMCAT_LL, 1, -31, 0, -31}; +static const struct _convrule_ rule204={GENCAT_LL, NUMCAT_LL, 1, -34, 0, -34}; +static const struct _convrule_ rule107={GENCAT_LU, NUMCAT_LU, 0, 0, 0, 0}; static const struct _convrule_ rule11={GENCAT_PC, NUMCAT_PC, 0, 0, 0, 0}; -static const struct _convrule_ rule175={GENCAT_LU, NUMCAT_LU, 1, 0, -42258, 0}; -static const struct _convrule_ rule144={GENCAT_LU, NUMCAT_LU, 1, 0, -112, 0}; +static const struct _convrule_ rule192={GENCAT_LU, NUMCAT_LU, 1, 0, -42261, 0}; +static const struct _convrule_ rule190={GENCAT_LU, NUMCAT_LU, 1, 0, -42258, 0}; +static const struct _convrule_ rule158={GENCAT_LU, NUMCAT_LU, 1, 0, -112, 0}; static const struct _convrule_ rule15={GENCAT_PI, NUMCAT_PI, 0, 0, 0, 0}; -static const struct _convrule_ rule132={GENCAT_LL, NUMCAT_LL, 1, 86, 0, 86}; -static const struct _convrule_ rule122={GENCAT_MC, NUMCAT_MC, 0, 0, 0, 0}; -static const struct _convrule_ rule126={GENCAT_LL, NUMCAT_LL, 1, 3814, 0, 3814}; +static const struct _convrule_ rule146={GENCAT_LL, NUMCAT_LL, 1, 86, 0, 86}; +static const struct _convrule_ rule124={GENCAT_MC, NUMCAT_MC, 0, 0, 0, 0}; +static const struct _convrule_ rule139={GENCAT_LL, NUMCAT_LL, 1, 3814, 0, 3814}; static const struct _convrule_ rule44={GENCAT_LU, NUMCAT_LU, 1, 0, 217, 0}; -static const struct _convrule_ rule153={GENCAT_LL, NUMCAT_LL, 1, -28, 0, -28}; -static const struct _convrule_ rule178={GENCAT_CO, NUMCAT_CO, 0, 0, 0, 0}; -static const struct _convrule_ rule114={GENCAT_LL, NUMCAT_LL, 1, -96, 0, -96}; +static const struct _convrule_ rule167={GENCAT_LL, NUMCAT_LL, 1, -28, 0, -28}; +static const struct _convrule_ rule200={GENCAT_CO, NUMCAT_CO, 0, 0, 0, 0}; +static const struct _convrule_ rule196={GENCAT_LU, NUMCAT_LU, 1, 0, -35384, 0}; +static const struct _convrule_ rule116={GENCAT_LL, NUMCAT_LL, 1, -96, 0, -96}; +static const struct _convrule_ rule185={GENCAT_LL, NUMCAT_LL, 1, 48, 0, 48}; static const struct _convrule_ rule51={GENCAT_LU, NUMCAT_LU, 1, 0, -97, 0}; static const struct _convrule_ rule39={GENCAT_LL, NUMCAT_LL, 1, 163, 0, 163}; -static const struct _convrule_ rule179={GENCAT_LU, NUMCAT_LU, 1, 0, 40, 0}; -static const struct _convrule_ rule124={GENCAT_NL, NUMCAT_NL, 0, 0, 0, 0}; -static const struct _convrule_ rule94={GENCAT_LU, NUMCAT_LU, 1, 0, 37, 0}; +static const struct _convrule_ rule201={GENCAT_LU, NUMCAT_LU, 1, 0, 40, 0}; +static const struct _convrule_ rule128={GENCAT_NL, NUMCAT_NL, 0, 0, 0, 0}; +static const struct _convrule_ rule126={GENCAT_LL, NUMCAT_LL, 1, 3008, 0, 0}; +static const struct _convrule_ rule96={GENCAT_LU, NUMCAT_LU, 1, 0, 37, 0}; static const struct _convrule_ rule82={GENCAT_LL, NUMCAT_LL, 1, -218, 0, -218}; -static const struct _convrule_ rule118={GENCAT_LU, NUMCAT_LU, 1, 0, 15, 0}; +static const struct _convrule_ rule120={GENCAT_LU, NUMCAT_LU, 1, 0, 15, 0}; static const struct _convrule_ rule67={GENCAT_LL, NUMCAT_LL, 1, -202, 0, -202}; static const struct _convrule_ rule66={GENCAT_LL, NUMCAT_LL, 1, -205, 0, -205}; static const struct _convrule_ rule47={GENCAT_LU, NUMCAT_LU, 1, 0, 2, 1}; +static const struct _convrule_ rule136={GENCAT_LL, NUMCAT_LL, 1, 35266, 0, 35266}; +static const struct _convrule_ rule83={GENCAT_LL, NUMCAT_LL, 1, 42307, 0, 42307}; static const struct _convrule_ rule30={GENCAT_LU, NUMCAT_LU, 1, 0, 206, 0}; -static const struct _convrule_ rule109={GENCAT_LL, NUMCAT_LL, 1, -86, 0, -86}; +static const struct _convrule_ rule111={GENCAT_LL, NUMCAT_LL, 1, -86, 0, -86}; static const struct _convrule_ rule4={GENCAT_PS, NUMCAT_PS, 0, 0, 0, 0}; static const struct _convrule_ rule3={GENCAT_SC, NUMCAT_SC, 0, 0, 0, 0}; -static const struct _convrule_ rule150={GENCAT_LU, NUMCAT_LU, 1, 0, -8383, 0}; -static const struct _convrule_ rule120={GENCAT_LU, NUMCAT_LU, 1, 0, 48, 0}; +static const struct _convrule_ rule164={GENCAT_LU, NUMCAT_LU, 1, 0, -8383, 0}; +static const struct _convrule_ rule122={GENCAT_LU, NUMCAT_LU, 1, 0, 48, 0}; static const struct _convrule_ rule14={GENCAT_LO, NUMCAT_LO, 0, 0, 0, 0}; static const struct _convrule_ rule18={GENCAT_LL, NUMCAT_LL, 1, 743, 0, 743}; -static const struct _convrule_ rule147={GENCAT_ZL, NUMCAT_ZL, 0, 0, 0, 0}; -static const struct _convrule_ rule142={GENCAT_LU, NUMCAT_LU, 1, 0, -86, 0}; -static const struct _convrule_ rule171={GENCAT_LU, NUMCAT_LU, 1, 0, -42308, 0}; -static const struct _convrule_ rule162={GENCAT_LL, NUMCAT_LL, 1, -10792, 0, -10792}; -static const struct _convrule_ rule166={GENCAT_LU, NUMCAT_LU, 1, 0, -10782, 0}; -static const struct _convrule_ rule139={GENCAT_LU, NUMCAT_LU, 1, 0, -74, 0}; +static const struct _convrule_ rule161={GENCAT_ZL, NUMCAT_ZL, 0, 0, 0, 0}; +static const struct _convrule_ rule156={GENCAT_LU, NUMCAT_LU, 1, 0, -86, 0}; +static const struct _convrule_ rule186={GENCAT_LU, NUMCAT_LU, 1, 0, -42308, 0}; +static const struct _convrule_ rule176={GENCAT_LL, NUMCAT_LL, 1, -10792, 0, -10792}; +static const struct _convrule_ rule180={GENCAT_LU, NUMCAT_LU, 1, 0, -10782, 0}; +static const struct _convrule_ rule198={GENCAT_LL, NUMCAT_LL, 1, -38864, 0, -38864}; +static const struct _convrule_ rule153={GENCAT_LU, NUMCAT_LU, 1, 0, -74, 0}; static const struct _convrule_ rule24={GENCAT_LU, NUMCAT_LU, 1, 0, -199, 0}; -static const struct _convrule_ rule143={GENCAT_LU, NUMCAT_LU, 1, 0, -100, 0}; -static const struct _convrule_ rule125={GENCAT_LL, NUMCAT_LL, 1, 35332, 0, 35332}; -static const struct _convrule_ rule141={GENCAT_LL, NUMCAT_LL, 1, -7205, 0, -7205}; -static const struct _convrule_ rule138={GENCAT_LL, NUMCAT_LL, 1, 9, 0, 9}; +static const struct _convrule_ rule157={GENCAT_LU, NUMCAT_LU, 1, 0, -100, 0}; +static const struct _convrule_ rule138={GENCAT_LL, NUMCAT_LL, 1, 35332, 0, 35332}; +static const struct _convrule_ rule155={GENCAT_LL, NUMCAT_LL, 1, -7205, 0, -7205}; +static const struct _convrule_ rule152={GENCAT_LL, NUMCAT_LL, 1, 9, 0, 9}; static const struct _convrule_ rule27={GENCAT_LL, NUMCAT_LL, 1, -300, 0, -300}; -static const struct _convrule_ rule172={GENCAT_LU, NUMCAT_LU, 1, 0, -42319, 0}; +static const struct _convrule_ rule187={GENCAT_LU, NUMCAT_LU, 1, 0, -42319, 0}; static const struct _convrule_ rule31={GENCAT_LU, NUMCAT_LU, 1, 0, 205, 0}; static const struct _convrule_ rule59={GENCAT_LU, NUMCAT_LU, 1, 0, 69, 0}; static const struct _convrule_ rule6={GENCAT_SM, NUMCAT_SM, 0, 0, 0, 0}; -static const struct _convrule_ rule119={GENCAT_LL, NUMCAT_LL, 1, -15, 0, -15}; -static const struct _convrule_ rule110={GENCAT_LL, NUMCAT_LL, 1, -80, 0, -80}; -static const struct _convrule_ rule176={GENCAT_LU, NUMCAT_LU, 1, 0, -42282, 0}; -static const struct _convrule_ rule151={GENCAT_LU, NUMCAT_LU, 1, 0, -8262, 0}; -static const struct _convrule_ rule130={GENCAT_LU, NUMCAT_LU, 1, 0, -8, 0}; +static const struct _convrule_ rule121={GENCAT_LL, NUMCAT_LL, 1, -15, 0, -15}; +static const struct _convrule_ rule112={GENCAT_LL, NUMCAT_LL, 1, -80, 0, -80}; +static const struct _convrule_ rule191={GENCAT_LU, NUMCAT_LU, 1, 0, -42282, 0}; +static const struct _convrule_ rule133={GENCAT_LL, NUMCAT_LL, 1, -6243, 0, -6243}; +static const struct _convrule_ rule130={GENCAT_LL, NUMCAT_LL, 1, -6253, 0, -6253}; +static const struct _convrule_ rule165={GENCAT_LU, NUMCAT_LU, 1, 0, -8262, 0}; +static const struct _convrule_ rule144={GENCAT_LU, NUMCAT_LU, 1, 0, -8, 0}; static const struct _convrule_ rule26={GENCAT_LU, NUMCAT_LU, 1, 0, -121, 0}; static const struct _convrule_ rule0={GENCAT_CC, NUMCAT_CC, 0, 0, 0, 0}; -static const struct _convrule_ rule111={GENCAT_LL, NUMCAT_LL, 1, 7, 0, 7}; -static const struct _convrule_ rule91={GENCAT_MN, NUMCAT_MN, 1, 84, 0, 84}; +static const struct _convrule_ rule113={GENCAT_LL, NUMCAT_LL, 1, 7, 0, 7}; +static const struct _convrule_ rule93={GENCAT_MN, NUMCAT_MN, 1, 84, 0, 84}; static const struct _convrule_ rule78={GENCAT_LL, NUMCAT_LL, 1, 10749, 0, 10749}; static const struct _convrule_ rule77={GENCAT_LL, NUMCAT_LL, 1, 42305, 0, 42305}; static const struct _convrule_ rule70={GENCAT_LL, NUMCAT_LL, 1, 42315, 0, 42315}; @@ -201,80 +217,88 @@ static const struct _convrule_ rule50={GENCAT_LL, NUMCAT_LL, 1, -79, 0, -79}; static const struct _convrule_ rule60={GENCAT_LU, NUMCAT_LU, 1, 0, 71, 0}; static const struct _convrule_ rule22={GENCAT_LU, NUMCAT_LU, 1, 0, 1, 0}; static const struct _convrule_ rule49={GENCAT_LL, NUMCAT_LL, 1, -2, 0, -1}; -static const struct _convrule_ rule92={GENCAT_LU, NUMCAT_LU, 1, 0, 116, 0}; -static const struct _convrule_ rule83={GENCAT_LL, NUMCAT_LL, 1, 42282, 0, 42282}; -static const struct _convrule_ rule155={GENCAT_NL, NUMCAT_NL, 1, -16, 0, -16}; -static const struct _convrule_ rule102={GENCAT_LU, NUMCAT_LU, 1, 0, 8, 0}; +static const struct _convrule_ rule94={GENCAT_LU, NUMCAT_LU, 1, 0, 116, 0}; +static const struct _convrule_ rule84={GENCAT_LL, NUMCAT_LL, 1, 42282, 0, 42282}; +static const struct _convrule_ rule169={GENCAT_NL, NUMCAT_NL, 1, -16, 0, -16}; +static const struct _convrule_ rule104={GENCAT_LU, NUMCAT_LU, 1, 0, 8, 0}; static const struct _convrule_ rule23={GENCAT_LL, NUMCAT_LL, 1, -1, 0, -1}; -static const struct _convrule_ rule87={GENCAT_LL, NUMCAT_LL, 1, -219, 0, -219}; +static const struct _convrule_ rule88={GENCAT_LL, NUMCAT_LL, 1, -219, 0, -219}; static const struct _convrule_ rule79={GENCAT_LL, NUMCAT_LL, 1, -213, 0, -213}; static const struct _convrule_ rule64={GENCAT_LL, NUMCAT_LL, 1, -210, 0, -210}; -static const struct _convrule_ rule163={GENCAT_LU, NUMCAT_LU, 1, 0, -10780, 0}; -static const struct _convrule_ rule86={GENCAT_LL, NUMCAT_LL, 1, -71, 0, -71}; -static const struct _convrule_ rule84={GENCAT_LL, NUMCAT_LL, 1, -69, 0, -69}; +static const struct _convrule_ rule177={GENCAT_LU, NUMCAT_LU, 1, 0, -10780, 0}; +static const struct _convrule_ rule87={GENCAT_LL, NUMCAT_LL, 1, -71, 0, -71}; +static const struct _convrule_ rule85={GENCAT_LL, NUMCAT_LL, 1, -69, 0, -69}; static const struct _convrule_ rule32={GENCAT_LU, NUMCAT_LU, 1, 0, 79, 0}; -static const struct _convrule_ rule115={GENCAT_LU, NUMCAT_LU, 1, 0, -7, 0}; +static const struct _convrule_ rule195={GENCAT_LU, NUMCAT_LU, 1, 0, -42307, 0}; +static const struct _convrule_ rule117={GENCAT_LU, NUMCAT_LU, 1, 0, -7, 0}; static const struct _convrule_ rule74={GENCAT_LL, NUMCAT_LL, 1, -209, 0, -209}; -static const struct _convrule_ rule177={GENCAT_CS, NUMCAT_CS, 0, 0, 0, 0}; -static const struct _convrule_ rule140={GENCAT_LT, NUMCAT_LT, 1, 0, -9, 0}; +static const struct _convrule_ rule199={GENCAT_CS, NUMCAT_CS, 0, 0, 0, 0}; +static const struct _convrule_ rule154={GENCAT_LT, NUMCAT_LT, 1, 0, -9, 0}; static const struct _convrule_ rule57={GENCAT_LL, NUMCAT_LL, 1, 10815, 0, 10815}; static const struct _convrule_ rule72={GENCAT_LL, NUMCAT_LL, 1, 42280, 0, 42280}; static const struct _convrule_ rule34={GENCAT_LU, NUMCAT_LU, 1, 0, 203, 0}; +static const struct _convrule_ rule194={GENCAT_LU, NUMCAT_LU, 1, 0, -48, 0}; static const struct _convrule_ rule63={GENCAT_LL, NUMCAT_LL, 1, 10782, 0, 10782}; -static const struct _convrule_ rule170={GENCAT_LU, NUMCAT_LU, 1, 0, -42280, 0}; -static const struct _convrule_ rule145={GENCAT_LU, NUMCAT_LU, 1, 0, -128, 0}; -static const struct _convrule_ rule100={GENCAT_LL, NUMCAT_LL, 1, -64, 0, -64}; +static const struct _convrule_ rule184={GENCAT_LU, NUMCAT_LU, 1, 0, -42280, 0}; +static const struct _convrule_ rule159={GENCAT_LU, NUMCAT_LU, 1, 0, -128, 0}; +static const struct _convrule_ rule102={GENCAT_LL, NUMCAT_LL, 1, -64, 0, -64}; static const struct _convrule_ rule17={GENCAT_NO, NUMCAT_NO, 0, 0, 0, 0}; -static const struct _convrule_ rule89={GENCAT_LM, NUMCAT_LM, 0, 0, 0, 0}; +static const struct _convrule_ rule91={GENCAT_LM, NUMCAT_LM, 0, 0, 0, 0}; static const struct _convrule_ rule46={GENCAT_LL, NUMCAT_LL, 1, 56, 0, 56}; -static const struct _convrule_ rule131={GENCAT_LL, NUMCAT_LL, 1, 74, 0, 74}; +static const struct _convrule_ rule145={GENCAT_LL, NUMCAT_LL, 1, 74, 0, 74}; static const struct _convrule_ rule42={GENCAT_LU, NUMCAT_LU, 1, 0, 214, 0}; -static const struct _convrule_ rule148={GENCAT_ZP, NUMCAT_ZP, 0, 0, 0, 0}; -static const struct _convrule_ rule101={GENCAT_LL, NUMCAT_LL, 1, -63, 0, -63}; +static const struct _convrule_ rule162={GENCAT_ZP, NUMCAT_ZP, 0, 0, 0, 0}; +static const struct _convrule_ rule103={GENCAT_LL, NUMCAT_LL, 1, -63, 0, -63}; static const struct _convrule_ rule36={GENCAT_LL, NUMCAT_LL, 1, 97, 0, 97}; -static const struct _convrule_ rule137={GENCAT_LT, NUMCAT_LT, 1, 0, -8, 0}; -static const struct _convrule_ rule134={GENCAT_LL, NUMCAT_LL, 1, 128, 0, 128}; +static const struct _convrule_ rule151={GENCAT_LT, NUMCAT_LT, 1, 0, -8, 0}; +static const struct _convrule_ rule148={GENCAT_LL, NUMCAT_LL, 1, 128, 0, 128}; static const struct _convrule_ rule81={GENCAT_LL, NUMCAT_LL, 1, 10727, 0, 10727}; static const struct _convrule_ rule62={GENCAT_LL, NUMCAT_LL, 1, 10780, 0, 10780}; static const struct _convrule_ rule41={GENCAT_LL, NUMCAT_LL, 1, 130, 0, 130}; +static const struct _convrule_ rule203={GENCAT_LU, NUMCAT_LU, 1, 0, 34, 0}; +static const struct _convrule_ rule134={GENCAT_LL, NUMCAT_LL, 1, -6236, 0, -6236}; static const struct _convrule_ rule68={GENCAT_LL, NUMCAT_LL, 1, -203, 0, -203}; static const struct _convrule_ rule65={GENCAT_LL, NUMCAT_LL, 1, -206, 0, -206}; static const struct _convrule_ rule48={GENCAT_LT, NUMCAT_LT, 1, -1, 1, 0}; static const struct _convrule_ rule19={GENCAT_PF, NUMCAT_PF, 0, 0, 0, 0}; static const struct _convrule_ rule33={GENCAT_LU, NUMCAT_LU, 1, 0, 202, 0}; -static const struct _convrule_ rule103={GENCAT_LL, NUMCAT_LL, 1, -62, 0, -62}; +static const struct _convrule_ rule105={GENCAT_LL, NUMCAT_LL, 1, -62, 0, -62}; static const struct _convrule_ rule8={GENCAT_ND, NUMCAT_ND, 0, 0, 0, 0}; +static const struct _convrule_ rule193={GENCAT_LU, NUMCAT_LU, 1, 0, 928, 0}; static const struct _convrule_ rule53={GENCAT_LU, NUMCAT_LU, 1, 0, -130, 0}; static const struct _convrule_ rule28={GENCAT_LL, NUMCAT_LL, 1, 195, 0, 195}; -static const struct _convrule_ rule158={GENCAT_LU, NUMCAT_LU, 1, 0, -10743, 0}; -static const struct _convrule_ rule127={GENCAT_LL, NUMCAT_LL, 1, -59, 0, -59}; -static const struct _convrule_ rule113={GENCAT_LU, NUMCAT_LU, 1, 0, -60, 0}; -static const struct _convrule_ rule108={GENCAT_LL, NUMCAT_LL, 1, -8, 0, -8}; +static const struct _convrule_ rule172={GENCAT_LU, NUMCAT_LU, 1, 0, -10743, 0}; +static const struct _convrule_ rule141={GENCAT_LL, NUMCAT_LL, 1, -59, 0, -59}; +static const struct _convrule_ rule115={GENCAT_LU, NUMCAT_LU, 1, 0, -60, 0}; +static const struct _convrule_ rule110={GENCAT_LL, NUMCAT_LL, 1, -8, 0, -8}; static const struct _convrule_ rule73={GENCAT_LL, NUMCAT_LL, 1, 42308, 0, 42308}; static const struct _convrule_ rule40={GENCAT_LU, NUMCAT_LU, 1, 0, 213, 0}; -static const struct _convrule_ rule136={GENCAT_LL, NUMCAT_LL, 1, 126, 0, 126}; -static const struct _convrule_ rule116={GENCAT_LU, NUMCAT_LU, 1, 0, 80, 0}; +static const struct _convrule_ rule150={GENCAT_LL, NUMCAT_LL, 1, 126, 0, 126}; +static const struct _convrule_ rule131={GENCAT_LL, NUMCAT_LL, 1, -6244, 0, -6244}; +static const struct _convrule_ rule129={GENCAT_LL, NUMCAT_LL, 1, -6254, 0, -6254}; +static const struct _convrule_ rule118={GENCAT_LU, NUMCAT_LU, 1, 0, 80, 0}; static const struct _convrule_ rule55={GENCAT_LU, NUMCAT_LU, 1, 0, -163, 0}; -static const struct _convrule_ rule174={GENCAT_LU, NUMCAT_LU, 1, 0, -42305, 0}; -static const struct _convrule_ rule161={GENCAT_LL, NUMCAT_LL, 1, -10795, 0, -10795}; +static const struct _convrule_ rule189={GENCAT_LU, NUMCAT_LU, 1, 0, -42305, 0}; +static const struct _convrule_ rule175={GENCAT_LL, NUMCAT_LL, 1, -10795, 0, -10795}; static const struct _convrule_ rule58={GENCAT_LU, NUMCAT_LU, 1, 0, -195, 0}; static const struct _convrule_ rule54={GENCAT_LU, NUMCAT_LU, 1, 0, 10795, 0}; -static const struct _convrule_ rule107={GENCAT_LL, NUMCAT_LL, 1, -54, 0, -54}; -static const struct _convrule_ rule146={GENCAT_LU, NUMCAT_LU, 1, 0, -126, 0}; -static const struct _convrule_ rule104={GENCAT_LL, NUMCAT_LL, 1, -57, 0, -57}; +static const struct _convrule_ rule135={GENCAT_LL, NUMCAT_LL, 1, -6181, 0, -6181}; +static const struct _convrule_ rule109={GENCAT_LL, NUMCAT_LL, 1, -54, 0, -54}; +static const struct _convrule_ rule160={GENCAT_LU, NUMCAT_LU, 1, 0, -126, 0}; +static const struct _convrule_ rule106={GENCAT_LL, NUMCAT_LL, 1, -57, 0, -57}; static const struct _convrule_ rule21={GENCAT_LL, NUMCAT_LL, 1, 121, 0, 121}; -static const struct _convrule_ rule156={GENCAT_SO, NUMCAT_SO, 1, 0, 26, 0}; -static const struct _convrule_ rule85={GENCAT_LL, NUMCAT_LL, 1, -217, 0, -217}; +static const struct _convrule_ rule170={GENCAT_SO, NUMCAT_SO, 1, 0, 26, 0}; +static const struct _convrule_ rule86={GENCAT_LL, NUMCAT_LL, 1, -217, 0, -217}; static const struct _convrule_ rule16={GENCAT_CF, NUMCAT_CF, 0, 0, 0, 0}; -static const struct _convrule_ rule112={GENCAT_LL, NUMCAT_LL, 1, -116, 0, -116}; +static const struct _convrule_ rule114={GENCAT_LL, NUMCAT_LL, 1, -116, 0, -116}; static const struct _convrule_ rule38={GENCAT_LU, NUMCAT_LU, 1, 0, 209, 0}; static const struct _convrule_ rule10={GENCAT_SK, NUMCAT_SK, 0, 0, 0, 0}; -static const struct _convrule_ rule167={GENCAT_LU, NUMCAT_LU, 1, 0, -10815, 0}; +static const struct _convrule_ rule181={GENCAT_LU, NUMCAT_LU, 1, 0, -10815, 0}; static const struct _convrule_ rule5={GENCAT_PE, NUMCAT_PE, 0, 0, 0, 0}; -static const struct _convrule_ rule164={GENCAT_LU, NUMCAT_LU, 1, 0, -10749, 0}; -static const struct _convrule_ rule117={GENCAT_ME, NUMCAT_ME, 0, 0, 0, 0}; -static const struct _convrule_ rule106={GENCAT_LL, NUMCAT_LL, 1, -47, 0, -47}; -static const struct _convrule_ rule160={GENCAT_LU, NUMCAT_LU, 1, 0, -10727, 0}; +static const struct _convrule_ rule178={GENCAT_LU, NUMCAT_LU, 1, 0, -10749, 0}; +static const struct _convrule_ rule119={GENCAT_ME, NUMCAT_ME, 0, 0, 0, 0}; +static const struct _convrule_ rule108={GENCAT_LL, NUMCAT_LL, 1, -47, 0, -47}; +static const struct _convrule_ rule174={GENCAT_LU, NUMCAT_LU, 1, 0, -10727, 0}; static const struct _convrule_ rule9={GENCAT_LU, NUMCAT_LU, 1, 0, 32, 0}; static const struct _charblock_ allchars[]={ {0, 32, &rule0}, @@ -686,7 +710,7 @@ static const struct _charblock_ allchars[]={ {615, 1, &rule20}, {616, 1, &rule74}, {617, 1, &rule75}, - {618, 1, &rule20}, + {618, 1, &rule73}, {619, 1, &rule76}, {620, 1, &rule77}, {621, 2, &rule20}, @@ -700,70 +724,72 @@ static const struct _charblock_ allchars[]={ {637, 1, &rule81}, {638, 2, &rule20}, {640, 1, &rule82}, - {641, 2, &rule20}, + {641, 1, &rule20}, + {642, 1, &rule83}, {643, 1, &rule82}, {644, 3, &rule20}, - {647, 1, &rule83}, + {647, 1, &rule84}, {648, 1, &rule82}, - {649, 1, &rule84}, - {650, 2, &rule85}, - {652, 1, &rule86}, + {649, 1, &rule85}, + {650, 2, &rule86}, + {652, 1, &rule87}, {653, 5, &rule20}, - {658, 1, &rule87}, + {658, 1, &rule88}, {659, 1, &rule20}, {660, 1, &rule14}, - {661, 9, &rule20}, - {670, 1, &rule88}, + {661, 8, &rule20}, + {669, 1, &rule89}, + {670, 1, &rule90}, {671, 17, &rule20}, - {688, 18, &rule89}, + {688, 18, &rule91}, {706, 4, &rule10}, - {710, 12, &rule89}, + {710, 12, &rule91}, {722, 14, &rule10}, - {736, 5, &rule89}, + {736, 5, &rule91}, {741, 7, &rule10}, - {748, 1, &rule89}, + {748, 1, &rule91}, {749, 1, &rule10}, - {750, 1, &rule89}, + {750, 1, &rule91}, {751, 17, &rule10}, - {768, 69, &rule90}, - {837, 1, &rule91}, - {838, 42, &rule90}, + {768, 69, &rule92}, + {837, 1, &rule93}, + {838, 42, &rule92}, {880, 1, &rule22}, {881, 1, &rule23}, {882, 1, &rule22}, {883, 1, &rule23}, - {884, 1, &rule89}, + {884, 1, &rule91}, {885, 1, &rule10}, {886, 1, &rule22}, {887, 1, &rule23}, - {890, 1, &rule89}, + {890, 1, &rule91}, {891, 3, &rule41}, {894, 1, &rule2}, - {895, 1, &rule92}, + {895, 1, &rule94}, {900, 2, &rule10}, - {902, 1, &rule93}, + {902, 1, &rule95}, {903, 1, &rule2}, - {904, 3, &rule94}, - {908, 1, &rule95}, - {910, 2, &rule96}, + {904, 3, &rule96}, + {908, 1, &rule97}, + {910, 2, &rule98}, {912, 1, &rule20}, {913, 17, &rule9}, {931, 9, &rule9}, - {940, 1, &rule97}, - {941, 3, &rule98}, + {940, 1, &rule99}, + {941, 3, &rule100}, {944, 1, &rule20}, {945, 17, &rule12}, - {962, 1, &rule99}, + {962, 1, &rule101}, {963, 9, &rule12}, - {972, 1, &rule100}, - {973, 2, &rule101}, - {975, 1, &rule102}, - {976, 1, &rule103}, - {977, 1, &rule104}, - {978, 3, &rule105}, - {981, 1, &rule106}, - {982, 1, &rule107}, - {983, 1, &rule108}, + {972, 1, &rule102}, + {973, 2, &rule103}, + {975, 1, &rule104}, + {976, 1, &rule105}, + {977, 1, &rule106}, + {978, 3, &rule107}, + {981, 1, &rule108}, + {982, 1, &rule109}, + {983, 1, &rule110}, {984, 1, &rule22}, {985, 1, &rule23}, {986, 1, &rule22}, @@ -788,24 +814,24 @@ static const struct _charblock_ allchars[]={ {1005, 1, &rule23}, {1006, 1, &rule22}, {1007, 1, &rule23}, - {1008, 1, &rule109}, - {1009, 1, &rule110}, - {1010, 1, &rule111}, - {1011, 1, &rule112}, - {1012, 1, &rule113}, - {1013, 1, &rule114}, + {1008, 1, &rule111}, + {1009, 1, &rule112}, + {1010, 1, &rule113}, + {1011, 1, &rule114}, + {1012, 1, &rule115}, + {1013, 1, &rule116}, {1014, 1, &rule6}, {1015, 1, &rule22}, {1016, 1, &rule23}, - {1017, 1, &rule115}, + {1017, 1, &rule117}, {1018, 1, &rule22}, {1019, 1, &rule23}, {1020, 1, &rule20}, {1021, 3, &rule53}, - {1024, 16, &rule116}, + {1024, 16, &rule118}, {1040, 32, &rule9}, {1072, 32, &rule12}, - {1104, 16, &rule110}, + {1104, 16, &rule112}, {1120, 1, &rule22}, {1121, 1, &rule23}, {1122, 1, &rule22}, @@ -841,8 +867,8 @@ static const struct _charblock_ allchars[]={ {1152, 1, &rule22}, {1153, 1, &rule23}, {1154, 1, &rule13}, - {1155, 5, &rule90}, - {1160, 2, &rule117}, + {1155, 5, &rule92}, + {1160, 2, &rule119}, {1162, 1, &rule22}, {1163, 1, &rule23}, {1164, 1, &rule22}, @@ -897,7 +923,7 @@ static const struct _charblock_ allchars[]={ {1213, 1, &rule23}, {1214, 1, &rule22}, {1215, 1, &rule23}, - {1216, 1, &rule118}, + {1216, 1, &rule120}, {1217, 1, &rule22}, {1218, 1, &rule23}, {1219, 1, &rule22}, @@ -912,7 +938,7 @@ static const struct _charblock_ allchars[]={ {1228, 1, &rule23}, {1229, 1, &rule22}, {1230, 1, &rule23}, - {1231, 1, &rule119}, + {1231, 1, &rule121}, {1232, 1, &rule22}, {1233, 1, &rule23}, {1234, 1, &rule22}, @@ -1009,26 +1035,27 @@ static const struct _charblock_ allchars[]={ {1325, 1, &rule23}, {1326, 1, &rule22}, {1327, 1, &rule23}, - {1329, 38, &rule120}, - {1369, 1, &rule89}, + {1329, 38, &rule122}, + {1369, 1, &rule91}, {1370, 6, &rule2}, - {1377, 38, &rule121}, - {1415, 1, &rule20}, + {1376, 1, &rule20}, + {1377, 38, &rule123}, + {1415, 2, &rule20}, {1417, 1, &rule2}, {1418, 1, &rule7}, {1421, 2, &rule13}, {1423, 1, &rule3}, - {1425, 45, &rule90}, + {1425, 45, &rule92}, {1470, 1, &rule7}, - {1471, 1, &rule90}, + {1471, 1, &rule92}, {1472, 1, &rule2}, - {1473, 2, &rule90}, + {1473, 2, &rule92}, {1475, 1, &rule2}, - {1476, 2, &rule90}, + {1476, 2, &rule92}, {1478, 1, &rule2}, - {1479, 1, &rule90}, + {1479, 1, &rule92}, {1488, 27, &rule14}, - {1520, 3, &rule14}, + {1519, 4, &rule14}, {1523, 2, &rule2}, {1536, 6, &rule16}, {1542, 3, &rule6}, @@ -1036,29 +1063,29 @@ static const struct _charblock_ allchars[]={ {1547, 1, &rule3}, {1548, 2, &rule2}, {1550, 2, &rule13}, - {1552, 11, &rule90}, + {1552, 11, &rule92}, {1563, 1, &rule2}, {1564, 1, &rule16}, {1566, 2, &rule2}, {1568, 32, &rule14}, - {1600, 1, &rule89}, + {1600, 1, &rule91}, {1601, 10, &rule14}, - {1611, 21, &rule90}, + {1611, 21, &rule92}, {1632, 10, &rule8}, {1642, 4, &rule2}, {1646, 2, &rule14}, - {1648, 1, &rule90}, + {1648, 1, &rule92}, {1649, 99, &rule14}, {1748, 1, &rule2}, {1749, 1, &rule14}, - {1750, 7, &rule90}, + {1750, 7, &rule92}, {1757, 1, &rule16}, {1758, 1, &rule13}, - {1759, 6, &rule90}, - {1765, 2, &rule89}, - {1767, 2, &rule90}, + {1759, 6, &rule92}, + {1765, 2, &rule91}, + {1767, 2, &rule92}, {1769, 1, &rule13}, - {1770, 4, &rule90}, + {1770, 4, &rule92}, {1774, 2, &rule14}, {1776, 10, &rule8}, {1786, 3, &rule14}, @@ -1067,81 +1094,90 @@ static const struct _charblock_ allchars[]={ {1792, 14, &rule2}, {1807, 1, &rule16}, {1808, 1, &rule14}, - {1809, 1, &rule90}, + {1809, 1, &rule92}, {1810, 30, &rule14}, - {1840, 27, &rule90}, + {1840, 27, &rule92}, {1869, 89, &rule14}, - {1958, 11, &rule90}, + {1958, 11, &rule92}, {1969, 1, &rule14}, {1984, 10, &rule8}, {1994, 33, &rule14}, - {2027, 9, &rule90}, - {2036, 2, &rule89}, + {2027, 9, &rule92}, + {2036, 2, &rule91}, {2038, 1, &rule13}, {2039, 3, &rule2}, - {2042, 1, &rule89}, + {2042, 1, &rule91}, + {2045, 1, &rule92}, + {2046, 2, &rule3}, {2048, 22, &rule14}, - {2070, 4, &rule90}, - {2074, 1, &rule89}, - {2075, 9, &rule90}, - {2084, 1, &rule89}, - {2085, 3, &rule90}, - {2088, 1, &rule89}, - {2089, 5, &rule90}, + {2070, 4, &rule92}, + {2074, 1, &rule91}, + {2075, 9, &rule92}, + {2084, 1, &rule91}, + {2085, 3, &rule92}, + {2088, 1, &rule91}, + {2089, 5, &rule92}, {2096, 15, &rule2}, {2112, 25, &rule14}, - {2137, 3, &rule90}, + {2137, 3, &rule92}, {2142, 1, &rule2}, - {2208, 19, &rule14}, - {2276, 31, &rule90}, - {2307, 1, &rule122}, + {2144, 11, &rule14}, + {2208, 21, &rule14}, + {2230, 8, &rule14}, + {2259, 15, &rule92}, + {2274, 1, &rule16}, + {2275, 32, &rule92}, + {2307, 1, &rule124}, {2308, 54, &rule14}, - {2362, 1, &rule90}, - {2363, 1, &rule122}, - {2364, 1, &rule90}, + {2362, 1, &rule92}, + {2363, 1, &rule124}, + {2364, 1, &rule92}, {2365, 1, &rule14}, - {2366, 3, &rule122}, - {2369, 8, &rule90}, - {2377, 4, &rule122}, - {2381, 1, &rule90}, - {2382, 2, &rule122}, + {2366, 3, &rule124}, + {2369, 8, &rule92}, + {2377, 4, &rule124}, + {2381, 1, &rule92}, + {2382, 2, &rule124}, {2384, 1, &rule14}, - {2385, 7, &rule90}, + {2385, 7, &rule92}, {2392, 10, &rule14}, - {2402, 2, &rule90}, + {2402, 2, &rule92}, {2404, 2, &rule2}, {2406, 10, &rule8}, {2416, 1, &rule2}, - {2417, 1, &rule89}, + {2417, 1, &rule91}, {2418, 15, &rule14}, - {2433, 1, &rule90}, - {2434, 2, &rule122}, + {2433, 1, &rule92}, + {2434, 2, &rule124}, {2437, 8, &rule14}, {2447, 2, &rule14}, {2451, 22, &rule14}, {2474, 7, &rule14}, {2482, 1, &rule14}, {2486, 4, &rule14}, - {2492, 1, &rule90}, + {2492, 1, &rule92}, {2493, 1, &rule14}, - {2494, 3, &rule122}, - {2497, 4, &rule90}, - {2503, 2, &rule122}, - {2507, 2, &rule122}, - {2509, 1, &rule90}, + {2494, 3, &rule124}, + {2497, 4, &rule92}, + {2503, 2, &rule124}, + {2507, 2, &rule124}, + {2509, 1, &rule92}, {2510, 1, &rule14}, - {2519, 1, &rule122}, + {2519, 1, &rule124}, {2524, 2, &rule14}, {2527, 3, &rule14}, - {2530, 2, &rule90}, + {2530, 2, &rule92}, {2534, 10, &rule8}, {2544, 2, &rule14}, {2546, 2, &rule3}, {2548, 6, &rule17}, {2554, 1, &rule13}, {2555, 1, &rule3}, - {2561, 2, &rule90}, - {2563, 1, &rule122}, + {2556, 1, &rule14}, + {2557, 1, &rule2}, + {2558, 1, &rule92}, + {2561, 2, &rule92}, + {2563, 1, &rule124}, {2565, 6, &rule14}, {2575, 2, &rule14}, {2579, 22, &rule14}, @@ -1149,67 +1185,70 @@ static const struct _charblock_ allchars[]={ {2610, 2, &rule14}, {2613, 2, &rule14}, {2616, 2, &rule14}, - {2620, 1, &rule90}, - {2622, 3, &rule122}, - {2625, 2, &rule90}, - {2631, 2, &rule90}, - {2635, 3, &rule90}, - {2641, 1, &rule90}, + {2620, 1, &rule92}, + {2622, 3, &rule124}, + {2625, 2, &rule92}, + {2631, 2, &rule92}, + {2635, 3, &rule92}, + {2641, 1, &rule92}, {2649, 4, &rule14}, {2654, 1, &rule14}, {2662, 10, &rule8}, - {2672, 2, &rule90}, + {2672, 2, &rule92}, {2674, 3, &rule14}, - {2677, 1, &rule90}, - {2689, 2, &rule90}, - {2691, 1, &rule122}, + {2677, 1, &rule92}, + {2678, 1, &rule2}, + {2689, 2, &rule92}, + {2691, 1, &rule124}, {2693, 9, &rule14}, {2703, 3, &rule14}, {2707, 22, &rule14}, {2730, 7, &rule14}, {2738, 2, &rule14}, {2741, 5, &rule14}, - {2748, 1, &rule90}, + {2748, 1, &rule92}, {2749, 1, &rule14}, - {2750, 3, &rule122}, - {2753, 5, &rule90}, - {2759, 2, &rule90}, - {2761, 1, &rule122}, - {2763, 2, &rule122}, - {2765, 1, &rule90}, + {2750, 3, &rule124}, + {2753, 5, &rule92}, + {2759, 2, &rule92}, + {2761, 1, &rule124}, + {2763, 2, &rule124}, + {2765, 1, &rule92}, {2768, 1, &rule14}, {2784, 2, &rule14}, - {2786, 2, &rule90}, + {2786, 2, &rule92}, {2790, 10, &rule8}, {2800, 1, &rule2}, {2801, 1, &rule3}, - {2817, 1, &rule90}, - {2818, 2, &rule122}, + {2809, 1, &rule14}, + {2810, 6, &rule92}, + {2817, 1, &rule92}, + {2818, 2, &rule124}, {2821, 8, &rule14}, {2831, 2, &rule14}, {2835, 22, &rule14}, {2858, 7, &rule14}, {2866, 2, &rule14}, {2869, 5, &rule14}, - {2876, 1, &rule90}, + {2876, 1, &rule92}, {2877, 1, &rule14}, - {2878, 1, &rule122}, - {2879, 1, &rule90}, - {2880, 1, &rule122}, - {2881, 4, &rule90}, - {2887, 2, &rule122}, - {2891, 2, &rule122}, - {2893, 1, &rule90}, - {2902, 1, &rule90}, - {2903, 1, &rule122}, + {2878, 1, &rule124}, + {2879, 1, &rule92}, + {2880, 1, &rule124}, + {2881, 4, &rule92}, + {2887, 2, &rule124}, + {2891, 2, &rule124}, + {2893, 1, &rule92}, + {2902, 1, &rule92}, + {2903, 1, &rule124}, {2908, 2, &rule14}, {2911, 3, &rule14}, - {2914, 2, &rule90}, + {2914, 2, &rule92}, {2918, 10, &rule8}, {2928, 1, &rule13}, {2929, 1, &rule14}, {2930, 6, &rule17}, - {2946, 1, &rule90}, + {2946, 1, &rule92}, {2947, 1, &rule14}, {2949, 6, &rule14}, {2958, 3, &rule14}, @@ -1220,123 +1259,124 @@ static const struct _charblock_ allchars[]={ {2979, 2, &rule14}, {2984, 3, &rule14}, {2990, 12, &rule14}, - {3006, 2, &rule122}, - {3008, 1, &rule90}, - {3009, 2, &rule122}, - {3014, 3, &rule122}, - {3018, 3, &rule122}, - {3021, 1, &rule90}, + {3006, 2, &rule124}, + {3008, 1, &rule92}, + {3009, 2, &rule124}, + {3014, 3, &rule124}, + {3018, 3, &rule124}, + {3021, 1, &rule92}, {3024, 1, &rule14}, - {3031, 1, &rule122}, + {3031, 1, &rule124}, {3046, 10, &rule8}, {3056, 3, &rule17}, {3059, 6, &rule13}, {3065, 1, &rule3}, {3066, 1, &rule13}, - {3072, 1, &rule90}, - {3073, 3, &rule122}, + {3072, 1, &rule92}, + {3073, 3, &rule124}, + {3076, 1, &rule92}, {3077, 8, &rule14}, {3086, 3, &rule14}, {3090, 23, &rule14}, {3114, 16, &rule14}, {3133, 1, &rule14}, - {3134, 3, &rule90}, - {3137, 4, &rule122}, - {3142, 3, &rule90}, - {3146, 4, &rule90}, - {3157, 2, &rule90}, - {3160, 2, &rule14}, + {3134, 3, &rule92}, + {3137, 4, &rule124}, + {3142, 3, &rule92}, + {3146, 4, &rule92}, + {3157, 2, &rule92}, + {3160, 3, &rule14}, {3168, 2, &rule14}, - {3170, 2, &rule90}, + {3170, 2, &rule92}, {3174, 10, &rule8}, + {3191, 1, &rule2}, {3192, 7, &rule17}, {3199, 1, &rule13}, - {3201, 1, &rule90}, - {3202, 2, &rule122}, + {3200, 1, &rule14}, + {3201, 1, &rule92}, + {3202, 2, &rule124}, + {3204, 1, &rule2}, {3205, 8, &rule14}, {3214, 3, &rule14}, {3218, 23, &rule14}, {3242, 10, &rule14}, {3253, 5, &rule14}, - {3260, 1, &rule90}, + {3260, 1, &rule92}, {3261, 1, &rule14}, - {3262, 1, &rule122}, - {3263, 1, &rule90}, - {3264, 5, &rule122}, - {3270, 1, &rule90}, - {3271, 2, &rule122}, - {3274, 2, &rule122}, - {3276, 2, &rule90}, - {3285, 2, &rule122}, + {3262, 1, &rule124}, + {3263, 1, &rule92}, + {3264, 5, &rule124}, + {3270, 1, &rule92}, + {3271, 2, &rule124}, + {3274, 2, &rule124}, + {3276, 2, &rule92}, + {3285, 2, &rule124}, {3294, 1, &rule14}, {3296, 2, &rule14}, - {3298, 2, &rule90}, + {3298, 2, &rule92}, {3302, 10, &rule8}, {3313, 2, &rule14}, - {3329, 1, &rule90}, - {3330, 2, &rule122}, + {3328, 2, &rule92}, + {3330, 2, &rule124}, {3333, 8, &rule14}, {3342, 3, &rule14}, {3346, 41, &rule14}, + {3387, 2, &rule92}, {3389, 1, &rule14}, - {3390, 3, &rule122}, - {3393, 4, &rule90}, - {3398, 3, &rule122}, - {3402, 3, &rule122}, - {3405, 1, &rule90}, + {3390, 3, &rule124}, + {3393, 4, &rule92}, + {3398, 3, &rule124}, + {3402, 3, &rule124}, + {3405, 1, &rule92}, {3406, 1, &rule14}, - {3415, 1, &rule122}, - {3424, 2, &rule14}, - {3426, 2, &rule90}, + {3407, 1, &rule13}, + {3412, 3, &rule14}, + {3415, 1, &rule124}, + {3416, 7, &rule17}, + {3423, 3, &rule14}, + {3426, 2, &rule92}, {3430, 10, &rule8}, - {3440, 6, &rule17}, + {3440, 9, &rule17}, {3449, 1, &rule13}, {3450, 6, &rule14}, - {3458, 2, &rule122}, + {3458, 2, &rule124}, {3461, 18, &rule14}, {3482, 24, &rule14}, {3507, 9, &rule14}, {3517, 1, &rule14}, {3520, 7, &rule14}, - {3530, 1, &rule90}, - {3535, 3, &rule122}, - {3538, 3, &rule90}, - {3542, 1, &rule90}, - {3544, 8, &rule122}, + {3530, 1, &rule92}, + {3535, 3, &rule124}, + {3538, 3, &rule92}, + {3542, 1, &rule92}, + {3544, 8, &rule124}, {3558, 10, &rule8}, - {3570, 2, &rule122}, + {3570, 2, &rule124}, {3572, 1, &rule2}, {3585, 48, &rule14}, - {3633, 1, &rule90}, + {3633, 1, &rule92}, {3634, 2, &rule14}, - {3636, 7, &rule90}, + {3636, 7, &rule92}, {3647, 1, &rule3}, {3648, 6, &rule14}, - {3654, 1, &rule89}, - {3655, 8, &rule90}, + {3654, 1, &rule91}, + {3655, 8, &rule92}, {3663, 1, &rule2}, {3664, 10, &rule8}, {3674, 2, &rule2}, {3713, 2, &rule14}, {3716, 1, &rule14}, - {3719, 2, &rule14}, - {3722, 1, &rule14}, - {3725, 1, &rule14}, - {3732, 4, &rule14}, - {3737, 7, &rule14}, - {3745, 3, &rule14}, + {3718, 5, &rule14}, + {3724, 24, &rule14}, {3749, 1, &rule14}, - {3751, 1, &rule14}, - {3754, 2, &rule14}, - {3757, 4, &rule14}, - {3761, 1, &rule90}, + {3751, 10, &rule14}, + {3761, 1, &rule92}, {3762, 2, &rule14}, - {3764, 6, &rule90}, - {3771, 2, &rule90}, + {3764, 9, &rule92}, {3773, 1, &rule14}, {3776, 5, &rule14}, - {3782, 1, &rule89}, - {3784, 6, &rule90}, + {3782, 1, &rule91}, + {3784, 6, &rule92}, {3792, 10, &rule8}, {3804, 4, &rule14}, {3840, 1, &rule14}, @@ -1345,80 +1385,81 @@ static const struct _charblock_ allchars[]={ {3859, 1, &rule13}, {3860, 1, &rule2}, {3861, 3, &rule13}, - {3864, 2, &rule90}, + {3864, 2, &rule92}, {3866, 6, &rule13}, {3872, 10, &rule8}, {3882, 10, &rule17}, {3892, 1, &rule13}, - {3893, 1, &rule90}, + {3893, 1, &rule92}, {3894, 1, &rule13}, - {3895, 1, &rule90}, + {3895, 1, &rule92}, {3896, 1, &rule13}, - {3897, 1, &rule90}, + {3897, 1, &rule92}, {3898, 1, &rule4}, {3899, 1, &rule5}, {3900, 1, &rule4}, {3901, 1, &rule5}, - {3902, 2, &rule122}, + {3902, 2, &rule124}, {3904, 8, &rule14}, {3913, 36, &rule14}, - {3953, 14, &rule90}, - {3967, 1, &rule122}, - {3968, 5, &rule90}, + {3953, 14, &rule92}, + {3967, 1, &rule124}, + {3968, 5, &rule92}, {3973, 1, &rule2}, - {3974, 2, &rule90}, + {3974, 2, &rule92}, {3976, 5, &rule14}, - {3981, 11, &rule90}, - {3993, 36, &rule90}, + {3981, 11, &rule92}, + {3993, 36, &rule92}, {4030, 8, &rule13}, - {4038, 1, &rule90}, + {4038, 1, &rule92}, {4039, 6, &rule13}, {4046, 2, &rule13}, {4048, 5, &rule2}, {4053, 4, &rule13}, {4057, 2, &rule2}, {4096, 43, &rule14}, - {4139, 2, &rule122}, - {4141, 4, &rule90}, - {4145, 1, &rule122}, - {4146, 6, &rule90}, - {4152, 1, &rule122}, - {4153, 2, &rule90}, - {4155, 2, &rule122}, - {4157, 2, &rule90}, + {4139, 2, &rule124}, + {4141, 4, &rule92}, + {4145, 1, &rule124}, + {4146, 6, &rule92}, + {4152, 1, &rule124}, + {4153, 2, &rule92}, + {4155, 2, &rule124}, + {4157, 2, &rule92}, {4159, 1, &rule14}, {4160, 10, &rule8}, {4170, 6, &rule2}, {4176, 6, &rule14}, - {4182, 2, &rule122}, - {4184, 2, &rule90}, + {4182, 2, &rule124}, + {4184, 2, &rule92}, {4186, 4, &rule14}, - {4190, 3, &rule90}, + {4190, 3, &rule92}, {4193, 1, &rule14}, - {4194, 3, &rule122}, + {4194, 3, &rule124}, {4197, 2, &rule14}, - {4199, 7, &rule122}, + {4199, 7, &rule124}, {4206, 3, &rule14}, - {4209, 4, &rule90}, + {4209, 4, &rule92}, {4213, 13, &rule14}, - {4226, 1, &rule90}, - {4227, 2, &rule122}, - {4229, 2, &rule90}, - {4231, 6, &rule122}, - {4237, 1, &rule90}, + {4226, 1, &rule92}, + {4227, 2, &rule124}, + {4229, 2, &rule92}, + {4231, 6, &rule124}, + {4237, 1, &rule92}, {4238, 1, &rule14}, - {4239, 1, &rule122}, + {4239, 1, &rule124}, {4240, 10, &rule8}, - {4250, 3, &rule122}, - {4253, 1, &rule90}, + {4250, 3, &rule124}, + {4253, 1, &rule92}, {4254, 2, &rule13}, - {4256, 38, &rule123}, - {4295, 1, &rule123}, - {4301, 1, &rule123}, - {4304, 43, &rule14}, + {4256, 38, &rule125}, + {4295, 1, &rule125}, + {4301, 1, &rule125}, + {4304, 43, &rule126}, {4347, 1, &rule2}, - {4348, 1, &rule89}, - {4349, 332, &rule14}, + {4348, 1, &rule91}, + {4349, 3, &rule126}, + {4352, 329, &rule14}, {4682, 4, &rule14}, {4688, 7, &rule14}, {4696, 1, &rule14}, @@ -1434,12 +1475,14 @@ static const struct _charblock_ allchars[]={ {4824, 57, &rule14}, {4882, 4, &rule14}, {4888, 67, &rule14}, - {4957, 3, &rule90}, + {4957, 3, &rule92}, {4960, 9, &rule2}, {4969, 20, &rule17}, {4992, 16, &rule14}, {5008, 10, &rule13}, - {5024, 85, &rule14}, + {5024, 80, &rule127}, + {5104, 6, &rule104}, + {5112, 6, &rule110}, {5120, 1, &rule7}, {5121, 620, &rule14}, {5741, 2, &rule2}, @@ -1450,168 +1493,181 @@ static const struct _charblock_ allchars[]={ {5788, 1, &rule5}, {5792, 75, &rule14}, {5867, 3, &rule2}, - {5870, 3, &rule124}, + {5870, 3, &rule128}, {5873, 8, &rule14}, {5888, 13, &rule14}, {5902, 4, &rule14}, - {5906, 3, &rule90}, + {5906, 3, &rule92}, {5920, 18, &rule14}, - {5938, 3, &rule90}, + {5938, 3, &rule92}, {5941, 2, &rule2}, {5952, 18, &rule14}, - {5970, 2, &rule90}, + {5970, 2, &rule92}, {5984, 13, &rule14}, {5998, 3, &rule14}, - {6002, 2, &rule90}, + {6002, 2, &rule92}, {6016, 52, &rule14}, - {6068, 2, &rule90}, - {6070, 1, &rule122}, - {6071, 7, &rule90}, - {6078, 8, &rule122}, - {6086, 1, &rule90}, - {6087, 2, &rule122}, - {6089, 11, &rule90}, + {6068, 2, &rule92}, + {6070, 1, &rule124}, + {6071, 7, &rule92}, + {6078, 8, &rule124}, + {6086, 1, &rule92}, + {6087, 2, &rule124}, + {6089, 11, &rule92}, {6100, 3, &rule2}, - {6103, 1, &rule89}, + {6103, 1, &rule91}, {6104, 3, &rule2}, {6107, 1, &rule3}, {6108, 1, &rule14}, - {6109, 1, &rule90}, + {6109, 1, &rule92}, {6112, 10, &rule8}, {6128, 10, &rule17}, {6144, 6, &rule2}, {6150, 1, &rule7}, {6151, 4, &rule2}, - {6155, 3, &rule90}, + {6155, 3, &rule92}, {6158, 1, &rule16}, {6160, 10, &rule8}, {6176, 35, &rule14}, - {6211, 1, &rule89}, - {6212, 52, &rule14}, - {6272, 41, &rule14}, - {6313, 1, &rule90}, + {6211, 1, &rule91}, + {6212, 53, &rule14}, + {6272, 5, &rule14}, + {6277, 2, &rule92}, + {6279, 34, &rule14}, + {6313, 1, &rule92}, {6314, 1, &rule14}, {6320, 70, &rule14}, {6400, 31, &rule14}, - {6432, 3, &rule90}, - {6435, 4, &rule122}, - {6439, 2, &rule90}, - {6441, 3, &rule122}, - {6448, 2, &rule122}, - {6450, 1, &rule90}, - {6451, 6, &rule122}, - {6457, 3, &rule90}, + {6432, 3, &rule92}, + {6435, 4, &rule124}, + {6439, 2, &rule92}, + {6441, 3, &rule124}, + {6448, 2, &rule124}, + {6450, 1, &rule92}, + {6451, 6, &rule124}, + {6457, 3, &rule92}, {6464, 1, &rule13}, {6468, 2, &rule2}, {6470, 10, &rule8}, {6480, 30, &rule14}, {6512, 5, &rule14}, {6528, 44, &rule14}, - {6576, 17, &rule122}, - {6593, 7, &rule14}, - {6600, 2, &rule122}, + {6576, 26, &rule14}, {6608, 10, &rule8}, {6618, 1, &rule17}, {6622, 34, &rule13}, {6656, 23, &rule14}, - {6679, 2, &rule90}, - {6681, 2, &rule122}, - {6683, 1, &rule90}, + {6679, 2, &rule92}, + {6681, 2, &rule124}, + {6683, 1, &rule92}, {6686, 2, &rule2}, {6688, 53, &rule14}, - {6741, 1, &rule122}, - {6742, 1, &rule90}, - {6743, 1, &rule122}, - {6744, 7, &rule90}, - {6752, 1, &rule90}, - {6753, 1, &rule122}, - {6754, 1, &rule90}, - {6755, 2, &rule122}, - {6757, 8, &rule90}, - {6765, 6, &rule122}, - {6771, 10, &rule90}, - {6783, 1, &rule90}, + {6741, 1, &rule124}, + {6742, 1, &rule92}, + {6743, 1, &rule124}, + {6744, 7, &rule92}, + {6752, 1, &rule92}, + {6753, 1, &rule124}, + {6754, 1, &rule92}, + {6755, 2, &rule124}, + {6757, 8, &rule92}, + {6765, 6, &rule124}, + {6771, 10, &rule92}, + {6783, 1, &rule92}, {6784, 10, &rule8}, {6800, 10, &rule8}, {6816, 7, &rule2}, - {6823, 1, &rule89}, + {6823, 1, &rule91}, {6824, 6, &rule2}, - {6832, 14, &rule90}, - {6846, 1, &rule117}, - {6912, 4, &rule90}, - {6916, 1, &rule122}, + {6832, 14, &rule92}, + {6846, 1, &rule119}, + {6912, 4, &rule92}, + {6916, 1, &rule124}, {6917, 47, &rule14}, - {6964, 1, &rule90}, - {6965, 1, &rule122}, - {6966, 5, &rule90}, - {6971, 1, &rule122}, - {6972, 1, &rule90}, - {6973, 5, &rule122}, - {6978, 1, &rule90}, - {6979, 2, &rule122}, + {6964, 1, &rule92}, + {6965, 1, &rule124}, + {6966, 5, &rule92}, + {6971, 1, &rule124}, + {6972, 1, &rule92}, + {6973, 5, &rule124}, + {6978, 1, &rule92}, + {6979, 2, &rule124}, {6981, 7, &rule14}, {6992, 10, &rule8}, {7002, 7, &rule2}, {7009, 10, &rule13}, - {7019, 9, &rule90}, + {7019, 9, &rule92}, {7028, 9, &rule13}, - {7040, 2, &rule90}, - {7042, 1, &rule122}, + {7040, 2, &rule92}, + {7042, 1, &rule124}, {7043, 30, &rule14}, - {7073, 1, &rule122}, - {7074, 4, &rule90}, - {7078, 2, &rule122}, - {7080, 2, &rule90}, - {7082, 1, &rule122}, - {7083, 3, &rule90}, + {7073, 1, &rule124}, + {7074, 4, &rule92}, + {7078, 2, &rule124}, + {7080, 2, &rule92}, + {7082, 1, &rule124}, + {7083, 3, &rule92}, {7086, 2, &rule14}, {7088, 10, &rule8}, {7098, 44, &rule14}, - {7142, 1, &rule90}, - {7143, 1, &rule122}, - {7144, 2, &rule90}, - {7146, 3, &rule122}, - {7149, 1, &rule90}, - {7150, 1, &rule122}, - {7151, 3, &rule90}, - {7154, 2, &rule122}, + {7142, 1, &rule92}, + {7143, 1, &rule124}, + {7144, 2, &rule92}, + {7146, 3, &rule124}, + {7149, 1, &rule92}, + {7150, 1, &rule124}, + {7151, 3, &rule92}, + {7154, 2, &rule124}, {7164, 4, &rule2}, {7168, 36, &rule14}, - {7204, 8, &rule122}, - {7212, 8, &rule90}, - {7220, 2, &rule122}, - {7222, 2, &rule90}, + {7204, 8, &rule124}, + {7212, 8, &rule92}, + {7220, 2, &rule124}, + {7222, 2, &rule92}, {7227, 5, &rule2}, {7232, 10, &rule8}, {7245, 3, &rule14}, {7248, 10, &rule8}, {7258, 30, &rule14}, - {7288, 6, &rule89}, + {7288, 6, &rule91}, {7294, 2, &rule2}, + {7296, 1, &rule129}, + {7297, 1, &rule130}, + {7298, 1, &rule131}, + {7299, 2, &rule132}, + {7301, 1, &rule133}, + {7302, 1, &rule134}, + {7303, 1, &rule135}, + {7304, 1, &rule136}, + {7312, 43, &rule137}, + {7357, 3, &rule137}, {7360, 8, &rule2}, - {7376, 3, &rule90}, + {7376, 3, &rule92}, {7379, 1, &rule2}, - {7380, 13, &rule90}, - {7393, 1, &rule122}, - {7394, 7, &rule90}, + {7380, 13, &rule92}, + {7393, 1, &rule124}, + {7394, 7, &rule92}, {7401, 4, &rule14}, - {7405, 1, &rule90}, - {7406, 4, &rule14}, - {7410, 2, &rule122}, - {7412, 1, &rule90}, + {7405, 1, &rule92}, + {7406, 6, &rule14}, + {7412, 1, &rule92}, {7413, 2, &rule14}, - {7416, 2, &rule90}, + {7415, 1, &rule124}, + {7416, 2, &rule92}, + {7418, 1, &rule14}, {7424, 44, &rule20}, - {7468, 63, &rule89}, + {7468, 63, &rule91}, {7531, 13, &rule20}, - {7544, 1, &rule89}, - {7545, 1, &rule125}, + {7544, 1, &rule91}, + {7545, 1, &rule138}, {7546, 3, &rule20}, - {7549, 1, &rule126}, - {7550, 29, &rule20}, - {7579, 37, &rule89}, - {7616, 54, &rule90}, - {7676, 4, &rule90}, + {7549, 1, &rule139}, + {7550, 16, &rule20}, + {7566, 1, &rule140}, + {7567, 12, &rule20}, + {7579, 37, &rule91}, + {7616, 58, &rule92}, + {7675, 5, &rule92}, {7680, 1, &rule22}, {7681, 1, &rule23}, {7682, 1, &rule22}, @@ -1763,9 +1819,9 @@ static const struct _charblock_ allchars[]={ {7828, 1, &rule22}, {7829, 1, &rule23}, {7830, 5, &rule20}, - {7835, 1, &rule127}, + {7835, 1, &rule141}, {7836, 2, &rule20}, - {7838, 1, &rule128}, + {7838, 1, &rule142}, {7839, 1, &rule20}, {7840, 1, &rule22}, {7841, 1, &rule23}, @@ -1863,81 +1919,81 @@ static const struct _charblock_ allchars[]={ {7933, 1, &rule23}, {7934, 1, &rule22}, {7935, 1, &rule23}, - {7936, 8, &rule129}, - {7944, 8, &rule130}, - {7952, 6, &rule129}, - {7960, 6, &rule130}, - {7968, 8, &rule129}, - {7976, 8, &rule130}, - {7984, 8, &rule129}, - {7992, 8, &rule130}, - {8000, 6, &rule129}, - {8008, 6, &rule130}, + {7936, 8, &rule143}, + {7944, 8, &rule144}, + {7952, 6, &rule143}, + {7960, 6, &rule144}, + {7968, 8, &rule143}, + {7976, 8, &rule144}, + {7984, 8, &rule143}, + {7992, 8, &rule144}, + {8000, 6, &rule143}, + {8008, 6, &rule144}, {8016, 1, &rule20}, - {8017, 1, &rule129}, + {8017, 1, &rule143}, {8018, 1, &rule20}, - {8019, 1, &rule129}, + {8019, 1, &rule143}, {8020, 1, &rule20}, - {8021, 1, &rule129}, + {8021, 1, &rule143}, {8022, 1, &rule20}, - {8023, 1, &rule129}, - {8025, 1, &rule130}, - {8027, 1, &rule130}, - {8029, 1, &rule130}, - {8031, 1, &rule130}, - {8032, 8, &rule129}, - {8040, 8, &rule130}, - {8048, 2, &rule131}, - {8050, 4, &rule132}, - {8054, 2, &rule133}, - {8056, 2, &rule134}, - {8058, 2, &rule135}, - {8060, 2, &rule136}, - {8064, 8, &rule129}, - {8072, 8, &rule137}, - {8080, 8, &rule129}, - {8088, 8, &rule137}, - {8096, 8, &rule129}, - {8104, 8, &rule137}, - {8112, 2, &rule129}, + {8023, 1, &rule143}, + {8025, 1, &rule144}, + {8027, 1, &rule144}, + {8029, 1, &rule144}, + {8031, 1, &rule144}, + {8032, 8, &rule143}, + {8040, 8, &rule144}, + {8048, 2, &rule145}, + {8050, 4, &rule146}, + {8054, 2, &rule147}, + {8056, 2, &rule148}, + {8058, 2, &rule149}, + {8060, 2, &rule150}, + {8064, 8, &rule143}, + {8072, 8, &rule151}, + {8080, 8, &rule143}, + {8088, 8, &rule151}, + {8096, 8, &rule143}, + {8104, 8, &rule151}, + {8112, 2, &rule143}, {8114, 1, &rule20}, - {8115, 1, &rule138}, + {8115, 1, &rule152}, {8116, 1, &rule20}, {8118, 2, &rule20}, - {8120, 2, &rule130}, - {8122, 2, &rule139}, - {8124, 1, &rule140}, + {8120, 2, &rule144}, + {8122, 2, &rule153}, + {8124, 1, &rule154}, {8125, 1, &rule10}, - {8126, 1, &rule141}, + {8126, 1, &rule155}, {8127, 3, &rule10}, {8130, 1, &rule20}, - {8131, 1, &rule138}, + {8131, 1, &rule152}, {8132, 1, &rule20}, {8134, 2, &rule20}, - {8136, 4, &rule142}, - {8140, 1, &rule140}, + {8136, 4, &rule156}, + {8140, 1, &rule154}, {8141, 3, &rule10}, - {8144, 2, &rule129}, + {8144, 2, &rule143}, {8146, 2, &rule20}, {8150, 2, &rule20}, - {8152, 2, &rule130}, - {8154, 2, &rule143}, + {8152, 2, &rule144}, + {8154, 2, &rule157}, {8157, 3, &rule10}, - {8160, 2, &rule129}, + {8160, 2, &rule143}, {8162, 3, &rule20}, - {8165, 1, &rule111}, + {8165, 1, &rule113}, {8166, 2, &rule20}, - {8168, 2, &rule130}, - {8170, 2, &rule144}, - {8172, 1, &rule115}, + {8168, 2, &rule144}, + {8170, 2, &rule158}, + {8172, 1, &rule117}, {8173, 3, &rule10}, {8178, 1, &rule20}, - {8179, 1, &rule138}, + {8179, 1, &rule152}, {8180, 1, &rule20}, {8182, 2, &rule20}, - {8184, 2, &rule145}, - {8186, 2, &rule146}, - {8188, 1, &rule140}, + {8184, 2, &rule159}, + {8186, 2, &rule160}, + {8188, 1, &rule154}, {8189, 2, &rule10}, {8192, 11, &rule1}, {8203, 5, &rule16}, @@ -1951,8 +2007,8 @@ static const struct _charblock_ allchars[]={ {8222, 1, &rule4}, {8223, 1, &rule15}, {8224, 8, &rule2}, - {8232, 1, &rule147}, - {8233, 1, &rule148}, + {8232, 1, &rule161}, + {8233, 1, &rule162}, {8234, 5, &rule16}, {8239, 1, &rule1}, {8240, 9, &rule2}, @@ -1973,75 +2029,76 @@ static const struct _charblock_ allchars[]={ {8288, 5, &rule16}, {8294, 10, &rule16}, {8304, 1, &rule17}, - {8305, 1, &rule89}, + {8305, 1, &rule91}, {8308, 6, &rule17}, {8314, 3, &rule6}, {8317, 1, &rule4}, {8318, 1, &rule5}, - {8319, 1, &rule89}, + {8319, 1, &rule91}, {8320, 10, &rule17}, {8330, 3, &rule6}, {8333, 1, &rule4}, {8334, 1, &rule5}, - {8336, 13, &rule89}, - {8352, 30, &rule3}, - {8400, 13, &rule90}, - {8413, 4, &rule117}, - {8417, 1, &rule90}, - {8418, 3, &rule117}, - {8421, 12, &rule90}, + {8336, 13, &rule91}, + {8352, 32, &rule3}, + {8400, 13, &rule92}, + {8413, 4, &rule119}, + {8417, 1, &rule92}, + {8418, 3, &rule119}, + {8421, 12, &rule92}, {8448, 2, &rule13}, - {8450, 1, &rule105}, + {8450, 1, &rule107}, {8451, 4, &rule13}, - {8455, 1, &rule105}, + {8455, 1, &rule107}, {8456, 2, &rule13}, {8458, 1, &rule20}, - {8459, 3, &rule105}, + {8459, 3, &rule107}, {8462, 2, &rule20}, - {8464, 3, &rule105}, + {8464, 3, &rule107}, {8467, 1, &rule20}, {8468, 1, &rule13}, - {8469, 1, &rule105}, + {8469, 1, &rule107}, {8470, 2, &rule13}, {8472, 1, &rule6}, - {8473, 5, &rule105}, + {8473, 5, &rule107}, {8478, 6, &rule13}, - {8484, 1, &rule105}, + {8484, 1, &rule107}, {8485, 1, &rule13}, - {8486, 1, &rule149}, + {8486, 1, &rule163}, {8487, 1, &rule13}, - {8488, 1, &rule105}, + {8488, 1, &rule107}, {8489, 1, &rule13}, - {8490, 1, &rule150}, - {8491, 1, &rule151}, - {8492, 2, &rule105}, + {8490, 1, &rule164}, + {8491, 1, &rule165}, + {8492, 2, &rule107}, {8494, 1, &rule13}, {8495, 1, &rule20}, - {8496, 2, &rule105}, - {8498, 1, &rule152}, - {8499, 1, &rule105}, + {8496, 2, &rule107}, + {8498, 1, &rule166}, + {8499, 1, &rule107}, {8500, 1, &rule20}, {8501, 4, &rule14}, {8505, 1, &rule20}, {8506, 2, &rule13}, {8508, 2, &rule20}, - {8510, 2, &rule105}, + {8510, 2, &rule107}, {8512, 5, &rule6}, - {8517, 1, &rule105}, + {8517, 1, &rule107}, {8518, 4, &rule20}, {8522, 1, &rule13}, {8523, 1, &rule6}, {8524, 2, &rule13}, - {8526, 1, &rule153}, + {8526, 1, &rule167}, {8527, 1, &rule13}, {8528, 16, &rule17}, - {8544, 16, &rule154}, - {8560, 16, &rule155}, - {8576, 3, &rule124}, + {8544, 16, &rule168}, + {8560, 16, &rule169}, + {8576, 3, &rule128}, {8579, 1, &rule22}, {8580, 1, &rule23}, - {8581, 4, &rule124}, + {8581, 4, &rule128}, {8585, 1, &rule17}, + {8586, 2, &rule13}, {8592, 5, &rule6}, {8597, 5, &rule13}, {8602, 2, &rule6}, @@ -2077,13 +2134,12 @@ static const struct _charblock_ allchars[]={ {9115, 25, &rule6}, {9140, 40, &rule13}, {9180, 6, &rule6}, - {9186, 25, &rule13}, - {9216, 39, &rule13}, + {9186, 69, &rule13}, {9280, 11, &rule13}, {9312, 60, &rule17}, {9372, 26, &rule13}, - {9398, 26, &rule156}, - {9424, 26, &rule157}, + {9398, 26, &rule170}, + {9424, 26, &rule171}, {9450, 22, &rule17}, {9472, 183, &rule13}, {9655, 1, &rule6}, @@ -2164,28 +2220,26 @@ static const struct _charblock_ allchars[]={ {11079, 6, &rule6}, {11085, 39, &rule13}, {11126, 32, &rule13}, - {11160, 34, &rule13}, - {11197, 12, &rule13}, - {11210, 8, &rule13}, - {11264, 47, &rule120}, - {11312, 47, &rule121}, + {11160, 104, &rule13}, + {11264, 47, &rule122}, + {11312, 47, &rule123}, {11360, 1, &rule22}, {11361, 1, &rule23}, - {11362, 1, &rule158}, - {11363, 1, &rule159}, - {11364, 1, &rule160}, - {11365, 1, &rule161}, - {11366, 1, &rule162}, + {11362, 1, &rule172}, + {11363, 1, &rule173}, + {11364, 1, &rule174}, + {11365, 1, &rule175}, + {11366, 1, &rule176}, {11367, 1, &rule22}, {11368, 1, &rule23}, {11369, 1, &rule22}, {11370, 1, &rule23}, {11371, 1, &rule22}, {11372, 1, &rule23}, - {11373, 1, &rule163}, - {11374, 1, &rule164}, - {11375, 1, &rule165}, - {11376, 1, &rule166}, + {11373, 1, &rule177}, + {11374, 1, &rule178}, + {11375, 1, &rule179}, + {11376, 1, &rule180}, {11377, 1, &rule20}, {11378, 1, &rule22}, {11379, 1, &rule23}, @@ -2193,8 +2247,8 @@ static const struct _charblock_ allchars[]={ {11381, 1, &rule22}, {11382, 1, &rule23}, {11383, 5, &rule20}, - {11388, 2, &rule89}, - {11390, 2, &rule167}, + {11388, 2, &rule91}, + {11390, 2, &rule181}, {11392, 1, &rule22}, {11393, 1, &rule23}, {11394, 1, &rule22}, @@ -2301,19 +2355,19 @@ static const struct _charblock_ allchars[]={ {11500, 1, &rule23}, {11501, 1, &rule22}, {11502, 1, &rule23}, - {11503, 3, &rule90}, + {11503, 3, &rule92}, {11506, 1, &rule22}, {11507, 1, &rule23}, {11513, 4, &rule2}, {11517, 1, &rule17}, {11518, 2, &rule2}, - {11520, 38, &rule168}, - {11559, 1, &rule168}, - {11565, 1, &rule168}, + {11520, 38, &rule182}, + {11559, 1, &rule182}, + {11565, 1, &rule182}, {11568, 56, &rule14}, - {11631, 1, &rule89}, + {11631, 1, &rule91}, {11632, 1, &rule2}, - {11647, 1, &rule90}, + {11647, 1, &rule92}, {11648, 23, &rule14}, {11680, 7, &rule14}, {11688, 7, &rule14}, @@ -2323,7 +2377,7 @@ static const struct _charblock_ allchars[]={ {11720, 7, &rule14}, {11728, 7, &rule14}, {11736, 7, &rule14}, - {11744, 32, &rule90}, + {11744, 32, &rule92}, {11776, 2, &rule2}, {11778, 1, &rule15}, {11779, 1, &rule19}, @@ -2354,13 +2408,14 @@ static const struct _charblock_ allchars[]={ {11816, 1, &rule4}, {11817, 1, &rule5}, {11818, 5, &rule2}, - {11823, 1, &rule89}, + {11823, 1, &rule91}, {11824, 10, &rule2}, {11834, 2, &rule7}, {11836, 4, &rule2}, {11840, 1, &rule7}, {11841, 1, &rule2}, {11842, 1, &rule4}, + {11843, 13, &rule2}, {11904, 26, &rule13}, {11931, 89, &rule13}, {12032, 214, &rule13}, @@ -2368,9 +2423,9 @@ static const struct _charblock_ allchars[]={ {12288, 1, &rule1}, {12289, 3, &rule2}, {12292, 1, &rule13}, - {12293, 1, &rule89}, + {12293, 1, &rule91}, {12294, 1, &rule14}, - {12295, 1, &rule124}, + {12295, 1, &rule128}, {12296, 1, &rule4}, {12297, 1, &rule5}, {12298, 1, &rule4}, @@ -2394,28 +2449,28 @@ static const struct _charblock_ allchars[]={ {12317, 1, &rule4}, {12318, 2, &rule5}, {12320, 1, &rule13}, - {12321, 9, &rule124}, - {12330, 4, &rule90}, - {12334, 2, &rule122}, + {12321, 9, &rule128}, + {12330, 4, &rule92}, + {12334, 2, &rule124}, {12336, 1, &rule7}, - {12337, 5, &rule89}, + {12337, 5, &rule91}, {12342, 2, &rule13}, - {12344, 3, &rule124}, - {12347, 1, &rule89}, + {12344, 3, &rule128}, + {12347, 1, &rule91}, {12348, 1, &rule14}, {12349, 1, &rule2}, {12350, 2, &rule13}, {12353, 86, &rule14}, - {12441, 2, &rule90}, + {12441, 2, &rule92}, {12443, 2, &rule10}, - {12445, 2, &rule89}, + {12445, 2, &rule91}, {12447, 1, &rule14}, {12448, 1, &rule7}, {12449, 90, &rule14}, {12539, 1, &rule2}, - {12540, 3, &rule89}, + {12540, 3, &rule91}, {12543, 1, &rule14}, - {12549, 41, &rule14}, + {12549, 43, &rule14}, {12593, 94, &rule14}, {12688, 2, &rule13}, {12690, 4, &rule17}, @@ -2437,16 +2492,16 @@ static const struct _charblock_ allchars[]={ {13056, 256, &rule13}, {13312, 6582, &rule14}, {19904, 64, &rule13}, - {19968, 20941, &rule14}, + {19968, 20976, &rule14}, {40960, 21, &rule14}, - {40981, 1, &rule89}, + {40981, 1, &rule91}, {40982, 1143, &rule14}, {42128, 55, &rule13}, {42192, 40, &rule14}, - {42232, 6, &rule89}, + {42232, 6, &rule91}, {42238, 2, &rule2}, {42240, 268, &rule14}, - {42508, 1, &rule89}, + {42508, 1, &rule91}, {42509, 3, &rule2}, {42512, 16, &rule14}, {42528, 10, &rule8}, @@ -2498,12 +2553,12 @@ static const struct _charblock_ allchars[]={ {42604, 1, &rule22}, {42605, 1, &rule23}, {42606, 1, &rule14}, - {42607, 1, &rule90}, - {42608, 3, &rule117}, + {42607, 1, &rule92}, + {42608, 3, &rule119}, {42611, 1, &rule2}, - {42612, 10, &rule90}, + {42612, 10, &rule92}, {42622, 1, &rule2}, - {42623, 1, &rule89}, + {42623, 1, &rule91}, {42624, 1, &rule22}, {42625, 1, &rule23}, {42626, 1, &rule22}, @@ -2532,14 +2587,14 @@ static const struct _charblock_ allchars[]={ {42649, 1, &rule23}, {42650, 1, &rule22}, {42651, 1, &rule23}, - {42652, 2, &rule89}, - {42655, 1, &rule90}, + {42652, 2, &rule91}, + {42654, 2, &rule92}, {42656, 70, &rule14}, - {42726, 10, &rule124}, - {42736, 2, &rule90}, + {42726, 10, &rule128}, + {42736, 2, &rule92}, {42738, 6, &rule2}, {42752, 23, &rule10}, - {42775, 9, &rule89}, + {42775, 9, &rule91}, {42784, 2, &rule10}, {42786, 1, &rule22}, {42787, 1, &rule23}, @@ -2618,13 +2673,13 @@ static const struct _charblock_ allchars[]={ {42861, 1, &rule23}, {42862, 1, &rule22}, {42863, 1, &rule23}, - {42864, 1, &rule89}, + {42864, 1, &rule91}, {42865, 8, &rule20}, {42873, 1, &rule22}, {42874, 1, &rule23}, {42875, 1, &rule22}, {42876, 1, &rule23}, - {42877, 1, &rule169}, + {42877, 1, &rule183}, {42878, 1, &rule22}, {42879, 1, &rule23}, {42880, 1, &rule22}, @@ -2635,17 +2690,19 @@ static const struct _charblock_ allchars[]={ {42885, 1, &rule23}, {42886, 1, &rule22}, {42887, 1, &rule23}, - {42888, 1, &rule89}, + {42888, 1, &rule91}, {42889, 2, &rule10}, {42891, 1, &rule22}, {42892, 1, &rule23}, - {42893, 1, &rule170}, + {42893, 1, &rule184}, {42894, 1, &rule20}, + {42895, 1, &rule14}, {42896, 1, &rule22}, {42897, 1, &rule23}, {42898, 1, &rule22}, {42899, 1, &rule23}, - {42900, 2, &rule20}, + {42900, 1, &rule185}, + {42901, 1, &rule20}, {42902, 1, &rule22}, {42903, 1, &rule23}, {42904, 1, &rule22}, @@ -2666,25 +2723,46 @@ static const struct _charblock_ allchars[]={ {42919, 1, &rule23}, {42920, 1, &rule22}, {42921, 1, &rule23}, - {42922, 1, &rule171}, - {42923, 1, &rule172}, - {42924, 1, &rule173}, - {42925, 1, &rule174}, - {42928, 1, &rule175}, - {42929, 1, &rule176}, + {42922, 1, &rule186}, + {42923, 1, &rule187}, + {42924, 1, &rule188}, + {42925, 1, &rule189}, + {42926, 1, &rule186}, + {42927, 1, &rule20}, + {42928, 1, &rule190}, + {42929, 1, &rule191}, + {42930, 1, &rule192}, + {42931, 1, &rule193}, + {42932, 1, &rule22}, + {42933, 1, &rule23}, + {42934, 1, &rule22}, + {42935, 1, &rule23}, + {42936, 1, &rule22}, + {42937, 1, &rule23}, + {42938, 1, &rule22}, + {42939, 1, &rule23}, + {42940, 1, &rule22}, + {42941, 1, &rule23}, + {42942, 1, &rule22}, + {42943, 1, &rule23}, + {42946, 1, &rule22}, + {42947, 1, &rule23}, + {42948, 1, &rule194}, + {42949, 1, &rule195}, + {42950, 1, &rule196}, {42999, 1, &rule14}, - {43000, 2, &rule89}, + {43000, 2, &rule91}, {43002, 1, &rule20}, {43003, 7, &rule14}, - {43010, 1, &rule90}, + {43010, 1, &rule92}, {43011, 3, &rule14}, - {43014, 1, &rule90}, + {43014, 1, &rule92}, {43015, 4, &rule14}, - {43019, 1, &rule90}, + {43019, 1, &rule92}, {43020, 23, &rule14}, - {43043, 2, &rule122}, - {43045, 2, &rule90}, - {43047, 1, &rule122}, + {43043, 2, &rule124}, + {43045, 2, &rule92}, + {43047, 1, &rule124}, {43048, 4, &rule13}, {43056, 6, &rule17}, {43062, 2, &rule13}, @@ -2692,120 +2770,126 @@ static const struct _charblock_ allchars[]={ {43065, 1, &rule13}, {43072, 52, &rule14}, {43124, 4, &rule2}, - {43136, 2, &rule122}, + {43136, 2, &rule124}, {43138, 50, &rule14}, - {43188, 16, &rule122}, - {43204, 1, &rule90}, + {43188, 16, &rule124}, + {43204, 2, &rule92}, {43214, 2, &rule2}, {43216, 10, &rule8}, - {43232, 18, &rule90}, + {43232, 18, &rule92}, {43250, 6, &rule14}, {43256, 3, &rule2}, {43259, 1, &rule14}, + {43260, 1, &rule2}, + {43261, 2, &rule14}, + {43263, 1, &rule92}, {43264, 10, &rule8}, {43274, 28, &rule14}, - {43302, 8, &rule90}, + {43302, 8, &rule92}, {43310, 2, &rule2}, {43312, 23, &rule14}, - {43335, 11, &rule90}, - {43346, 2, &rule122}, + {43335, 11, &rule92}, + {43346, 2, &rule124}, {43359, 1, &rule2}, {43360, 29, &rule14}, - {43392, 3, &rule90}, - {43395, 1, &rule122}, + {43392, 3, &rule92}, + {43395, 1, &rule124}, {43396, 47, &rule14}, - {43443, 1, &rule90}, - {43444, 2, &rule122}, - {43446, 4, &rule90}, - {43450, 2, &rule122}, - {43452, 1, &rule90}, - {43453, 4, &rule122}, + {43443, 1, &rule92}, + {43444, 2, &rule124}, + {43446, 4, &rule92}, + {43450, 2, &rule124}, + {43452, 1, &rule92}, + {43453, 4, &rule124}, {43457, 13, &rule2}, - {43471, 1, &rule89}, + {43471, 1, &rule91}, {43472, 10, &rule8}, {43486, 2, &rule2}, {43488, 5, &rule14}, - {43493, 1, &rule90}, - {43494, 1, &rule89}, + {43493, 1, &rule92}, + {43494, 1, &rule91}, {43495, 9, &rule14}, {43504, 10, &rule8}, {43514, 5, &rule14}, {43520, 41, &rule14}, - {43561, 6, &rule90}, - {43567, 2, &rule122}, - {43569, 2, &rule90}, - {43571, 2, &rule122}, - {43573, 2, &rule90}, + {43561, 6, &rule92}, + {43567, 2, &rule124}, + {43569, 2, &rule92}, + {43571, 2, &rule124}, + {43573, 2, &rule92}, {43584, 3, &rule14}, - {43587, 1, &rule90}, + {43587, 1, &rule92}, {43588, 8, &rule14}, - {43596, 1, &rule90}, - {43597, 1, &rule122}, + {43596, 1, &rule92}, + {43597, 1, &rule124}, {43600, 10, &rule8}, {43612, 4, &rule2}, {43616, 16, &rule14}, - {43632, 1, &rule89}, + {43632, 1, &rule91}, {43633, 6, &rule14}, {43639, 3, &rule13}, {43642, 1, &rule14}, - {43643, 1, &rule122}, - {43644, 1, &rule90}, - {43645, 1, &rule122}, + {43643, 1, &rule124}, + {43644, 1, &rule92}, + {43645, 1, &rule124}, {43646, 50, &rule14}, - {43696, 1, &rule90}, + {43696, 1, &rule92}, {43697, 1, &rule14}, - {43698, 3, &rule90}, + {43698, 3, &rule92}, {43701, 2, &rule14}, - {43703, 2, &rule90}, + {43703, 2, &rule92}, {43705, 5, &rule14}, - {43710, 2, &rule90}, + {43710, 2, &rule92}, {43712, 1, &rule14}, - {43713, 1, &rule90}, + {43713, 1, &rule92}, {43714, 1, &rule14}, {43739, 2, &rule14}, - {43741, 1, &rule89}, + {43741, 1, &rule91}, {43742, 2, &rule2}, {43744, 11, &rule14}, - {43755, 1, &rule122}, - {43756, 2, &rule90}, - {43758, 2, &rule122}, + {43755, 1, &rule124}, + {43756, 2, &rule92}, + {43758, 2, &rule124}, {43760, 2, &rule2}, {43762, 1, &rule14}, - {43763, 2, &rule89}, - {43765, 1, &rule122}, - {43766, 1, &rule90}, + {43763, 2, &rule91}, + {43765, 1, &rule124}, + {43766, 1, &rule92}, {43777, 6, &rule14}, {43785, 6, &rule14}, {43793, 6, &rule14}, {43808, 7, &rule14}, {43816, 7, &rule14}, - {43824, 43, &rule20}, + {43824, 35, &rule20}, + {43859, 1, &rule197}, + {43860, 7, &rule20}, {43867, 1, &rule10}, - {43868, 4, &rule89}, - {43876, 2, &rule20}, + {43868, 4, &rule91}, + {43872, 8, &rule20}, + {43888, 80, &rule198}, {43968, 35, &rule14}, - {44003, 2, &rule122}, - {44005, 1, &rule90}, - {44006, 2, &rule122}, - {44008, 1, &rule90}, - {44009, 2, &rule122}, + {44003, 2, &rule124}, + {44005, 1, &rule92}, + {44006, 2, &rule124}, + {44008, 1, &rule92}, + {44009, 2, &rule124}, {44011, 1, &rule2}, - {44012, 1, &rule122}, - {44013, 1, &rule90}, + {44012, 1, &rule124}, + {44013, 1, &rule92}, {44016, 10, &rule8}, {44032, 11172, &rule14}, {55216, 23, &rule14}, {55243, 49, &rule14}, - {55296, 896, &rule177}, - {56192, 128, &rule177}, - {56320, 1024, &rule177}, - {57344, 6400, &rule178}, + {55296, 896, &rule199}, + {56192, 128, &rule199}, + {56320, 1024, &rule199}, + {57344, 6400, &rule200}, {63744, 366, &rule14}, {64112, 106, &rule14}, {64256, 7, &rule20}, {64275, 5, &rule20}, {64285, 1, &rule14}, - {64286, 1, &rule90}, + {64286, 1, &rule92}, {64287, 10, &rule14}, {64297, 1, &rule6}, {64298, 13, &rule14}, @@ -2823,12 +2907,12 @@ static const struct _charblock_ allchars[]={ {65008, 12, &rule14}, {65020, 1, &rule3}, {65021, 1, &rule13}, - {65024, 16, &rule90}, + {65024, 16, &rule92}, {65040, 7, &rule2}, {65047, 1, &rule4}, {65048, 1, &rule5}, {65049, 1, &rule2}, - {65056, 14, &rule90}, + {65056, 16, &rule92}, {65072, 1, &rule2}, {65073, 2, &rule7}, {65075, 2, &rule11}, @@ -2905,9 +2989,9 @@ static const struct _charblock_ allchars[]={ {65379, 1, &rule5}, {65380, 2, &rule2}, {65382, 10, &rule14}, - {65392, 1, &rule89}, + {65392, 1, &rule91}, {65393, 45, &rule14}, - {65438, 2, &rule89}, + {65438, 2, &rule91}, {65440, 31, &rule14}, {65474, 6, &rule14}, {65482, 6, &rule14}, @@ -2933,37 +3017,39 @@ static const struct _charblock_ allchars[]={ {65792, 3, &rule2}, {65799, 45, &rule17}, {65847, 9, &rule13}, - {65856, 53, &rule124}, + {65856, 53, &rule128}, {65909, 4, &rule17}, {65913, 17, &rule13}, {65930, 2, &rule17}, - {65932, 1, &rule13}, + {65932, 3, &rule13}, {65936, 12, &rule13}, {65952, 1, &rule13}, {66000, 45, &rule13}, - {66045, 1, &rule90}, + {66045, 1, &rule92}, {66176, 29, &rule14}, {66208, 49, &rule14}, - {66272, 1, &rule90}, + {66272, 1, &rule92}, {66273, 27, &rule17}, {66304, 32, &rule14}, {66336, 4, &rule17}, - {66352, 17, &rule14}, - {66369, 1, &rule124}, + {66349, 20, &rule14}, + {66369, 1, &rule128}, {66370, 8, &rule14}, - {66378, 1, &rule124}, + {66378, 1, &rule128}, {66384, 38, &rule14}, - {66422, 5, &rule90}, + {66422, 5, &rule92}, {66432, 30, &rule14}, {66463, 1, &rule2}, {66464, 36, &rule14}, {66504, 8, &rule14}, {66512, 1, &rule2}, - {66513, 5, &rule124}, - {66560, 40, &rule179}, - {66600, 40, &rule180}, + {66513, 5, &rule128}, + {66560, 40, &rule201}, + {66600, 40, &rule202}, {66640, 78, &rule14}, {66720, 10, &rule8}, + {66736, 36, &rule201}, + {66776, 36, &rule202}, {66816, 40, &rule14}, {66864, 52, &rule14}, {66927, 1, &rule2}, @@ -2983,23 +3069,29 @@ static const struct _charblock_ allchars[]={ {67705, 7, &rule17}, {67712, 31, &rule14}, {67751, 9, &rule17}, + {67808, 19, &rule14}, + {67828, 2, &rule14}, + {67835, 5, &rule17}, {67840, 22, &rule14}, {67862, 6, &rule17}, {67871, 1, &rule2}, {67872, 26, &rule14}, {67903, 1, &rule2}, {67968, 56, &rule14}, + {68028, 2, &rule17}, {68030, 2, &rule14}, + {68032, 16, &rule17}, + {68050, 46, &rule17}, {68096, 1, &rule14}, - {68097, 3, &rule90}, - {68101, 2, &rule90}, - {68108, 4, &rule90}, + {68097, 3, &rule92}, + {68101, 2, &rule92}, + {68108, 4, &rule92}, {68112, 4, &rule14}, {68117, 3, &rule14}, - {68121, 27, &rule14}, - {68152, 3, &rule90}, - {68159, 1, &rule90}, - {68160, 8, &rule17}, + {68121, 29, &rule14}, + {68152, 3, &rule92}, + {68159, 1, &rule92}, + {68160, 9, &rule17}, {68176, 9, &rule2}, {68192, 29, &rule14}, {68221, 2, &rule17}, @@ -3009,7 +3101,7 @@ static const struct _charblock_ allchars[]={ {68288, 8, &rule14}, {68296, 1, &rule13}, {68297, 28, &rule14}, - {68325, 2, &rule90}, + {68325, 2, &rule92}, {68331, 5, &rule17}, {68336, 7, &rule2}, {68352, 54, &rule14}, @@ -3022,258 +3114,458 @@ static const struct _charblock_ allchars[]={ {68505, 4, &rule2}, {68521, 7, &rule17}, {68608, 73, &rule14}, + {68736, 51, &rule97}, + {68800, 51, &rule102}, + {68858, 6, &rule17}, + {68864, 36, &rule14}, + {68900, 4, &rule92}, + {68912, 10, &rule8}, {69216, 31, &rule17}, - {69632, 1, &rule122}, - {69633, 1, &rule90}, - {69634, 1, &rule122}, + {69376, 29, &rule14}, + {69405, 10, &rule17}, + {69415, 1, &rule14}, + {69424, 22, &rule14}, + {69446, 11, &rule92}, + {69457, 4, &rule17}, + {69461, 5, &rule2}, + {69600, 23, &rule14}, + {69632, 1, &rule124}, + {69633, 1, &rule92}, + {69634, 1, &rule124}, {69635, 53, &rule14}, - {69688, 15, &rule90}, + {69688, 15, &rule92}, {69703, 7, &rule2}, {69714, 20, &rule17}, {69734, 10, &rule8}, - {69759, 3, &rule90}, - {69762, 1, &rule122}, + {69759, 3, &rule92}, + {69762, 1, &rule124}, {69763, 45, &rule14}, - {69808, 3, &rule122}, - {69811, 4, &rule90}, - {69815, 2, &rule122}, - {69817, 2, &rule90}, + {69808, 3, &rule124}, + {69811, 4, &rule92}, + {69815, 2, &rule124}, + {69817, 2, &rule92}, {69819, 2, &rule2}, {69821, 1, &rule16}, {69822, 4, &rule2}, + {69837, 1, &rule16}, {69840, 25, &rule14}, {69872, 10, &rule8}, - {69888, 3, &rule90}, + {69888, 3, &rule92}, {69891, 36, &rule14}, - {69927, 5, &rule90}, - {69932, 1, &rule122}, - {69933, 8, &rule90}, + {69927, 5, &rule92}, + {69932, 1, &rule124}, + {69933, 8, &rule92}, {69942, 10, &rule8}, {69952, 4, &rule2}, + {69956, 1, &rule14}, + {69957, 2, &rule124}, {69968, 35, &rule14}, - {70003, 1, &rule90}, + {70003, 1, &rule92}, {70004, 2, &rule2}, {70006, 1, &rule14}, - {70016, 2, &rule90}, - {70018, 1, &rule122}, + {70016, 2, &rule92}, + {70018, 1, &rule124}, {70019, 48, &rule14}, - {70067, 3, &rule122}, - {70070, 9, &rule90}, - {70079, 2, &rule122}, + {70067, 3, &rule124}, + {70070, 9, &rule92}, + {70079, 2, &rule124}, {70081, 4, &rule14}, {70085, 4, &rule2}, + {70089, 4, &rule92}, {70093, 1, &rule2}, {70096, 10, &rule8}, {70106, 1, &rule14}, + {70107, 1, &rule2}, + {70108, 1, &rule14}, + {70109, 3, &rule2}, {70113, 20, &rule17}, {70144, 18, &rule14}, {70163, 25, &rule14}, - {70188, 3, &rule122}, - {70191, 3, &rule90}, - {70194, 2, &rule122}, - {70196, 1, &rule90}, - {70197, 1, &rule122}, - {70198, 2, &rule90}, + {70188, 3, &rule124}, + {70191, 3, &rule92}, + {70194, 2, &rule124}, + {70196, 1, &rule92}, + {70197, 1, &rule124}, + {70198, 2, &rule92}, {70200, 6, &rule2}, + {70206, 1, &rule92}, + {70272, 7, &rule14}, + {70280, 1, &rule14}, + {70282, 4, &rule14}, + {70287, 15, &rule14}, + {70303, 10, &rule14}, + {70313, 1, &rule2}, {70320, 47, &rule14}, - {70367, 1, &rule90}, - {70368, 3, &rule122}, - {70371, 8, &rule90}, + {70367, 1, &rule92}, + {70368, 3, &rule124}, + {70371, 8, &rule92}, {70384, 10, &rule8}, - {70401, 1, &rule90}, - {70402, 2, &rule122}, + {70400, 2, &rule92}, + {70402, 2, &rule124}, {70405, 8, &rule14}, {70415, 2, &rule14}, {70419, 22, &rule14}, {70442, 7, &rule14}, {70450, 2, &rule14}, {70453, 5, &rule14}, - {70460, 1, &rule90}, + {70459, 2, &rule92}, {70461, 1, &rule14}, - {70462, 2, &rule122}, - {70464, 1, &rule90}, - {70465, 4, &rule122}, - {70471, 2, &rule122}, - {70475, 3, &rule122}, - {70487, 1, &rule122}, + {70462, 2, &rule124}, + {70464, 1, &rule92}, + {70465, 4, &rule124}, + {70471, 2, &rule124}, + {70475, 3, &rule124}, + {70480, 1, &rule14}, + {70487, 1, &rule124}, {70493, 5, &rule14}, - {70498, 2, &rule122}, - {70502, 7, &rule90}, - {70512, 5, &rule90}, + {70498, 2, &rule124}, + {70502, 7, &rule92}, + {70512, 5, &rule92}, + {70656, 53, &rule14}, + {70709, 3, &rule124}, + {70712, 8, &rule92}, + {70720, 2, &rule124}, + {70722, 3, &rule92}, + {70725, 1, &rule124}, + {70726, 1, &rule92}, + {70727, 4, &rule14}, + {70731, 5, &rule2}, + {70736, 10, &rule8}, + {70747, 1, &rule2}, + {70749, 1, &rule2}, + {70750, 1, &rule92}, + {70751, 1, &rule14}, {70784, 48, &rule14}, - {70832, 3, &rule122}, - {70835, 6, &rule90}, - {70841, 1, &rule122}, - {70842, 1, &rule90}, - {70843, 4, &rule122}, - {70847, 2, &rule90}, - {70849, 1, &rule122}, - {70850, 2, &rule90}, + {70832, 3, &rule124}, + {70835, 6, &rule92}, + {70841, 1, &rule124}, + {70842, 1, &rule92}, + {70843, 4, &rule124}, + {70847, 2, &rule92}, + {70849, 1, &rule124}, + {70850, 2, &rule92}, {70852, 2, &rule14}, {70854, 1, &rule2}, {70855, 1, &rule14}, {70864, 10, &rule8}, {71040, 47, &rule14}, - {71087, 3, &rule122}, - {71090, 4, &rule90}, - {71096, 4, &rule122}, - {71100, 2, &rule90}, - {71102, 1, &rule122}, - {71103, 2, &rule90}, - {71105, 9, &rule2}, + {71087, 3, &rule124}, + {71090, 4, &rule92}, + {71096, 4, &rule124}, + {71100, 2, &rule92}, + {71102, 1, &rule124}, + {71103, 2, &rule92}, + {71105, 23, &rule2}, + {71128, 4, &rule14}, + {71132, 2, &rule92}, {71168, 48, &rule14}, - {71216, 3, &rule122}, - {71219, 8, &rule90}, - {71227, 2, &rule122}, - {71229, 1, &rule90}, - {71230, 1, &rule122}, - {71231, 2, &rule90}, + {71216, 3, &rule124}, + {71219, 8, &rule92}, + {71227, 2, &rule124}, + {71229, 1, &rule92}, + {71230, 1, &rule124}, + {71231, 2, &rule92}, {71233, 3, &rule2}, {71236, 1, &rule14}, {71248, 10, &rule8}, + {71264, 13, &rule2}, {71296, 43, &rule14}, - {71339, 1, &rule90}, - {71340, 1, &rule122}, - {71341, 1, &rule90}, - {71342, 2, &rule122}, - {71344, 6, &rule90}, - {71350, 1, &rule122}, - {71351, 1, &rule90}, + {71339, 1, &rule92}, + {71340, 1, &rule124}, + {71341, 1, &rule92}, + {71342, 2, &rule124}, + {71344, 6, &rule92}, + {71350, 1, &rule124}, + {71351, 1, &rule92}, + {71352, 1, &rule14}, {71360, 10, &rule8}, + {71424, 27, &rule14}, + {71453, 3, &rule92}, + {71456, 2, &rule124}, + {71458, 4, &rule92}, + {71462, 1, &rule124}, + {71463, 5, &rule92}, + {71472, 10, &rule8}, + {71482, 2, &rule17}, + {71484, 3, &rule2}, + {71487, 1, &rule13}, + {71680, 44, &rule14}, + {71724, 3, &rule124}, + {71727, 9, &rule92}, + {71736, 1, &rule124}, + {71737, 2, &rule92}, + {71739, 1, &rule2}, {71840, 32, &rule9}, {71872, 32, &rule12}, {71904, 10, &rule8}, {71914, 9, &rule17}, {71935, 1, &rule14}, + {72096, 8, &rule14}, + {72106, 39, &rule14}, + {72145, 1, &rule124}, + {72146, 1, &rule92}, + {72147, 1, &rule124}, + {72148, 4, &rule92}, + {72154, 2, &rule92}, + {72156, 4, &rule124}, + {72160, 1, &rule92}, + {72161, 3, &rule14}, + {72164, 1, &rule124}, + {72192, 1, &rule14}, + {72193, 10, &rule92}, + {72203, 40, &rule14}, + {72243, 6, &rule92}, + {72249, 1, &rule124}, + {72250, 1, &rule14}, + {72251, 4, &rule92}, + {72255, 8, &rule2}, + {72263, 1, &rule92}, + {72272, 1, &rule14}, + {72273, 6, &rule92}, + {72279, 2, &rule124}, + {72281, 3, &rule92}, + {72284, 46, &rule14}, + {72330, 13, &rule92}, + {72343, 1, &rule124}, + {72344, 2, &rule92}, + {72346, 3, &rule2}, + {72349, 1, &rule14}, + {72350, 5, &rule2}, {72384, 57, &rule14}, - {73728, 921, &rule14}, - {74752, 111, &rule124}, + {72704, 9, &rule14}, + {72714, 37, &rule14}, + {72751, 1, &rule124}, + {72752, 7, &rule92}, + {72760, 6, &rule92}, + {72766, 1, &rule124}, + {72767, 1, &rule92}, + {72768, 1, &rule14}, + {72769, 5, &rule2}, + {72784, 10, &rule8}, + {72794, 19, &rule17}, + {72816, 2, &rule2}, + {72818, 30, &rule14}, + {72850, 22, &rule92}, + {72873, 1, &rule124}, + {72874, 7, &rule92}, + {72881, 1, &rule124}, + {72882, 2, &rule92}, + {72884, 1, &rule124}, + {72885, 2, &rule92}, + {72960, 7, &rule14}, + {72968, 2, &rule14}, + {72971, 38, &rule14}, + {73009, 6, &rule92}, + {73018, 1, &rule92}, + {73020, 2, &rule92}, + {73023, 7, &rule92}, + {73030, 1, &rule14}, + {73031, 1, &rule92}, + {73040, 10, &rule8}, + {73056, 6, &rule14}, + {73063, 2, &rule14}, + {73066, 32, &rule14}, + {73098, 5, &rule124}, + {73104, 2, &rule92}, + {73107, 2, &rule124}, + {73109, 1, &rule92}, + {73110, 1, &rule124}, + {73111, 1, &rule92}, + {73112, 1, &rule14}, + {73120, 10, &rule8}, + {73440, 19, &rule14}, + {73459, 2, &rule92}, + {73461, 2, &rule124}, + {73463, 2, &rule2}, + {73664, 21, &rule17}, + {73685, 8, &rule13}, + {73693, 4, &rule3}, + {73697, 17, &rule13}, + {73727, 1, &rule2}, + {73728, 922, &rule14}, + {74752, 111, &rule128}, {74864, 5, &rule2}, + {74880, 196, &rule14}, {77824, 1071, &rule14}, + {78896, 9, &rule16}, + {82944, 583, &rule14}, {92160, 569, &rule14}, {92736, 31, &rule14}, {92768, 10, &rule8}, {92782, 2, &rule2}, {92880, 30, &rule14}, - {92912, 5, &rule90}, + {92912, 5, &rule92}, {92917, 1, &rule2}, {92928, 48, &rule14}, - {92976, 7, &rule90}, + {92976, 7, &rule92}, {92983, 5, &rule2}, {92988, 4, &rule13}, - {92992, 4, &rule89}, + {92992, 4, &rule91}, {92996, 1, &rule2}, {92997, 1, &rule13}, {93008, 10, &rule8}, {93019, 7, &rule17}, {93027, 21, &rule14}, {93053, 19, &rule14}, - {93952, 69, &rule14}, + {93760, 32, &rule9}, + {93792, 32, &rule12}, + {93824, 23, &rule17}, + {93847, 4, &rule2}, + {93952, 75, &rule14}, + {94031, 1, &rule92}, {94032, 1, &rule14}, - {94033, 46, &rule122}, - {94095, 4, &rule90}, - {94099, 13, &rule89}, - {110592, 2, &rule14}, + {94033, 55, &rule124}, + {94095, 4, &rule92}, + {94099, 13, &rule91}, + {94176, 2, &rule91}, + {94178, 1, &rule2}, + {94179, 1, &rule91}, + {94208, 6136, &rule14}, + {100352, 755, &rule14}, + {110592, 287, &rule14}, + {110928, 3, &rule14}, + {110948, 4, &rule14}, + {110960, 396, &rule14}, {113664, 107, &rule14}, {113776, 13, &rule14}, {113792, 9, &rule14}, {113808, 10, &rule14}, {113820, 1, &rule13}, - {113821, 2, &rule90}, + {113821, 2, &rule92}, {113823, 1, &rule2}, {113824, 4, &rule16}, {118784, 246, &rule13}, {119040, 39, &rule13}, {119081, 60, &rule13}, - {119141, 2, &rule122}, - {119143, 3, &rule90}, + {119141, 2, &rule124}, + {119143, 3, &rule92}, {119146, 3, &rule13}, - {119149, 6, &rule122}, + {119149, 6, &rule124}, {119155, 8, &rule16}, - {119163, 8, &rule90}, + {119163, 8, &rule92}, {119171, 2, &rule13}, - {119173, 7, &rule90}, + {119173, 7, &rule92}, {119180, 30, &rule13}, - {119210, 4, &rule90}, - {119214, 48, &rule13}, + {119210, 4, &rule92}, + {119214, 59, &rule13}, {119296, 66, &rule13}, - {119362, 3, &rule90}, + {119362, 3, &rule92}, {119365, 1, &rule13}, + {119520, 20, &rule17}, {119552, 87, &rule13}, - {119648, 18, &rule17}, - {119808, 26, &rule105}, + {119648, 25, &rule17}, + {119808, 26, &rule107}, {119834, 26, &rule20}, - {119860, 26, &rule105}, + {119860, 26, &rule107}, {119886, 7, &rule20}, {119894, 18, &rule20}, - {119912, 26, &rule105}, + {119912, 26, &rule107}, {119938, 26, &rule20}, - {119964, 1, &rule105}, - {119966, 2, &rule105}, - {119970, 1, &rule105}, - {119973, 2, &rule105}, - {119977, 4, &rule105}, - {119982, 8, &rule105}, + {119964, 1, &rule107}, + {119966, 2, &rule107}, + {119970, 1, &rule107}, + {119973, 2, &rule107}, + {119977, 4, &rule107}, + {119982, 8, &rule107}, {119990, 4, &rule20}, {119995, 1, &rule20}, {119997, 7, &rule20}, {120005, 11, &rule20}, - {120016, 26, &rule105}, + {120016, 26, &rule107}, {120042, 26, &rule20}, - {120068, 2, &rule105}, - {120071, 4, &rule105}, - {120077, 8, &rule105}, - {120086, 7, &rule105}, + {120068, 2, &rule107}, + {120071, 4, &rule107}, + {120077, 8, &rule107}, + {120086, 7, &rule107}, {120094, 26, &rule20}, - {120120, 2, &rule105}, - {120123, 4, &rule105}, - {120128, 5, &rule105}, - {120134, 1, &rule105}, - {120138, 7, &rule105}, + {120120, 2, &rule107}, + {120123, 4, &rule107}, + {120128, 5, &rule107}, + {120134, 1, &rule107}, + {120138, 7, &rule107}, {120146, 26, &rule20}, - {120172, 26, &rule105}, + {120172, 26, &rule107}, {120198, 26, &rule20}, - {120224, 26, &rule105}, + {120224, 26, &rule107}, {120250, 26, &rule20}, - {120276, 26, &rule105}, + {120276, 26, &rule107}, {120302, 26, &rule20}, - {120328, 26, &rule105}, + {120328, 26, &rule107}, {120354, 26, &rule20}, - {120380, 26, &rule105}, + {120380, 26, &rule107}, {120406, 26, &rule20}, - {120432, 26, &rule105}, + {120432, 26, &rule107}, {120458, 28, &rule20}, - {120488, 25, &rule105}, + {120488, 25, &rule107}, {120513, 1, &rule6}, {120514, 25, &rule20}, {120539, 1, &rule6}, {120540, 6, &rule20}, - {120546, 25, &rule105}, + {120546, 25, &rule107}, {120571, 1, &rule6}, {120572, 25, &rule20}, {120597, 1, &rule6}, {120598, 6, &rule20}, - {120604, 25, &rule105}, + {120604, 25, &rule107}, {120629, 1, &rule6}, {120630, 25, &rule20}, {120655, 1, &rule6}, {120656, 6, &rule20}, - {120662, 25, &rule105}, + {120662, 25, &rule107}, {120687, 1, &rule6}, {120688, 25, &rule20}, {120713, 1, &rule6}, {120714, 6, &rule20}, - {120720, 25, &rule105}, + {120720, 25, &rule107}, {120745, 1, &rule6}, {120746, 25, &rule20}, {120771, 1, &rule6}, {120772, 6, &rule20}, - {120778, 1, &rule105}, + {120778, 1, &rule107}, {120779, 1, &rule20}, {120782, 50, &rule8}, + {120832, 512, &rule13}, + {121344, 55, &rule92}, + {121399, 4, &rule13}, + {121403, 50, &rule92}, + {121453, 8, &rule13}, + {121461, 1, &rule92}, + {121462, 14, &rule13}, + {121476, 1, &rule92}, + {121477, 2, &rule13}, + {121479, 5, &rule2}, + {121499, 5, &rule92}, + {121505, 15, &rule92}, + {122880, 7, &rule92}, + {122888, 17, &rule92}, + {122907, 7, &rule92}, + {122915, 2, &rule92}, + {122918, 5, &rule92}, + {123136, 45, &rule14}, + {123184, 7, &rule92}, + {123191, 7, &rule91}, + {123200, 10, &rule8}, + {123214, 2, &rule14}, + {123584, 44, &rule14}, + {123628, 4, &rule92}, + {123632, 10, &rule8}, + {123647, 1, &rule3}, {124928, 197, &rule14}, {125127, 9, &rule17}, - {125136, 7, &rule90}, + {125136, 7, &rule92}, + {125184, 34, &rule203}, + {125218, 34, &rule204}, + {125252, 7, &rule92}, + {125264, 10, &rule8}, + {125278, 2, &rule2}, + {126065, 59, &rule17}, + {126124, 1, &rule13}, + {126125, 3, &rule17}, + {126128, 1, &rule3}, + {126129, 4, &rule17}, + {126209, 45, &rule17}, + {126254, 1, &rule13}, + {126255, 15, &rule17}, {126464, 4, &rule14}, {126469, 27, &rule14}, {126497, 2, &rule14}, @@ -3315,41 +3607,49 @@ static const struct _charblock_ allchars[]={ {127169, 15, &rule13}, {127185, 37, &rule13}, {127232, 13, &rule17}, - {127248, 31, &rule13}, - {127280, 60, &rule13}, - {127344, 43, &rule13}, + {127248, 93, &rule13}, + {127344, 61, &rule13}, {127462, 29, &rule13}, - {127504, 43, &rule13}, + {127504, 44, &rule13}, {127552, 9, &rule13}, {127568, 2, &rule13}, - {127744, 45, &rule13}, - {127792, 78, &rule13}, - {127872, 79, &rule13}, - {127956, 36, &rule13}, - {128000, 255, &rule13}, - {128256, 75, &rule13}, - {128336, 42, &rule13}, - {128379, 41, &rule13}, - {128421, 158, &rule13}, - {128581, 139, &rule13}, + {127584, 6, &rule13}, + {127744, 251, &rule13}, + {127995, 5, &rule10}, + {128000, 726, &rule13}, {128736, 13, &rule13}, - {128752, 4, &rule13}, + {128752, 11, &rule13}, {128768, 116, &rule13}, - {128896, 85, &rule13}, + {128896, 89, &rule13}, + {128992, 12, &rule13}, {129024, 12, &rule13}, {129040, 56, &rule13}, {129104, 10, &rule13}, {129120, 40, &rule13}, {129168, 30, &rule13}, + {129280, 12, &rule13}, + {129293, 101, &rule13}, + {129395, 4, &rule13}, + {129402, 41, &rule13}, + {129445, 6, &rule13}, + {129454, 29, &rule13}, + {129485, 135, &rule13}, + {129632, 14, &rule13}, + {129648, 4, &rule13}, + {129656, 3, &rule13}, + {129664, 3, &rule13}, + {129680, 6, &rule13}, {131072, 42711, &rule14}, {173824, 4149, &rule14}, {177984, 222, &rule14}, + {178208, 5762, &rule14}, + {183984, 7473, &rule14}, {194560, 542, &rule14}, {917505, 1, &rule16}, {917536, 96, &rule16}, - {917760, 240, &rule90}, - {983040, 65534, &rule178}, - {1048576, 65534, &rule178} + {917760, 240, &rule92}, + {983040, 65534, &rule200}, + {1048576, 65534, &rule200} }; static const struct _charblock_ convchars[]={ {65, 26, &rule9}, @@ -3688,6 +3988,7 @@ static const struct _charblock_ convchars[]={ {614, 1, &rule73}, {616, 1, &rule74}, {617, 1, &rule75}, + {618, 1, &rule73}, {619, 1, &rule76}, {620, 1, &rule77}, {623, 1, &rule75}, @@ -3696,15 +3997,17 @@ static const struct _charblock_ convchars[]={ {629, 1, &rule80}, {637, 1, &rule81}, {640, 1, &rule82}, + {642, 1, &rule83}, {643, 1, &rule82}, - {647, 1, &rule83}, + {647, 1, &rule84}, {648, 1, &rule82}, - {649, 1, &rule84}, - {650, 2, &rule85}, - {652, 1, &rule86}, - {658, 1, &rule87}, - {670, 1, &rule88}, - {837, 1, &rule91}, + {649, 1, &rule85}, + {650, 2, &rule86}, + {652, 1, &rule87}, + {658, 1, &rule88}, + {669, 1, &rule89}, + {670, 1, &rule90}, + {837, 1, &rule93}, {880, 1, &rule22}, {881, 1, &rule23}, {882, 1, &rule22}, @@ -3712,26 +4015,26 @@ static const struct _charblock_ convchars[]={ {886, 1, &rule22}, {887, 1, &rule23}, {891, 3, &rule41}, - {895, 1, &rule92}, - {902, 1, &rule93}, - {904, 3, &rule94}, - {908, 1, &rule95}, - {910, 2, &rule96}, + {895, 1, &rule94}, + {902, 1, &rule95}, + {904, 3, &rule96}, + {908, 1, &rule97}, + {910, 2, &rule98}, {913, 17, &rule9}, {931, 9, &rule9}, - {940, 1, &rule97}, - {941, 3, &rule98}, + {940, 1, &rule99}, + {941, 3, &rule100}, {945, 17, &rule12}, - {962, 1, &rule99}, + {962, 1, &rule101}, {963, 9, &rule12}, - {972, 1, &rule100}, - {973, 2, &rule101}, - {975, 1, &rule102}, - {976, 1, &rule103}, - {977, 1, &rule104}, - {981, 1, &rule106}, - {982, 1, &rule107}, - {983, 1, &rule108}, + {972, 1, &rule102}, + {973, 2, &rule103}, + {975, 1, &rule104}, + {976, 1, &rule105}, + {977, 1, &rule106}, + {981, 1, &rule108}, + {982, 1, &rule109}, + {983, 1, &rule110}, {984, 1, &rule22}, {985, 1, &rule23}, {986, 1, &rule22}, @@ -3756,22 +4059,22 @@ static const struct _charblock_ convchars[]={ {1005, 1, &rule23}, {1006, 1, &rule22}, {1007, 1, &rule23}, - {1008, 1, &rule109}, - {1009, 1, &rule110}, - {1010, 1, &rule111}, - {1011, 1, &rule112}, - {1012, 1, &rule113}, - {1013, 1, &rule114}, + {1008, 1, &rule111}, + {1009, 1, &rule112}, + {1010, 1, &rule113}, + {1011, 1, &rule114}, + {1012, 1, &rule115}, + {1013, 1, &rule116}, {1015, 1, &rule22}, {1016, 1, &rule23}, - {1017, 1, &rule115}, + {1017, 1, &rule117}, {1018, 1, &rule22}, {1019, 1, &rule23}, {1021, 3, &rule53}, - {1024, 16, &rule116}, + {1024, 16, &rule118}, {1040, 32, &rule9}, {1072, 32, &rule12}, - {1104, 16, &rule110}, + {1104, 16, &rule112}, {1120, 1, &rule22}, {1121, 1, &rule23}, {1122, 1, &rule22}, @@ -3860,7 +4163,7 @@ static const struct _charblock_ convchars[]={ {1213, 1, &rule23}, {1214, 1, &rule22}, {1215, 1, &rule23}, - {1216, 1, &rule118}, + {1216, 1, &rule120}, {1217, 1, &rule22}, {1218, 1, &rule23}, {1219, 1, &rule22}, @@ -3875,7 +4178,7 @@ static const struct _charblock_ convchars[]={ {1228, 1, &rule23}, {1229, 1, &rule22}, {1230, 1, &rule23}, - {1231, 1, &rule119}, + {1231, 1, &rule121}, {1232, 1, &rule22}, {1233, 1, &rule23}, {1234, 1, &rule22}, @@ -3972,13 +4275,29 @@ static const struct _charblock_ convchars[]={ {1325, 1, &rule23}, {1326, 1, &rule22}, {1327, 1, &rule23}, - {1329, 38, &rule120}, - {1377, 38, &rule121}, - {4256, 38, &rule123}, - {4295, 1, &rule123}, - {4301, 1, &rule123}, - {7545, 1, &rule125}, - {7549, 1, &rule126}, + {1329, 38, &rule122}, + {1377, 38, &rule123}, + {4256, 38, &rule125}, + {4295, 1, &rule125}, + {4301, 1, &rule125}, + {4304, 43, &rule126}, + {4349, 3, &rule126}, + {5024, 80, &rule127}, + {5104, 6, &rule104}, + {5112, 6, &rule110}, + {7296, 1, &rule129}, + {7297, 1, &rule130}, + {7298, 1, &rule131}, + {7299, 2, &rule132}, + {7301, 1, &rule133}, + {7302, 1, &rule134}, + {7303, 1, &rule135}, + {7304, 1, &rule136}, + {7312, 43, &rule137}, + {7357, 3, &rule137}, + {7545, 1, &rule138}, + {7549, 1, &rule139}, + {7566, 1, &rule140}, {7680, 1, &rule22}, {7681, 1, &rule23}, {7682, 1, &rule22}, @@ -4129,8 +4448,8 @@ static const struct _charblock_ convchars[]={ {7827, 1, &rule23}, {7828, 1, &rule22}, {7829, 1, &rule23}, - {7835, 1, &rule127}, - {7838, 1, &rule128}, + {7835, 1, &rule141}, + {7838, 1, &rule142}, {7840, 1, &rule22}, {7841, 1, &rule23}, {7842, 1, &rule22}, @@ -4227,94 +4546,94 @@ static const struct _charblock_ convchars[]={ {7933, 1, &rule23}, {7934, 1, &rule22}, {7935, 1, &rule23}, - {7936, 8, &rule129}, - {7944, 8, &rule130}, - {7952, 6, &rule129}, - {7960, 6, &rule130}, - {7968, 8, &rule129}, - {7976, 8, &rule130}, - {7984, 8, &rule129}, - {7992, 8, &rule130}, - {8000, 6, &rule129}, - {8008, 6, &rule130}, - {8017, 1, &rule129}, - {8019, 1, &rule129}, - {8021, 1, &rule129}, - {8023, 1, &rule129}, - {8025, 1, &rule130}, - {8027, 1, &rule130}, - {8029, 1, &rule130}, - {8031, 1, &rule130}, - {8032, 8, &rule129}, - {8040, 8, &rule130}, - {8048, 2, &rule131}, - {8050, 4, &rule132}, - {8054, 2, &rule133}, - {8056, 2, &rule134}, - {8058, 2, &rule135}, - {8060, 2, &rule136}, - {8064, 8, &rule129}, - {8072, 8, &rule137}, - {8080, 8, &rule129}, - {8088, 8, &rule137}, - {8096, 8, &rule129}, - {8104, 8, &rule137}, - {8112, 2, &rule129}, - {8115, 1, &rule138}, - {8120, 2, &rule130}, - {8122, 2, &rule139}, - {8124, 1, &rule140}, - {8126, 1, &rule141}, - {8131, 1, &rule138}, - {8136, 4, &rule142}, - {8140, 1, &rule140}, - {8144, 2, &rule129}, - {8152, 2, &rule130}, - {8154, 2, &rule143}, - {8160, 2, &rule129}, - {8165, 1, &rule111}, - {8168, 2, &rule130}, - {8170, 2, &rule144}, - {8172, 1, &rule115}, - {8179, 1, &rule138}, - {8184, 2, &rule145}, - {8186, 2, &rule146}, - {8188, 1, &rule140}, - {8486, 1, &rule149}, - {8490, 1, &rule150}, - {8491, 1, &rule151}, - {8498, 1, &rule152}, - {8526, 1, &rule153}, - {8544, 16, &rule154}, - {8560, 16, &rule155}, + {7936, 8, &rule143}, + {7944, 8, &rule144}, + {7952, 6, &rule143}, + {7960, 6, &rule144}, + {7968, 8, &rule143}, + {7976, 8, &rule144}, + {7984, 8, &rule143}, + {7992, 8, &rule144}, + {8000, 6, &rule143}, + {8008, 6, &rule144}, + {8017, 1, &rule143}, + {8019, 1, &rule143}, + {8021, 1, &rule143}, + {8023, 1, &rule143}, + {8025, 1, &rule144}, + {8027, 1, &rule144}, + {8029, 1, &rule144}, + {8031, 1, &rule144}, + {8032, 8, &rule143}, + {8040, 8, &rule144}, + {8048, 2, &rule145}, + {8050, 4, &rule146}, + {8054, 2, &rule147}, + {8056, 2, &rule148}, + {8058, 2, &rule149}, + {8060, 2, &rule150}, + {8064, 8, &rule143}, + {8072, 8, &rule151}, + {8080, 8, &rule143}, + {8088, 8, &rule151}, + {8096, 8, &rule143}, + {8104, 8, &rule151}, + {8112, 2, &rule143}, + {8115, 1, &rule152}, + {8120, 2, &rule144}, + {8122, 2, &rule153}, + {8124, 1, &rule154}, + {8126, 1, &rule155}, + {8131, 1, &rule152}, + {8136, 4, &rule156}, + {8140, 1, &rule154}, + {8144, 2, &rule143}, + {8152, 2, &rule144}, + {8154, 2, &rule157}, + {8160, 2, &rule143}, + {8165, 1, &rule113}, + {8168, 2, &rule144}, + {8170, 2, &rule158}, + {8172, 1, &rule117}, + {8179, 1, &rule152}, + {8184, 2, &rule159}, + {8186, 2, &rule160}, + {8188, 1, &rule154}, + {8486, 1, &rule163}, + {8490, 1, &rule164}, + {8491, 1, &rule165}, + {8498, 1, &rule166}, + {8526, 1, &rule167}, + {8544, 16, &rule168}, + {8560, 16, &rule169}, {8579, 1, &rule22}, {8580, 1, &rule23}, - {9398, 26, &rule156}, - {9424, 26, &rule157}, - {11264, 47, &rule120}, - {11312, 47, &rule121}, + {9398, 26, &rule170}, + {9424, 26, &rule171}, + {11264, 47, &rule122}, + {11312, 47, &rule123}, {11360, 1, &rule22}, {11361, 1, &rule23}, - {11362, 1, &rule158}, - {11363, 1, &rule159}, - {11364, 1, &rule160}, - {11365, 1, &rule161}, - {11366, 1, &rule162}, + {11362, 1, &rule172}, + {11363, 1, &rule173}, + {11364, 1, &rule174}, + {11365, 1, &rule175}, + {11366, 1, &rule176}, {11367, 1, &rule22}, {11368, 1, &rule23}, {11369, 1, &rule22}, {11370, 1, &rule23}, {11371, 1, &rule22}, {11372, 1, &rule23}, - {11373, 1, &rule163}, - {11374, 1, &rule164}, - {11375, 1, &rule165}, - {11376, 1, &rule166}, + {11373, 1, &rule177}, + {11374, 1, &rule178}, + {11375, 1, &rule179}, + {11376, 1, &rule180}, {11378, 1, &rule22}, {11379, 1, &rule23}, {11381, 1, &rule22}, {11382, 1, &rule23}, - {11390, 2, &rule167}, + {11390, 2, &rule181}, {11392, 1, &rule22}, {11393, 1, &rule23}, {11394, 1, &rule22}, @@ -4421,9 +4740,9 @@ static const struct _charblock_ convchars[]={ {11502, 1, &rule23}, {11506, 1, &rule22}, {11507, 1, &rule23}, - {11520, 38, &rule168}, - {11559, 1, &rule168}, - {11565, 1, &rule168}, + {11520, 38, &rule182}, + {11559, 1, &rule182}, + {11565, 1, &rule182}, {42560, 1, &rule22}, {42561, 1, &rule23}, {42562, 1, &rule22}, @@ -4578,7 +4897,7 @@ static const struct _charblock_ convchars[]={ {42874, 1, &rule23}, {42875, 1, &rule22}, {42876, 1, &rule23}, - {42877, 1, &rule169}, + {42877, 1, &rule183}, {42878, 1, &rule22}, {42879, 1, &rule23}, {42880, 1, &rule22}, @@ -4591,11 +4910,12 @@ static const struct _charblock_ convchars[]={ {42887, 1, &rule23}, {42891, 1, &rule22}, {42892, 1, &rule23}, - {42893, 1, &rule170}, + {42893, 1, &rule184}, {42896, 1, &rule22}, {42897, 1, &rule23}, {42898, 1, &rule22}, {42899, 1, &rule23}, + {42900, 1, &rule185}, {42902, 1, &rule22}, {42903, 1, &rule23}, {42904, 1, &rule22}, @@ -4616,18 +4936,48 @@ static const struct _charblock_ convchars[]={ {42919, 1, &rule23}, {42920, 1, &rule22}, {42921, 1, &rule23}, - {42922, 1, &rule171}, - {42923, 1, &rule172}, - {42924, 1, &rule173}, - {42925, 1, &rule174}, - {42928, 1, &rule175}, - {42929, 1, &rule176}, + {42922, 1, &rule186}, + {42923, 1, &rule187}, + {42924, 1, &rule188}, + {42925, 1, &rule189}, + {42926, 1, &rule186}, + {42928, 1, &rule190}, + {42929, 1, &rule191}, + {42930, 1, &rule192}, + {42931, 1, &rule193}, + {42932, 1, &rule22}, + {42933, 1, &rule23}, + {42934, 1, &rule22}, + {42935, 1, &rule23}, + {42936, 1, &rule22}, + {42937, 1, &rule23}, + {42938, 1, &rule22}, + {42939, 1, &rule23}, + {42940, 1, &rule22}, + {42941, 1, &rule23}, + {42942, 1, &rule22}, + {42943, 1, &rule23}, + {42946, 1, &rule22}, + {42947, 1, &rule23}, + {42948, 1, &rule194}, + {42949, 1, &rule195}, + {42950, 1, &rule196}, + {43859, 1, &rule197}, + {43888, 80, &rule198}, {65313, 26, &rule9}, {65345, 26, &rule12}, - {66560, 40, &rule179}, - {66600, 40, &rule180}, + {66560, 40, &rule201}, + {66600, 40, &rule202}, + {66736, 36, &rule201}, + {66776, 36, &rule202}, + {68736, 51, &rule97}, + {68800, 51, &rule102}, {71840, 32, &rule9}, - {71872, 32, &rule12} + {71872, 32, &rule12}, + {93760, 32, &rule9}, + {93792, 32, &rule12}, + {125184, 34, &rule203}, + {125218, 34, &rule204} }; static const struct _charblock_ spacechars[]={ {32, 1, &rule1}, @@ -4726,7 +5076,6 @@ unipred(u_iswalpha,(GENCAT_LL|GENCAT_LU|GENCAT_LT|GENCAT_LM|GENCAT_LO)) unipred(u_iswdigit,GENCAT_ND) unipred(u_iswalnum,(GENCAT_LT|GENCAT_LU|GENCAT_LL|GENCAT_LM|GENCAT_LO| - GENCAT_MC|GENCAT_ME|GENCAT_MN| GENCAT_NO|GENCAT_ND|GENCAT_NL)) #define caseconv(p,to) \ @@ -4745,4 +5094,3 @@ HsInt u_gencat(HsInt c) { return getrule(allchars,NUM_BLOCKS,c)->catnumber; } - diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c index 965adc2902..b33db04c35 100644 --- a/libraries/base/cbits/Win32Utils.c +++ b/libraries/base/cbits/Win32Utils.c @@ -1,12 +1,18 @@ /* ---------------------------------------------------------------------------- (c) The University of Glasgow 2006 - + Useful Win32 bits ------------------------------------------------------------------------- */ #if defined(_WIN32) #include "HsBase.h" +#include <stdbool.h> +#include <stdint.h> +/* Using Secure APIs */ +#define MINGW_HAS_SECURE_API 1 +#include <wchar.h> +#include <windows.h> /* This is the error table that defines the mapping between OS error codes and errno values */ @@ -148,4 +154,43 @@ BOOL file_exists(LPCTSTR path) return r != INVALID_FILE_ATTRIBUTES; } +bool getTempFileNameErrorNo (wchar_t* pathName, wchar_t* prefix, + wchar_t* suffix, uint32_t uUnique, + wchar_t* tempFileName) +{ + if (!GetTempFileNameW(pathName, prefix, uUnique, tempFileName)) + { + maperrno(); + return false; + } + + wchar_t* drive = malloc (sizeof(wchar_t) * _MAX_DRIVE); + wchar_t* dir = malloc (sizeof(wchar_t) * _MAX_DIR); + wchar_t* fname = malloc (sizeof(wchar_t) * _MAX_FNAME); + bool success = true; + if (_wsplitpath_s (tempFileName, drive, _MAX_DRIVE, dir, _MAX_DIR, + fname, _MAX_FNAME, NULL, 0) != 0) + { + success = false; + maperrno (); + } + else + { + wchar_t* temp = _wcsdup (tempFileName); + if (wcsnlen(drive, _MAX_DRIVE) == 0) + swprintf_s(tempFileName, MAX_PATH, L"%s\%s%s", + dir, fname, suffix); + else + swprintf_s(tempFileName, MAX_PATH, L"%s\%s\%s%s", + drive, dir, fname, suffix); + MoveFileW(temp, tempFileName); + free(temp); + } + + free(drive); + free(dir); + free(fname); + + return success; +} #endif diff --git a/libraries/base/cbits/inputReady.c b/libraries/base/cbits/inputReady.c index 0a84668689..cfbced914f 100644 --- a/libraries/base/cbits/inputReady.c +++ b/libraries/base/cbits/inputReady.c @@ -4,76 +4,265 @@ * hWaitForInput Runtime Support */ +/* FD_SETSIZE defaults to 64 on Windows, which makes even the most basic + * programs break that use select() on a socket FD. + * Thus we raise it here (before any #include of network-related headers) + * to 1024 so that at least those programs would work that would work on + * Linux if that used select() (luckily it uses poll() by now). + * See https://ghc.haskell.org/trac/ghc/ticket/13497#comment:23 + * The real solution would be to remove all uses of select() + * on Windows, too, and use IO Completion Ports instead. + * Note that on Windows, one can simply define FD_SETSIZE to the desired + * size before including Winsock2.h, as described here: + * https://msdn.microsoft.com/en-us/library/windows/desktop/ms740141(v=vs.85).aspx + */ +#if defined(_WIN32) +#define FD_SETSIZE 1024 +#endif + /* select and supporting types is not Posix */ /* #include "PosixSource.h" */ +#include <limits.h> +#include <stdbool.h> #include "HsBase.h" +#include "Rts.h" #if !defined(_WIN32) #include <poll.h> -#include <sys/time.h> +#endif + +/* + * Returns a timeout suitable to be passed into poll(). + * + * If `remaining` contains a fractional milliseconds part that cannot be passed + * to poll(), this function will return the next larger value that can, so + * that the timeout passed to poll() would always be `>= remaining`. + * + * If `infinite`, `remaining` is ignored. + */ +static inline +int +compute_poll_timeout(bool infinite, Time remaining) +{ + if (infinite) return -1; + + if (remaining < 0) return 0; + + if (remaining > MSToTime(INT_MAX)) return INT_MAX; + + int remaining_ms = TimeToMS(remaining); + + if (remaining != MSToTime(remaining_ms)) return remaining_ms + 1; + + return remaining_ms; +} + +#if defined(_WIN32) +/* + * Returns a timeout suitable to be passed into select() on Windows. + * + * The given `remaining_tv` serves as a storage for the timeout + * when needed, but callers should use the returned value instead + * as it will not be filled in all cases. + * + * If `infinite`, `remaining` is ignored and `remaining_tv` not touched + * (and may be passed as NULL in that case). + */ +static inline +struct timeval * +compute_windows_select_timeout(bool infinite, Time remaining, + /* out */ struct timeval * remaining_tv) +{ + if (infinite) { + return NULL; + } + + ASSERT(remaining_tv); + + if (remaining < 0) { + remaining_tv->tv_sec = 0; + remaining_tv->tv_usec = 0; + } else if (remaining > MSToTime(LONG_MAX)) { + remaining_tv->tv_sec = LONG_MAX; + remaining_tv->tv_usec = LONG_MAX; + } else { + remaining_tv->tv_sec = TimeToMS(remaining) / 1000; + remaining_tv->tv_usec = TimeToUS(remaining) % 1000000; + } + + return remaining_tv; +} + +/* + * Returns a timeout suitable to be passed into WaitForSingleObject() on + * Windows. + * + * If `remaining` contains a fractional milliseconds part that cannot be passed + * to WaitForSingleObject(), this function will return the next larger value + * that can, so that the timeout passed to WaitForSingleObject() would + * always be `>= remaining`. + * + * If `infinite`, `remaining` is ignored. + */ +static inline +DWORD +compute_WaitForSingleObject_timeout(bool infinite, Time remaining) +{ + // WaitForSingleObject() has the fascinating delicacy behaviour + // that it waits indefinitely if the `DWORD dwMilliseconds` + // is set to 0xFFFFFFFF (the maximum DWORD value), which is + // 4294967295 seconds == ~49.71 days + // (the Windows API calls this constant INFINITE...). + // https://msdn.microsoft.com/en-us/library/windows/desktop/ms687032(v=vs.85).aspx + // + // We ensure that if accidentally `remaining == 4294967295`, it does + // NOT wait forever, by never passing that value to + // WaitForSingleObject() (so, never returning it from this function), + // unless `infinite`. + + if (infinite) return INFINITE; + + if (remaining < 0) return 0; + + if (remaining >= MSToTime(INFINITE)) return INFINITE - 1; + + DWORD remaining_ms = TimeToMS(remaining); + + if (remaining != MSToTime(remaining_ms)) return remaining_ms + 1; + + return remaining_ms; +} #endif /* * inputReady(fd) checks to see whether input is available on the file * descriptor 'fd' within 'msecs' milliseconds (or indefinitely if 'msecs' is * negative). "Input is available" is defined as 'can I safely read at least a - * *character* from this file object without blocking?' + * *character* from this file object without blocking?' (this does not work + * reliably on Linux when the fd is a not-O_NONBLOCK socket, so if you pass + * socket fds to this function, ensure they have O_NONBLOCK; + * see `man 2 poll` and `man 2 select`, and + * https://ghc.haskell.org/trac/ghc/ticket/13497#comment:26). + * + * This function blocks until either `msecs` have passed, or input is + * available. + * + * Returns: + * 1 => Input ready, 0 => not ready, -1 => error + * On error, sets `errno`. */ int -fdReady(int fd, int write, int msecs, int isSock) +fdReady(int fd, bool write, int64_t msecs, bool isSock) { + bool infinite = msecs < 0; -#if !defined(_WIN32) - struct pollfd fds[1]; - - // if we need to track the then record the current time in case we are + // if we need to track the time then record the end time in case we are // interrupted. - struct timeval tv0; + Time endTime = 0; if (msecs > 0) { - if (gettimeofday(&tv0, NULL) != 0) { - fprintf(stderr, "fdReady: gettimeofday failed: %s\n", - strerror(errno)); - abort(); - } + endTime = getProcessElapsedTime() + MSToTime(msecs); } + // Invariant of all code below: + // If `infinite`, then `remaining` and `endTime` are never used. + + Time remaining = MSToTime(msecs); + + // Note [Guaranteed syscall time spent] + // + // The implementation ensures that if fdReady() is called with N `msecs`, + // it will not return before an FD-polling syscall *returns* + // with `endTime` having passed. + // + // Consider the following scenario: + // + // 1 int ready = poll(..., msecs); + // 2 if (EINTR happened) { + // 3 Time now = getProcessElapsedTime(); + // 4 if (now >= endTime) return 0; + // 5 remaining = endTime - now; + // 6 } + // + // If `msecs` is 5 seconds, but in line 1 poll() returns with EINTR after + // only 10 ms due to a signal, and if at line 2 the machine starts + // swapping for 10 seconds, then line 4 will return that there's no + // data ready, even though by now there may be data ready now, and we have + // not actually checked after up to `msecs` = 5 seconds whether there's + // data ready as promised. + // + // Why is this important? + // Assume you call the pizza man to bring you a pizza. + // You arrange that you won't pay if he doesn't ring your doorbell + // in under 10 minutes delivery time. + // At 9:58 fdReady() gets woken by EINTR and then your computer swaps + // for 3 seconds. + // At 9:59 the pizza man rings. + // At 10:01 fdReady() will incorrectly tell you that the pizza man hasn't + // rung within 10 minutes, when in fact he has. + // + // If the pizza man is some watchdog service or dead man's switch program, + // this is problematic. + // + // To avoid it, we ensure that in the timeline diagram: + // + // endTime + // | + // time ----+----------+-------+----> + // | | + // syscall starts syscall returns + // + // the "syscall returns" event is always >= the "endTime" time. + // + // In the code this means that we never check whether to `return 0` + // after a `Time now = getProcessElapsedTime();`, and instead always + // let the branch marked [we waited the full msecs] handle that case. + +#if !defined(_WIN32) + struct pollfd fds[1]; + fds[0].fd = fd; fds[0].events = write ? POLLOUT : POLLIN; fds[0].revents = 0; - int res; - while ((res = poll(fds, 1, msecs)) < 0) { - if (errno == EINTR) { - if (msecs > 0) { - struct timeval tv; - if (gettimeofday(&tv, NULL) != 0) { - fprintf(stderr, "fdReady: gettimeofday failed: %s\n", - strerror(errno)); - abort(); - } + // The code below tries to make as few syscalls as possible; + // in particular, it eschews getProcessElapsedTime() calls + // when `infinite` or `msecs == 0`. - int elapsed = 1000 * (tv.tv_sec - tv0.tv_sec) - + (tv.tv_usec - tv0.tv_usec) / 1000; - msecs -= elapsed; - if (msecs <= 0) return 0; - tv0 = tv; - } - } else { - return (-1); + // We need to wait in a loop because poll() accepts `int` but `msecs` is + // `int64_t`, and because signals can interrupt it. + + while (true) { + int res = poll(fds, 1, compute_poll_timeout(infinite, remaining)); + + if (res < 0 && errno != EINTR) + return (-1); // real error; errno is preserved + + if (res > 0) + return 1; // FD has new data + + if (res == 0 && !infinite && remaining <= MSToTime(INT_MAX)) + return 0; // FD has no new data and [we waited the full msecs] + + // Non-exit cases + CHECK( ( res < 0 && errno == EINTR ) || // EINTR happened + // need to wait more + ( res == 0 && (infinite || + remaining > MSToTime(INT_MAX)) ) ); + + if (!infinite) { + Time now = getProcessElapsedTime(); + remaining = endTime - now; } } - // res is the number of FDs with events - return (res > 0); - #else if (isSock) { - int maxfd, ready; + int maxfd; fd_set rfd, wfd; - struct timeval tv; + struct timeval remaining_tv; + if ((fd >= (int)FD_SETSIZE) || (fd < 0)) { - fprintf(stderr, "fdReady: fd is too big"); - abort(); + barf("fdReady: fd is too big: %d but FD_SETSIZE is %d", fd, (int)FD_SETSIZE); } FD_ZERO(&rfd); FD_ZERO(&wfd); @@ -87,52 +276,110 @@ fdReady(int fd, int write, int msecs, int isSock) * (maxfd-1) */ maxfd = fd + 1; - tv.tv_sec = msecs / 1000; - tv.tv_usec = (msecs % 1000) * 1000; - while ((ready = select(maxfd, &rfd, &wfd, NULL, &tv)) < 0 ) { - if (errno != EINTR ) { - return -1; + // We need to wait in a loop because the `timeval` `tv_*` members + // passed into select() accept are `long` (which is 32 bits on 32-bit + // and 64-bit Windows), but `msecs` is `int64_t`, and because signals + // can interrupt it. + // https://msdn.microsoft.com/en-us/library/windows/desktop/ms740560(v=vs.85).aspx + // https://stackoverflow.com/questions/384502/what-is-the-bit-size-of-long-on-64-bit-windows#384672 + + while (true) { + int res = select(maxfd, &rfd, &wfd, NULL, + compute_windows_select_timeout(infinite, remaining, + &remaining_tv)); + + if (res < 0 && errno != EINTR) + return (-1); // real error; errno is preserved + + if (res > 0) + return 1; // FD has new data + + if (res == 0 && !infinite && remaining <= MSToTime(INT_MAX)) + return 0; // FD has no new data and [we waited the full msecs] + + // Non-exit cases + CHECK( ( res < 0 && errno == EINTR ) || // EINTR happened + // need to wait more + ( res == 0 && (infinite || + remaining > MSToTime(INT_MAX)) ) ); + + if (!infinite) { + Time now = getProcessElapsedTime(); + remaining = endTime - now; } } - /* 1 => Input ready, 0 => not ready, -1 => error */ - return (ready); - } - else { + } else { DWORD rc; HANDLE hFile = (HANDLE)_get_osfhandle(fd); - DWORD avail; + DWORD avail = 0; switch (GetFileType(hFile)) { - case FILE_TYPE_CHAR: - { - INPUT_RECORD buf[1]; - DWORD count; + case FILE_TYPE_CHAR: + { + INPUT_RECORD buf[1]; + DWORD count; - // nightmare. A Console Handle will appear to be ready - // (WaitForSingleObject() returned WAIT_OBJECT_0) when - // it has events in its input buffer, but these events might - // not be keyboard events, so when we read from the Handle the - // read() will block. So here we try to discard non-keyboard - // events from a console handle's input buffer and then try - // the WaitForSingleObject() again. + // nightmare. A Console Handle will appear to be ready + // (WaitForSingleObject() returned WAIT_OBJECT_0) when + // it has events in its input buffer, but these events might + // not be keyboard events, so when we read from the Handle the + // read() will block. So here we try to discard non-keyboard + // events from a console handle's input buffer and then try + // the WaitForSingleObject() again. - while (1) // keep trying until we find a real key event + while (1) // keep trying until we find a real key event { - rc = WaitForSingleObject( hFile, msecs ); + rc = WaitForSingleObject( + hFile, + compute_WaitForSingleObject_timeout(infinite, remaining)); switch (rc) { - case WAIT_TIMEOUT: return 0; - case WAIT_OBJECT_0: break; - default: /* WAIT_FAILED */ maperrno(); return -1; + case WAIT_TIMEOUT: + // We need to use < here because if remaining + // was INFINITE, we'll have waited for + // `INFINITE - 1` as per + // compute_WaitForSingleObject_timeout(), + // so that's 1 ms too little. Wait again then. + if (!infinite && remaining < MSToTime(INFINITE)) + return 0; // real complete or [we waited the full msecs] + goto waitAgain; + case WAIT_OBJECT_0: break; + default: /* WAIT_FAILED */ maperrno(); return -1; } while (1) // discard non-key events + { + BOOL success = PeekConsoleInput(hFile, buf, 1, &count); + // printf("peek, rc=%d, count=%d, type=%d\n", rc, count, buf[0].EventType); + if (!success) { + rc = GetLastError(); + if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) { + return 1; + } else { + maperrno(); + return -1; + } + } + + if (count == 0) break; // no more events => wait again + + // discard console events that are not "key down", because + // these will also be discarded by ReadFile(). + if (buf[0].EventType == KEY_EVENT && + buf[0].Event.KeyEvent.bKeyDown && + buf[0].Event.KeyEvent.uChar.AsciiChar != '\0') + { + // it's a proper keypress: + return 1; + } + else { - rc = PeekConsoleInput(hFile, buf, 1, &count); - // printf("peek, rc=%d, count=%d, type=%d\n", rc, count, buf[0].EventType); - if (rc == 0) { + // it's a non-key event, a key up event, or a + // non-character key (e.g. shift). discard it. + BOOL success = ReadConsoleInput(hFile, buf, 1, &count); + if (!success) { rc = GetLastError(); if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) { return 1; @@ -141,75 +388,92 @@ fdReady(int fd, int write, int msecs, int isSock) return -1; } } + } + } - if (count == 0) break; // no more events => wait again + Time now; + waitAgain: + now = getProcessElapsedTime(); + remaining = endTime - now; + } + } - // discard console events that are not "key down", because - // these will also be discarded by ReadFile(). - if (buf[0].EventType == KEY_EVENT && - buf[0].Event.KeyEvent.bKeyDown && - buf[0].Event.KeyEvent.uChar.AsciiChar != '\0') - { - // it's a proper keypress: - return 1; - } - else - { - // it's a non-key event, a key up event, or a - // non-character key (e.g. shift). discard it. - rc = ReadConsoleInput(hFile, buf, 1, &count); - if (rc == 0) { - rc = GetLastError(); - if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) { - return 1; - } else { - maperrno(); - return -1; - } - } - } + case FILE_TYPE_DISK: + // assume that disk files are always ready: + return 1; + + case FILE_TYPE_PIPE: { + // WaitForMultipleObjects() doesn't work for pipes (it + // always returns WAIT_OBJECT_0 even when no data is + // available). If the HANDLE is a pipe, therefore, we try + // PeekNamedPipe(): + // + // PeekNamedPipe() does not block, so if it returns that + // there is no new data, we have to sleep and try again. + + // Because PeekNamedPipe() doesn't block, we have to track + // manually whether we've called it one more time after `endTime` + // to fulfill Note [Guaranteed syscall time spent]. + bool endTimeReached = false; + while (avail == 0) { + BOOL success = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL ); + if (success) { + if (avail != 0) { + return 1; + } else { // no new data + if (infinite) { + Sleep(1); // 1 millisecond (smallest possible time on Windows) + continue; + } else if (msecs == 0) { + return 0; + } else { + if (endTimeReached) return 0; // [we waited the full msecs] + Time now = getProcessElapsedTime(); + if (now >= endTime) endTimeReached = true; + Sleep(1); // 1 millisecond (smallest possible time on Windows) + continue; } + } + } else { + rc = GetLastError(); + if (rc == ERROR_BROKEN_PIPE) { + return 1; // this is probably what we want + } + if (rc != ERROR_INVALID_HANDLE && rc != ERROR_INVALID_FUNCTION) { + maperrno(); + return -1; + } } - } - - case FILE_TYPE_DISK: - // assume that disk files are always ready: - return 1; - - case FILE_TYPE_PIPE: - // WaitForMultipleObjects() doesn't work for pipes (it - // always returns WAIT_OBJECT_0 even when no data is - // available). If the HANDLE is a pipe, therefore, we try - // PeekNamedPipe: - // - rc = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL ); - if (rc != 0) { - if (avail != 0) { - return 1; - } else { - return 0; - } - } else { - rc = GetLastError(); - if (rc == ERROR_BROKEN_PIPE) { - return 1; // this is probably what we want - } - if (rc != ERROR_INVALID_HANDLE && rc != ERROR_INVALID_FUNCTION) { - maperrno(); - return -1; } } /* PeekNamedPipe didn't work - fall through to the general case */ - default: - rc = WaitForSingleObject( hFile, msecs ); + default: + while (true) { + rc = WaitForSingleObject( + hFile, + compute_WaitForSingleObject_timeout(infinite, remaining)); - /* 1 => Input ready, 0 => not ready, -1 => error */ - switch (rc) { - case WAIT_TIMEOUT: return 0; - case WAIT_OBJECT_0: return 1; - default: /* WAIT_FAILED */ maperrno(); return -1; - } + switch (rc) { + case WAIT_TIMEOUT: + // We need to use < here because if remaining + // was INFINITE, we'll have waited for + // `INFINITE - 1` as per + // compute_WaitForSingleObject_timeout(), + // so that's 1 ms too little. Wait again then. + if (!infinite && remaining < MSToTime(INFINITE)) + return 0; // real complete or [we waited the full msecs] + break; + case WAIT_OBJECT_0: return 1; + default: /* WAIT_FAILED */ maperrno(); return -1; + } + + // EINTR or a >(INFINITE - 1) timeout completed + if (!infinite) { + Time now = getProcessElapsedTime(); + remaining = endTime - now; + } + } } } #endif diff --git a/libraries/base/cbits/primFloat.c b/libraries/base/cbits/primFloat.c index f0746775d3..dde5d06503 100644 --- a/libraries/base/cbits/primFloat.c +++ b/libraries/base/cbits/primFloat.c @@ -315,7 +315,7 @@ rintFloat(HsFloat f) mant += 2*half; if (mant == FLT_POWER2) { - /* next power of 2, increase exponent an set mantissa to 0 */ + /* next power of 2, increase exponent and set mantissa to 0 */ u.ieee.mantissa = 0; u.ieee.exponent += 1; return u.f; diff --git a/libraries/base/cbits/ubconfc b/libraries/base/cbits/ubconfc index 509049d664..4d325866bb 100644 --- a/libraries/base/cbits/ubconfc +++ b/libraries/base/cbits/ubconfc @@ -322,7 +322,6 @@ unipred(u_iswalpha,(GENCAT_LL|GENCAT_LU|GENCAT_LT|GENCAT_LM|GENCAT_LO)) unipred(u_iswdigit,GENCAT_ND) unipred(u_iswalnum,(GENCAT_LT|GENCAT_LU|GENCAT_LL|GENCAT_LM|GENCAT_LO| - GENCAT_MC|GENCAT_ME|GENCAT_MN| GENCAT_NO|GENCAT_ND|GENCAT_NL)) #define caseconv(p,to) \\ @@ -341,5 +340,4 @@ HsInt u_gencat(HsInt c) { return getrule(allchars,NUM_BLOCKS,c)->catnumber; } - EOF diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 0cfd9c1ba8..8964edd7ff 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -1,17 +1,151 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) -## 4.11.0.0 *TBA* +## 4.12.0.0 *TBA* + * Bundled with GHC *TBA* + + * Support the characters from recent versions of Unicode (up to v. 12) in + literals (#5518). + +## 4.12.0.0 *TBA* * Bundled with GHC *TBA* + * The STM invariant-checking mechanism (`always` and `alwaysSucceeds`), which + was deprecated in GHC 8.4, has been removed (as proposed in + <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0011-deprecate-stm-invariants.rst>). + This is a bit earlier than proposed in the deprecation pragma included in + GHC 8.4, but due to community feedback we decided to move ahead with the + early removal. + + Existing users are encouraged to encapsulate their STM operations in safe + abstractions which can perform the invariant checking without help from the + runtime system. + + * Add a new module `GHC.ResponseFile` (previously defined in the `haddock` + package). (#13896) + + * Move the module `Data.Functor.Contravariant` from the + `contravariant` package to `base`. + + * `($!)` is now representation-polymorphic like `($)`. + + * Add `Applicative` (for `K1`), `Semigroup` and `Monoid` instances in + `GHC.Generics`. (#14849) + + * `asinh` for `Float` and `Double` is now numerically stable in the face of + non-small negative arguments and enormous arguments of either sign. (#14927) + + * `Numeric.showEFloat (Just 0)` now respects the user's requested precision. + (#15115) + + * `Data.Monoid.Alt` now has `Foldable` and `Traversable` instances. (#15099) + + * `Data.Monoid.Ap` has been introduced + + * `Control.Exception.throw` is now levity polymorphic. (#15180) + + * `Data.Ord.Down` now has a number of new instances. These include: + `MonadFix`, `MonadZip`, `Data`, `Foldable`, `Traversable`, `Eq1`, `Ord1`, + `Read1`, `Show1`, `Generic`, `Generic1`. (#15098) + + +## 4.11.1.0 *TBA* + * Bundled with GHC 8.4.2 + + * Add the `readFieldHash` function to `GHC.Read` which behaves like + `readField`, but for a field that ends with a `#` symbol (#14918). + +## 4.11.0.0 *TBA* + * Bundled with GHC 8.4.1 + + * `System.IO.openTempFile` is now thread-safe on Windows. + + * Deprecated `GHC.Stats.GCStats` interface has been removed. + + * Add `showHFloat` to `Numeric` + + * Add `Div`, `Mod`, and `Log2` functions on type-level naturals + in `GHC.TypeLits`. + * Add `Alternative` instance for `ZipList` (#13520) * Add instances `Num`, `Functor`, `Applicative`, `Monad`, `Semigroup` and `Monoid` for `Data.Ord.Down` (#13097). + * Add `Semigroup` instance for `EventLifetime`. + + * Make `Semigroup` a superclass of `Monoid`; + export `Semigroup((<>))` from `Prelude`; remove `Monoid` reexport + from `Data.Semigroup` (#14191). + + * Generalise `instance Monoid a => Monoid (Maybe a)` to + `instance Semigroup a => Monoid (Maybe a)`. + * Add `infixl 9 !!` declaration for `Data.List.NonEmpty.!!` -## 4.10.0.0 *April 2017* - * Bundled with GHC *TBA* + * Add `<&>` operator to `Data.Functor` (#14029) + + * Remove the deprecated `Typeable{1..7}` type synonyms (#14047) + + * Make `Data.Type.Equality.==` a closed type family. It now works for all + kinds out of the box. Any modules that previously declared instances of this + family will need to remove them. Whereas the previous definition was somewhat + ad hoc, the behavior is now completely uniform. As a result, some applications + that used to reduce no longer do, and conversely. Most notably, `(==)` no + longer treats the `*`, `j -> k`, or `()` kinds specially; equality is + tested structurally in all cases. + + * Add instances `Semigroup` and `Monoid` for `Control.Monad.ST` (#14107). + + * The `Read` instances for `Proxy`, `Coercion`, `(:~:)`, `(:~~:)`, and `U1` + now ignore the parsing precedence. The effect of this is that `read` will + be able to successfully parse more strings containing `"Proxy"` _et al._ + without surrounding parentheses (e.g., `"Thing Proxy"`) (#12874). + + * Add `iterate'`, a strict version of `iterate`, to `Data.List` + and `Data.OldList` (#3474) + + * Add `Data` instances for `IntPtr` and `WordPtr` (#13115) + + * Add missing `MonadFail` instance for `Control.Monad.Strict.ST.ST` + + * Make `zipWith` and `zipWith3` inlinable (#14224) + + * `Type.Reflection.App` now matches on function types (fixes #14236) + + * `Type.Reflection.withTypeable` is now polymorphic in the `RuntimeRep` of + its result. + + * Add `installSEHHandlers` to `MiscFlags` in `GHC.RTS.Flags` to determine if + exception handling is enabled. + + * The deprecated functions `isEmptyChan` and `unGetChan` in + `Control.Concurrent.Chan` have been removed (#13561). + + * Add `generateCrashDumpFile` to `MiscFlags` in `GHC.RTS.Flags` to determine + if a core dump will be generated on crashes. + + * Add `generateStackTrace` to `MiscFlags` in `GHC.RTS.Flags` to determine if + stack traces will be generated on unhandled exceptions by the RTS. + + * `getExecutablePath` now resolves symlinks on Windows (#14483) + + * Deprecated STM invariant checking primitives (`checkInv`, `always`, and + `alwaysSucceeds`) in `GHC.Conc.Sync` (#14324). + + * Add a `FixIOException` data type to `Control.Exception.Base`, and change + `fixIO` to throw that instead of a `BlockedIndefinitelyOnMVar` exception + (#14356). + +## 4.10.1.0 *November 2017* + * Bundled with GHC 8.2.2 + + * The file locking primitives provided by `GHC.IO.Handle` now use + Linux open file descriptor locking if available. + + * Fixed bottoming definition of `clearBit` for `Natural` + +## 4.10.0.0 *July 2017* + * Bundled with GHC 8.2.1 * `Data.Type.Bool.Not` given a type family dependency (#12057). @@ -202,6 +336,9 @@ * New `Control.Exception.TypeError` datatype, which is thrown when an expression fails to typecheck when run using `-fdefer-type-errors` (#10284) + * The `bitSize` method of `Data.Bits.Bits` now has a (partial!) + default implementation based on `bitSizeMaybe`. (#12970) + ### New instances * `Alt`, `Dual`, `First`, `Last`, `Product`, and `Sum` now have `Data`, diff --git a/libraries/base/configure.ac b/libraries/base/configure.ac index af041a7ad5..a141a25a90 100644 --- a/libraries/base/configure.ac +++ b/libraries/base/configure.ac @@ -69,7 +69,12 @@ if test "$ac_cv_header_poll_h" = yes && test "$ac_cv_func_poll" = yes; then AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.]) fi -#flock +# Linux open file descriptor locks +AC_CHECK_DECL([F_OFD_SETLK], [ + AC_DEFINE([HAVE_OFD_LOCKING], [1], [Define if you have open file descriptor lock support.]) +]) + +# flock AC_CHECK_FUNCS([flock]) if test "$ac_cv_header_sys_file_h" = yes && test "$ac_cv_func_flock" = yes; then AC_DEFINE([HAVE_FLOCK], [1], [Define if you have flock support.]) @@ -229,10 +234,10 @@ AS_IF([test "x$with_libcharset" != xno], fi # Hack - md5.h needs HsFFI.h. Is there a better way to do this? -CFLAGS="-I../../includes $CFLAGS" +CFLAGS="-I../.. -I../../../../includes $CFLAGS" dnl Calling AC_CHECK_TYPE(T) makes AC_CHECK_SIZEOF(T) abort on failure dnl instead of considering sizeof(T) as 0. -AC_CHECK_TYPE([struct MD5Context], [], [], [#include "include/md5.h"]) +AC_CHECK_TYPE([struct MD5Context], [], [AC_MSG_ERROR([internal error])], [#include "include/md5.h"]) AC_CHECK_SIZEOF([struct MD5Context], [], [#include "include/md5.h"]) AC_SUBST(EXTRA_LIBS) diff --git a/libraries/base/include/HsBase.h b/libraries/base/include/HsBase.h index 0fe5805a64..d5884473ca 100644 --- a/libraries/base/include/HsBase.h +++ b/libraries/base/include/HsBase.h @@ -24,6 +24,7 @@ #include "HsFFI.h" +#include <stdbool.h> #include <stdio.h> #include <stdlib.h> #include <math.h> @@ -152,7 +153,7 @@ extern HsWord64 getMonotonicUSec(void); #endif /* in inputReady.c */ -extern int fdReady(int fd, int write, int msecs, int isSock); +extern int fdReady(int fd, bool write, int64_t msecs, bool isSock); /* ----------------------------------------------------------------------------- INLINE functions. @@ -288,7 +289,7 @@ __hscore_ftruncate( int fd, off_t where ) return _chsize(fd,where); #else // ToDo: we should use _chsize_s() on Windows which allows a 64-bit -// offset, but it doesn't seem to be available from mingw at this time +// offset, but it doesn't seem to be available from mingw at this time // --SDM (01/2008) #error at least ftruncate or _chsize functions are required to build #endif @@ -519,13 +520,25 @@ extern void* __hscore_get_saved_termios(int fd); extern void __hscore_set_saved_termios(int fd, void* ts); #if defined(_WIN32) +/* Defined in fs.c. */ +extern int __hs_swopen (const wchar_t* filename, int oflag, int shflag, + int pmode); + INLINE int __hscore_open(wchar_t *file, int how, mode_t mode) { + int result = -1; if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND)) - return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); + result = __hs_swopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); // _O_NOINHERIT: see #2650 else - return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); + result = __hs_swopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); // _O_NOINHERIT: see #2650 + + /* This call is very important, otherwise the I/O system will not propagate + the correct error for why it failed. */ + if (result == -1) + maperrno (); + + return result; } #else INLINE int __hscore_open(char *file, int how, mode_t mode) { diff --git a/libraries/base/tests/CatEntail.hs b/libraries/base/tests/CatEntail.hs index c980a2db73..30023ad5b8 100644 --- a/libraries/base/tests/CatEntail.hs +++ b/libraries/base/tests/CatEntail.hs @@ -2,11 +2,11 @@ {-# LANGUAGE TypeOperators, KindSignatures #-} module CatEntail where import Prelude hiding (id, (.)) -import GHC.Exts (Constraint) +import Data.Kind import Control.Category -- One dictionary to rule them all. -data Dict :: Constraint -> * where +data Dict :: Constraint -> Type where Dict :: ctx => Dict ctx -- Entailment. diff --git a/libraries/base/tests/IO/T2122.hs b/libraries/base/tests/IO/T2122.hs index 9a8badc216..488d2434bc 100644 --- a/libraries/base/tests/IO/T2122.hs +++ b/libraries/base/tests/IO/T2122.hs @@ -51,9 +51,9 @@ test causeFailure = -- probably because openFd does not try to lock the file test2 :: Bool -> IO () test2 causeFailure = - do fd1 <- openFd fp ReadOnly Nothing defaultFileFlags `catchIOError` (\e -> error ("openFile 1: " ++ show e)) + do fd1 <- openFd fp ReadOnly defaultFileFlags `catchIOError` (\e -> error ("openFile 1: " ++ show e)) when causeFailure $ do - fd2 <- openFd fp ReadOnly Nothing defaultFileFlags `catchIOError` (\e -> error ("openFile 2: " ++ show e)) + fd2 <- openFd fp ReadOnly defaultFileFlags `catchIOError` (\e -> error ("openFile 2: " ++ show e)) closeFd fd2 closeFd fd1 removeFile fp diff --git a/libraries/base/tests/IO/all.T b/libraries/base/tests/IO/all.T index 0de530bc2c..dba0e5e3d7 100644 --- a/libraries/base/tests/IO/all.T +++ b/libraries/base/tests/IO/all.T @@ -34,7 +34,8 @@ test('hReady001', normal, compile_and_run, ['-cpp']) # data to read. It relies on piping input from 'sleep 1', which doesn't # work for the 'ghci' way because in that case we already pipe input from # a script, so hence omit_ways(['ghci']) -test('hReady002', [cmd_prefix('sleep 1 |'), omit_ways(['ghci'])], +test('hReady002', [cmd_prefix('sleep 1 |'), omit_ways(['ghci']), + multi_cpu_race], compile_and_run, ['']) test('hSeek001', normal, compile_and_run, ['']) @@ -87,8 +88,10 @@ test('hDuplicateTo001', [], compile_and_run, ['']) test('countReaders001', [], compile_and_run, ['']) -test('concio001', normal, run_command, ['$MAKE -s --no-print-directory test.concio001']) -test('concio001.thr', extra_files(['concio001.hs']), run_command, ['$MAKE -s --no-print-directory test.concio001.thr']) +test('concio001', [normal, multi_cpu_race], + run_command, ['$MAKE -s --no-print-directory test.concio001']) +test('concio001.thr', [extra_files(['concio001.hs']), multi_cpu_race], + run_command, ['$MAKE -s --no-print-directory test.concio001.thr']) test('concio002', reqlib('process'), compile_and_run, ['']) diff --git a/libraries/base/tests/Numeric/all.T b/libraries/base/tests/Numeric/all.T index a0a9d68382..c4c9bb4646 100644 --- a/libraries/base/tests/Numeric/all.T +++ b/libraries/base/tests/Numeric/all.T @@ -13,7 +13,9 @@ if config.arch == 'i386': else: opts = '' test('num009', [ when(fast(), skip) + , when(wordsize(32), expect_broken(15062)) , when(platform('i386-apple-darwin'), expect_broken(2370)) + , when(platform('powerpc64le-unknown-linux'), expect_broken(13634)) , when(opsys('mingw32'), omit_ways(['ghci'])) ], # We get different results at 1e20 on x86/Windows, so there is # a special output file for that. I (SDM) don't think these are @@ -25,3 +27,4 @@ test('num010', when(platform('i386-apple-darwin'), expect_broken_for(7043, 'ghci')), compile_and_run, ['']) +test('sqrt', normal, compile_and_run, ['']) diff --git a/libraries/base/tests/Numeric/num008.stdout b/libraries/base/tests/Numeric/num008.stdout index 5086442f0f..116998cc80 100644 --- a/libraries/base/tests/Numeric/num008.stdout +++ b/libraries/base/tests/Numeric/num008.stdout @@ -6,14 +6,14 @@ 4.2000000e-2 1.8217369e0 1.8217369e-300 -0.0e0 -4.2e2 -4.2e1 -4.2e0 -4.2e-1 -4.2e-2 -1.8e0 -1.8e-300 +0e0 +4e2 +4e1 +4e0 +4e-1 +4e-2 +2e0 +2e-300 0.0e0 4.2e2 4.2e1 @@ -59,9 +59,9 @@ 42 4 0 -4.2e-2 +4e-2 2 -1.8e-300 +2e-300 0.0 420.0 42.0 @@ -79,14 +79,14 @@ 4.2000000e-2 1.8217369e0 0.0000000e0 -0.0e0 -4.2e2 -4.2e1 -4.2e0 -4.2e-1 -4.2e-2 -1.8e0 -0.0e0 +0e0 +4e2 +4e1 +4e0 +4e-1 +4e-2 +2e0 +0e0 0.0e0 4.2e2 4.2e1 @@ -132,7 +132,7 @@ 42 4 0 -4.2e-2 +4e-2 2 0 0.0 @@ -144,5 +144,5 @@ 1.8217369 0.0 -[0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,1.8217369e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8,1.8e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369128763983,1.821736912876398e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.0,0.0,0.0,2.0,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369128763983,1.821736912876398e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,1.8217369e-300,0.0,420.0,42.0,4.0,0.0,4.2e-2,2.0,1.8e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369128763983,1.821736912876398e-300] -[0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.0,0.0,0.0,2.0,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.0,0.0,4.2e-2,2.0,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0] +[0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,1.8217369e-300,0.0,400.0,40.0,4.0,0.4,4.0e-2,2.0,2.0e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369128763983,1.821736912876398e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.0,0.0,0.0,2.0,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369128763983,1.821736912876398e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,1.8217369e-300,0.0,420.0,42.0,4.0,0.0,4.0e-2,2.0,2.0e-300,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369128763983,1.821736912876398e-300] +[0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,400.0,40.0,4.0,0.4,4.0e-2,2.0,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.0,0.0,0.0,2.0,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0,0.0,420.0,42.0,4.0,0.0,4.0e-2,2.0,0.0,0.0,420.0,42.0,4.2,0.42,4.2e-2,1.8217369,0.0] diff --git a/libraries/base/tests/Numeric/sqrt.hs b/libraries/base/tests/Numeric/sqrt.hs new file mode 100644 index 0000000000..a58875ae68 --- /dev/null +++ b/libraries/base/tests/Numeric/sqrt.hs @@ -0,0 +1,3 @@ +main = do + print (sqrt (-7 :: Double)) + print (sqrt (-7 :: Float)) diff --git a/libraries/base/tests/Numeric/sqrt.stdout b/libraries/base/tests/Numeric/sqrt.stdout new file mode 100644 index 0000000000..913b330b26 --- /dev/null +++ b/libraries/base/tests/Numeric/sqrt.stdout @@ -0,0 +1,2 @@ +NaN +NaN diff --git a/libraries/base/tests/System/all.T b/libraries/base/tests/System/all.T index a6894fa95a..3cadf3534f 100644 --- a/libraries/base/tests/System/all.T +++ b/libraries/base/tests/System/all.T @@ -4,6 +4,6 @@ test('getArgs001', normal, compile_and_run, ['']) test('getEnv001', normal, compile_and_run, ['']) test('T5930', normal, compile_and_run, ['']) -test('system001', when(opsys("mingw32"), expect_fail), \ +test('system001', when(opsys("mingw32"), skip), \ compile_and_run, ['']) test('Timeout001', normal, compile_and_run, ['']) diff --git a/libraries/base/tests/T10412.hs b/libraries/base/tests/T10412.hs new file mode 100644 index 0000000000..9657ef7d16 --- /dev/null +++ b/libraries/base/tests/T10412.hs @@ -0,0 +1,7 @@ +import Data.Char + +main :: IO () +main = do + print $ isMark '\768' + print $ isAlphaNum '\768' + print $ (isAlpha '\768', isNumber '\768') diff --git a/libraries/base/tests/T10412.stdout b/libraries/base/tests/T10412.stdout new file mode 100644 index 0000000000..a275e0ae27 --- /dev/null +++ b/libraries/base/tests/T10412.stdout @@ -0,0 +1,3 @@ +True +False +(False,False) diff --git a/libraries/base/tests/T12494.hs b/libraries/base/tests/T12494.hs new file mode 100644 index 0000000000..544f5ed908 --- /dev/null +++ b/libraries/base/tests/T12494.hs @@ -0,0 +1,36 @@ +import System.Environment.Blank + +main = do + let envVar = "AN_ENVIRONMENT_VARIABLE" + + valueBeforeSettingVariable <- getEnv envVar + print valueBeforeSettingVariable -- Nothing + + valueWithDefaultBeforeSetting <- getEnvDefault envVar "DEFAULT" + print valueWithDefaultBeforeSetting -- "DEFAULT" + + setEnv envVar "" False + + valueAfterSettingVariable <- getEnv envVar + print valueAfterSettingVariable -- Just "" + + valueWithDefaultAfterSetting <- getEnvDefault envVar "DEFAULT" + print valueWithDefaultAfterSetting -- "" + + valueFromGetEnvironment <- lookup envVar <$> getEnvironment + print valueFromGetEnvironment -- Just "" + + setEnv envVar "NO_OVERRIDE" False + + valueAfterSettingWithExistingValueAndOverrideFalse <- getEnv envVar + print valueAfterSettingWithExistingValueAndOverrideFalse -- Just "" + + setEnv envVar "OVERRIDE" True + + valueAfterSettingWithExistingValueAndOverrideTrue <- getEnv envVar + print valueAfterSettingWithExistingValueAndOverrideTrue -- Just "OVERRIDE" + + unsetEnv envVar + + valueAfterUnsettingVariable <- getEnv envVar + print valueAfterUnsettingVariable -- Nothing diff --git a/libraries/base/tests/T12494.stdout b/libraries/base/tests/T12494.stdout new file mode 100644 index 0000000000..a3b77cc271 --- /dev/null +++ b/libraries/base/tests/T12494.stdout @@ -0,0 +1,8 @@ +Nothing +"DEFAULT" +Just "" +"" +Just "" +Just "" +Just "OVERRIDE" +Nothing diff --git a/libraries/base/tests/T12874.hs b/libraries/base/tests/T12874.hs new file mode 100644 index 0000000000..cba7173121 --- /dev/null +++ b/libraries/base/tests/T12874.hs @@ -0,0 +1,9 @@ +module Main where + +import Data.Proxy + +main :: IO () +main = print (read "Thing Proxy" :: Thing (Proxy Int)) + +data Thing a = Thing a + deriving (Read,Show) diff --git a/libraries/base/tests/T12874.stdout b/libraries/base/tests/T12874.stdout new file mode 100644 index 0000000000..8a896600ac --- /dev/null +++ b/libraries/base/tests/T12874.stdout @@ -0,0 +1 @@ +Thing Proxy diff --git a/libraries/base/tests/T13167.hs b/libraries/base/tests/T13167.hs new file mode 100644 index 0000000000..e41104cde9 --- /dev/null +++ b/libraries/base/tests/T13167.hs @@ -0,0 +1,29 @@ +import Data.IORef +import Control.Monad +import Control.Exception +import Control.Concurrent.MVar +import System.Mem + +main :: IO () +main = do + run + run + run + run + m <- newEmptyMVar + quit m + performMajorGC + takeMVar m + +run :: IO () +run = do + ref <- newIORef () + void $ mkWeakIORef ref $ do + putStr "." + throwIO $ ErrorCall "failed" + +quit :: MVar () -> IO () +quit m = do + ref <- newIORef () + void $ mkWeakIORef ref $ do + putMVar m () diff --git a/libraries/base/tests/T13167.stdout b/libraries/base/tests/T13167.stdout new file mode 100644 index 0000000000..4918d25340 --- /dev/null +++ b/libraries/base/tests/T13167.stdout @@ -0,0 +1 @@ +....
diff --git a/libraries/base/tests/T13896.hs b/libraries/base/tests/T13896.hs new file mode 100644 index 0000000000..9e269a4a7c --- /dev/null +++ b/libraries/base/tests/T13896.hs @@ -0,0 +1,75 @@ +import GHC.ResponseFile + +assertEqual :: (Eq a, Show a) => a -> a -> IO () +assertEqual x y = if x == y + then return () + else error $ "assertEqual: " ++ show x ++ " /= " ++ show y + +-- Migrated from Haddock. + +-- The first two elements are +-- 1) a list of 'args' to encode and +-- 2) a single string of the encoded args +-- The 3rd element is just a description for the tests. +testStrs :: [(([String], String), String)] +testStrs = + [ ((["a simple command line"], + "a\\ simple\\ command\\ line\n"), + "the white-space, end with newline") + + , ((["arg 'foo' is single quoted"], + "arg\\ \\'foo\\'\\ is\\ single\\ quoted\n"), + "the single quotes as well") + + , ((["arg \"bar\" is double quoted"], + "arg\\ \\\"bar\\\"\\ is\\ double\\ quoted\n"), + "the double quotes as well" ) + + , ((["arg \"foo bar\" has embedded whitespace"], + "arg\\ \\\"foo\\ bar\\\"\\ has\\ embedded\\ whitespace\n"), + "the quote-embedded whitespace") + + , ((["arg 'Jack said \\'hi\\'' has single quotes"], + "arg\\ \\'Jack\\ said\\ \\\\\\'hi\\\\\\'\\'\\ has\\ single\\ quotes\n"), + "the escaped single quotes") + + , ((["arg 'Jack said \\\"hi\\\"' has double quotes"], + "arg\\ \\'Jack\\ said\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ double\\ quotes\n"), + "the escaped double quotes") + + , ((["arg 'Jack said\\r\\n\\t \\\"hi\\\"' has other whitespace"], + "arg\\ \\'Jack\\ said\\\\r\\\\n\\\\t\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ \ + \other\\ whitespace\n"), + "the other whitespace") + + , (([ "--prologue=.\\dist\\.\\haddock-prologue3239114604.txt" + , "--title=HaddockNewline-0.1.0.0: This has a\n\ + \newline yo." + , "-BC:\\Program Files\\Haskell Platform\\lib"], + "--prologue=.\\\\dist\\\\.\\\\haddock-prologue3239114604.txt\n\ + \--title=HaddockNewline-0.1.0.0:\\ This\\ has\\ a\\\n\ + \newline\\ yo.\n\ + \-BC:\\\\Program\\ Files\\\\Haskell\\ Platform\\\\lib\n"), + "an actual haddock response file snippet with embedded newlines") + ] + +main :: IO () +main = do + -- Test escapeArgs + mapM_ (\((ss1,s2),des) -> escapeArgs ss1 `assertEqual` s2) testStrs + + -- Test unescapeArgs + mapM_ (\((ss1,s2),des) -> unescapeArgs s2 `assertEqual` ss1) testStrs + + -- Given unescaped quotes, it should pass-through, + -- without escaping everything inside + + (filter (not . null) $ + unescapeArgs "this\\ is\\ 'not escape\\d \"inside\"'\\ yo\n") + `assertEqual` + ["this is not escaped \"inside\" yo"] + + (filter (not . null) $ + unescapeArgs "this\\ is\\ \"not escape\\d 'inside'\"\\ yo\n") + `assertEqual` + ["this is not escaped 'inside' yo"] diff --git a/libraries/base/tests/T14425.hs b/libraries/base/tests/T14425.hs new file mode 100644 index 0000000000..0a935693d3 --- /dev/null +++ b/libraries/base/tests/T14425.hs @@ -0,0 +1,5 @@ +import Data.Ratio + +main = do + print (approxRational (0 % 1 :: Ratio Int) (1 % 10)) -- 0%1, correct + print (approxRational (0 % 1 :: Ratio Word) (1 % 10)) -- 1%1, incorrect diff --git a/libraries/base/tests/T14425.stdout b/libraries/base/tests/T14425.stdout new file mode 100644 index 0000000000..2118b0ccd4 --- /dev/null +++ b/libraries/base/tests/T14425.stdout @@ -0,0 +1,2 @@ +0 % 1 +0 % 1 diff --git a/libraries/base/tests/T15349.hs b/libraries/base/tests/T15349.hs new file mode 100644 index 0000000000..6674330924 --- /dev/null +++ b/libraries/base/tests/T15349.hs @@ -0,0 +1,17 @@ +import Control.Monad.ST.Strict +import Control.Monad.Fix +import Data.STRef + +foo :: ST s Int +foo = do + ref <- newSTRef True + mfix $ \res -> do + x <- readSTRef ref + if x + then do + writeSTRef ref False + return $! (res + 5) + else return 10 + +main :: IO () +main = print $ runST foo diff --git a/libraries/base/tests/T15349.stderr b/libraries/base/tests/T15349.stderr new file mode 100644 index 0000000000..9cb080d93e --- /dev/null +++ b/libraries/base/tests/T15349.stderr @@ -0,0 +1 @@ +T15349: <<loop>> diff --git a/libraries/base/tests/T3474.hs b/libraries/base/tests/T3474.hs new file mode 100644 index 0000000000..dbd59011b4 --- /dev/null +++ b/libraries/base/tests/T3474.hs @@ -0,0 +1,5 @@ +import Data.List + +-- this should evaluate in constant space +main :: IO () +main = print $ iterate' (+1) 1 !! 100000000 diff --git a/libraries/base/tests/T3474.stdout b/libraries/base/tests/T3474.stdout new file mode 100644 index 0000000000..2e8da1af1b --- /dev/null +++ b/libraries/base/tests/T3474.stdout @@ -0,0 +1 @@ +100000001
\ No newline at end of file diff --git a/libraries/base/tests/T7773.hs b/libraries/base/tests/T7773.hs index 495cd7abd9..13ec40dadf 100644 --- a/libraries/base/tests/T7773.hs +++ b/libraries/base/tests/T7773.hs @@ -6,4 +6,4 @@ main = do fd <- openFd "/dev/random" ReadOnly Nothing defaultFileFlags threadWaitRead fd putStrLn "goodbye" -
\ No newline at end of file + diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 4bd8084220..715d4c3f53 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -1,7 +1,21 @@ +import string +import re +#-------------------------------------- +# Python normalization functions +#-------------------------------------- + +def normalise_quotes (str): + str = re.sub(r'"',r'', str, flags=re.MULTILINE) + return str + +#-------------------------------------- +# Test functions +#-------------------------------------- test('readFloat', exit_code(1), compile_and_run, ['']) test('enumDouble', normal, compile_and_run, ['']) test('enumRatio', normal, compile_and_run, ['']) +test('enumNumeric', normal, compile_and_run, ['']) test('tempfiles', normal, compile_and_run, ['']) test('fixed', normal, compile_and_run, ['']) test('quotOverflow', normal, compile_and_run, ['']) @@ -121,7 +135,9 @@ test('T2528', normal, compile_and_run, ['']) # Seems to be a known problem, e.g. # http://mingw-users.1079350.n2.nabble.com/Bug-re-Unicode-on-the-console-td3121717.html # May 2014: seems to work on msys2 -test('T4006', normal, compile_and_run, ['']) +# May 2018: The behavior of printf seems very implementation dependent. +# so let's normalise the output. +test('T4006', normalise_fun(normalise_quotes), compile_and_run, ['']) test('T5943', normal, compile_and_run, ['']) test('T5962', normal, compile_and_run, ['']) @@ -201,9 +217,11 @@ test('T9848', test('T10149', normal, compile_and_run, ['']) test('T11334a', normal, compile_and_run, ['']) test('T11555', normal, compile_and_run, ['']) +test('T12494', normal, compile_and_run, ['']) test('T12852', when(opsys('mingw32'), skip), compile_and_run, ['']) test('lazySTexamples', normal, compile_and_run, ['']) test('T11760', normal, compile_and_run, ['-threaded -with-rtsopts=-N2']) +test('T12874', normal, compile_and_run, ['']) test('T13191', [ stats_num_field('bytes allocated', [ (wordsize(64), 185943272, 5) ]) @@ -214,3 +232,13 @@ test('T13191', ['-O']) test('T13525', when(opsys('mingw32'), skip), compile_and_run, ['']) test('T13097', normal, compile_and_run, ['']) +test('functorOperators', normal, compile_and_run, ['']) +test('T3474', + [stats_num_field('max_bytes_used', [ (wordsize(64), 44504, 5) ]), + only_ways(['normal'])], + compile_and_run, ['-O']) +test('T14425', normal, compile_and_run, ['']) +test('T10412', normal, compile_and_run, ['']) +test('T13896', normal, compile_and_run, ['']) +test('T13167', normal, compile_and_run, ['']) +test('T15349', [exit_code(1)], compile_and_run, ['']) diff --git a/libraries/base/tests/enumNumeric.hs b/libraries/base/tests/enumNumeric.hs new file mode 100644 index 0000000000..36c4846d1f --- /dev/null +++ b/libraries/base/tests/enumNumeric.hs @@ -0,0 +1,7 @@ +main :: IO () +main = do + print $ map (/2) ([5..6] :: [Double]) + print $ ([9007199254740990..9007199254740991] :: [Double]) + print $ map (/2) ([9007199254740990..9007199254740991] :: [Double]) + print $ ([9007199254740989..9007199254740990] :: [Double]) + print $ map (/2) ([9007199254740989..9007199254740990] :: [Double]) diff --git a/libraries/base/tests/enumNumeric.stdout b/libraries/base/tests/enumNumeric.stdout new file mode 100644 index 0000000000..3d7eb74f91 --- /dev/null +++ b/libraries/base/tests/enumNumeric.stdout @@ -0,0 +1,5 @@ +[2.5,3.0] +[9.00719925474099e15,9.007199254740991e15,9.007199254740992e15,9.007199254740992e15] +[4.503599627370495e15,4.5035996273704955e15,4.503599627370496e15,4.503599627370496e15] +[9.007199254740989e15,9.00719925474099e15] +[4.5035996273704945e15,4.503599627370495e15] diff --git a/libraries/base/tests/functorOperators.hs b/libraries/base/tests/functorOperators.hs new file mode 100644 index 0000000000..aea5dfda80 --- /dev/null +++ b/libraries/base/tests/functorOperators.hs @@ -0,0 +1,38 @@ +-- Test infix operators of 'Functor' + +import Data.Functor + +main :: IO () +main = do + testInfixFmap + testFlippedInfixFmap + testInfixReplace + testFlippedInfixReplace + +testInfixFmap :: IO () +testInfixFmap = do + print "<$> tests:" + print $ (+ 1) <$> Just 2 -- => Just 3 + print (((+ 1) <$> Right 3) :: Either Int Int) -- => Right 4 + print $ (+ 1) <$> [1, 2, 3] -- => [2,3,4] + +testFlippedInfixFmap :: IO () +testFlippedInfixFmap = do + print "<&> tests:" + print $ Just 2 <&> (+ 1) -- => Just 3 + print ((Right 3 <&> (+ 1)) :: Either Int Int) -- => Right 4 + print $ [1, 2, 3] <&> (+ 1) -- => [2,3,4] + +testInfixReplace :: IO () +testInfixReplace = do + print "<$ tests:" + print $ 42 <$ Just 1 -- => Just 42 + print ((42 <$ Right 1) :: Either Int Int) -- => Right 42 + print $ 42 <$ [1, 2, 3] -- => [42,42,42] + +testFlippedInfixReplace :: IO () +testFlippedInfixReplace = do + print "$> tests:" + print $ Just 1 $> 42 -- => Just 42 + print ((Right 1 $> 42) :: Either Int Int) -- => Right 42 + print $ [1, 2, 3] $> 42 -- => [42,42,42] diff --git a/libraries/base/tests/functorOperators.stdout b/libraries/base/tests/functorOperators.stdout new file mode 100644 index 0000000000..00a17ed3b8 --- /dev/null +++ b/libraries/base/tests/functorOperators.stdout @@ -0,0 +1,16 @@ +"<$> tests:" +Just 3 +Right 4 +[2,3,4] +"<&> tests:" +Just 3 +Right 4 +[2,3,4] +"<$ tests:" +Just 42 +Right 42 +[42,42,42] +"$> tests:" +Just 42 +Right 42 +[42,42,42] diff --git a/libraries/base/tests/memo001.hs b/libraries/base/tests/memo001.hs index 551bcd8cf4..bb43dd0cd4 100644 --- a/libraries/base/tests/memo001.hs +++ b/libraries/base/tests/memo001.hs @@ -12,7 +12,7 @@ testMemo = do -- mlength will memoize itself over each element of 'keys', returning -- the memoized result the second time around. Then we move onto -- keys2, and while we're doing this the first lot of memo table --- entries can be purged. Finally, we do a a large computation +-- entries can be purged. Finally, we do a large computation -- (length [1..10000]) to allow time for the memo table to be fully -- purged. diff --git a/libraries/base/tests/tempfiles.stdout-mingw32 b/libraries/base/tests/tempfiles.stdout-mingw32 new file mode 100644 index 0000000000..5d7b23db0e --- /dev/null +++ b/libraries/base/tests/tempfiles.stdout-mingw32 @@ -0,0 +1,12 @@ +.no_prefix.hs +True +False +no_suffix +True +False +one_suffix.hs +True +False +two_suffixes.hs.blah +True +False diff --git a/libraries/base/tests/unicode002.stdout b/libraries/base/tests/unicode002.stdout index 800cce71af..8a5febbb0a 100644 --- a/libraries/base/tests/unicode002.stdout +++ b/libraries/base/tests/unicode002.stdout @@ -1375,7 +1375,7 @@ Code C P S U L A D 1373 F T F F F F F 1374 F T F F F F F 1375 F T F F F F F -1376 F F F F F F F +1376 F T F F T T F 1377 F T F F T T F 1378 F T F F T T F 1379 F T F F T T F @@ -1415,7 +1415,7 @@ Code C P S U L A D 1413 F T F F T T F 1414 F T F F T T F 1415 F T F F T T F -1416 F F F F F F F +1416 F T F F T T F 1417 F T F F F F F 1418 F T F F F F F 1419 F F F F F F F @@ -1518,7 +1518,7 @@ Code C P S U L A D 1516 F F F F F F F 1517 F F F F F F F 1518 F F F F F F F -1519 F F F F F F F +1519 F T F F F T F 1520 F T F F F T F 1521 F T F F F T F 1522 F T F F F T F @@ -2044,9 +2044,9 @@ Code C P S U L A D 2042 F T F F F T F 2043 F F F F F F F 2044 F F F F F F F -2045 F F F F F F F -2046 F F F F F F F -2047 F F F F F F F +2045 F T F F F F F +2046 F T F F F F F +2047 F T F F F F F 2048 F T F F F T F 2049 F T F F F T F 2050 F T F F F T F @@ -2143,17 +2143,17 @@ Code C P S U L A D 2141 F F F F F F F 2142 F T F F F F F 2143 F F F F F F F -2144 F F F F F F F -2145 F F F F F F F -2146 F F F F F F F -2147 F F F F F F F -2148 F F F F F F F -2149 F F F F F F F -2150 F F F F F F F -2151 F F F F F F F -2152 F F F F F F F -2153 F F F F F F F -2154 F F F F F F F +2144 F T F F F T F +2145 F T F F F T F +2146 F T F F F T F +2147 F T F F F T F +2148 F T F F F T F +2149 F T F F F T F +2150 F T F F F T F +2151 F T F F F T F +2152 F T F F F T F +2153 F T F F F T F +2154 F T F F F T F 2155 F F F F F F F 2156 F F F F F F F 2157 F F F F F F F @@ -2226,17 +2226,17 @@ Code C P S U L A D 2224 F T F F F T F 2225 F T F F F T F 2226 F T F F F T F -2227 F F F F F F F -2228 F F F F F F F +2227 F T F F F T F +2228 F T F F F T F 2229 F F F F F F F -2230 F F F F F F F -2231 F F F F F F F -2232 F F F F F F F -2233 F F F F F F F -2234 F F F F F F F -2235 F F F F F F F -2236 F F F F F F F -2237 F F F F F F F +2230 F T F F F T F +2231 F T F F F T F +2232 F T F F F T F +2233 F T F F F T F +2234 F T F F F T F +2235 F T F F F T F +2236 F T F F F T F +2237 F T F F F T F 2238 F F F F F F F 2239 F F F F F F F 2240 F F F F F F F @@ -2258,23 +2258,23 @@ Code C P S U L A D 2256 F F F F F F F 2257 F F F F F F F 2258 F F F F F F F -2259 F F F F F F F -2260 F F F F F F F -2261 F F F F F F F -2262 F F F F F F F -2263 F F F F F F F -2264 F F F F F F F -2265 F F F F F F F -2266 F F F F F F F -2267 F F F F F F F -2268 F F F F F F F -2269 F F F F F F F -2270 F F F F F F F -2271 F F F F F F F -2272 F F F F F F F -2273 F F F F F F F +2259 F T F F F F F +2260 F T F F F F F +2261 F T F F F F F +2262 F T F F F F F +2263 F T F F F F F +2264 F T F F F F F +2265 F T F F F F F +2266 F T F F F F F +2267 F T F F F F F +2268 F T F F F F F +2269 F T F F F F F +2270 F T F F F F F +2271 F T F F F F F +2272 F T F F F F F +2273 F T F F F F F 2274 F F F F F F F -2275 F F F F F F F +2275 F T F F F F F 2276 F T F F F F F 2277 F T F F F F F 2278 F T F F F F F @@ -2555,9 +2555,9 @@ Code C P S U L A D 2553 F T F F F F F 2554 F T F F F F F 2555 F T F F F F F -2556 F F F F F F F -2557 F F F F F F F -2558 F F F F F F F +2556 F T F F F T F +2557 F T F F F F F +2558 F T F F F F F 2559 F F F F F F F 2560 F F F F F F F 2561 F T F F F F F @@ -2677,7 +2677,7 @@ Code C P S U L A D 2675 F T F F F T F 2676 F T F F F T F 2677 F T F F F F F -2678 F F F F F F F +2678 F T F F F F F 2679 F F F F F F F 2680 F F F F F F F 2681 F F F F F F F @@ -2808,13 +2808,13 @@ Code C P S U L A D 2806 F F F F F F F 2807 F F F F F F F 2808 F F F F F F F -2809 F F F F F F F -2810 F F F F F F F -2811 F F F F F F F -2812 F F F F F F F -2813 F F F F F F F -2814 F F F F F F F -2815 F F F F F F F +2809 F T F F F T F +2810 F T F F F F F +2811 F T F F F F F +2812 F T F F F F F +2813 F T F F F F F +2814 F T F F F F F +2815 F T F F F F F 2816 F F F F F F F 2817 F T F F F F F 2818 F T F F F F F @@ -3075,7 +3075,7 @@ Code C P S U L A D 3073 F T F F F F F 3074 F T F F F F F 3075 F T F F F F F -3076 F F F F F F F +3076 F T F F F F F 3077 F T F F F T F 3078 F T F F F T F 3079 F T F F F T F @@ -3161,7 +3161,7 @@ Code C P S U L A D 3159 F F F F F F F 3160 F T F F F T F 3161 F T F F F T F -3162 F F F F F F F +3162 F T F F F T F 3163 F F F F F F F 3164 F F F F F F F 3165 F F F F F F F @@ -3190,7 +3190,7 @@ Code C P S U L A D 3188 F F F F F F F 3189 F F F F F F F 3190 F F F F F F F -3191 F F F F F F F +3191 F T F F F F F 3192 F T F F F F F 3193 F T F F F F F 3194 F T F F F F F @@ -3199,11 +3199,11 @@ Code C P S U L A D 3197 F T F F F F F 3198 F T F F F F F 3199 F T F F F F F -3200 F F F F F F F +3200 F T F F F T F 3201 F T F F F F F 3202 F T F F F F F 3203 F T F F F F F -3204 F F F F F F F +3204 F T F F F F F 3205 F T F F F T F 3206 F T F F F T F 3207 F T F F F T F @@ -3327,7 +3327,7 @@ Code C P S U L A D 3325 F F F F F F F 3326 F F F F F F F 3327 F F F F F F F -3328 F F F F F F F +3328 F T F F F F F 3329 F T F F F F F 3330 F T F F F F F 3331 F T F F F F F @@ -3386,8 +3386,8 @@ Code C P S U L A D 3384 F T F F F T F 3385 F T F F F T F 3386 F T F F F T F -3387 F F F F F F F -3388 F F F F F F F +3387 F T F F F F F +3388 F T F F F F F 3389 F T F F F T F 3390 F T F F F F F 3391 F T F F F F F @@ -3406,23 +3406,23 @@ Code C P S U L A D 3404 F T F F F F F 3405 F T F F F F F 3406 F T F F F T F -3407 F F F F F F F +3407 F T F F F F F 3408 F F F F F F F 3409 F F F F F F F 3410 F F F F F F F 3411 F F F F F F F -3412 F F F F F F F -3413 F F F F F F F -3414 F F F F F F F +3412 F T F F F T F +3413 F T F F F T F +3414 F T F F F T F 3415 F T F F F F F -3416 F F F F F F F -3417 F F F F F F F -3418 F F F F F F F -3419 F F F F F F F -3420 F F F F F F F -3421 F F F F F F F -3422 F F F F F F F -3423 F F F F F F F +3416 F T F F F F F +3417 F T F F F F F +3418 F T F F F F F +3419 F T F F F F F +3420 F T F F F F F +3421 F T F F F F F +3422 F T F F F F F +3423 F T F F F T F 3424 F T F F F T F 3425 F T F F F T F 3426 F T F F F F F @@ -3445,9 +3445,9 @@ Code C P S U L A D 3443 F T F F F F F 3444 F T F F F F F 3445 F T F F F F F -3446 F F F F F F F -3447 F F F F F F F -3448 F F F F F F F +3446 F T F F F F F +3447 F T F F F F F +3448 F T F F F F F 3449 F T F F F F F 3450 F T F F F T F 3451 F T F F F T F @@ -3717,25 +3717,25 @@ Code C P S U L A D 3715 F F F F F F F 3716 F T F F F T F 3717 F F F F F F F -3718 F F F F F F F +3718 F T F F F T F 3719 F T F F F T F 3720 F T F F F T F -3721 F F F F F F F +3721 F T F F F T F 3722 F T F F F T F 3723 F F F F F F F -3724 F F F F F F F +3724 F T F F F T F 3725 F T F F F T F -3726 F F F F F F F -3727 F F F F F F F -3728 F F F F F F F -3729 F F F F F F F -3730 F F F F F F F -3731 F F F F F F F +3726 F T F F F T F +3727 F T F F F T F +3728 F T F F F T F +3729 F T F F F T F +3730 F T F F F T F +3731 F T F F F T F 3732 F T F F F T F 3733 F T F F F T F 3734 F T F F F T F 3735 F T F F F T F -3736 F F F F F F F +3736 F T F F F T F 3737 F T F F F T F 3738 F T F F F T F 3739 F T F F F T F @@ -3743,7 +3743,7 @@ Code C P S U L A D 3741 F T F F F T F 3742 F T F F F T F 3743 F T F F F T F -3744 F F F F F F F +3744 F T F F F T F 3745 F T F F F T F 3746 F T F F F T F 3747 F T F F F T F @@ -3751,11 +3751,11 @@ Code C P S U L A D 3749 F T F F F T F 3750 F F F F F F F 3751 F T F F F T F -3752 F F F F F F F -3753 F F F F F F F +3752 F T F F F T F +3753 F T F F F T F 3754 F T F F F T F 3755 F T F F F T F -3756 F F F F F F F +3756 F T F F F T F 3757 F T F F F T F 3758 F T F F F T F 3759 F T F F F T F @@ -3769,7 +3769,7 @@ Code C P S U L A D 3767 F T F F F F F 3768 F T F F F F F 3769 F T F F F F F -3770 F F F F F F F +3770 F T F F F F F 3771 F T F F F F F 3772 F T F F F F F 3773 F T F F F T F @@ -4303,54 +4303,54 @@ Code C P S U L A D 4301 F T F T F T F 4302 F F F F F F F 4303 F F F F F F F -4304 F T F F F T F -4305 F T F F F T F -4306 F T F F F T F -4307 F T F F F T F -4308 F T F F F T F -4309 F T F F F T F -4310 F T F F F T F -4311 F T F F F T F -4312 F T F F F T F -4313 F T F F F T F -4314 F T F F F T F -4315 F T F F F T F -4316 F T F F F T F -4317 F T F F F T F -4318 F T F F F T F -4319 F T F F F T F -4320 F T F F F T F -4321 F T F F F T F -4322 F T F F F T F -4323 F T F F F T F -4324 F T F F F T F -4325 F T F F F T F -4326 F T F F F T F -4327 F T F F F T F -4328 F T F F F T F -4329 F T F F F T F -4330 F T F F F T F -4331 F T F F F T F -4332 F T F F F T F -4333 F T F F F T F -4334 F T F F F T F -4335 F T F F F T F -4336 F T F F F T F -4337 F T F F F T F -4338 F T F F F T F -4339 F T F F F T F -4340 F T F F F T F -4341 F T F F F T F -4342 F T F F F T F -4343 F T F F F T F -4344 F T F F F T F -4345 F T F F F T F -4346 F T F F F T F +4304 F T F F T T F +4305 F T F F T T F +4306 F T F F T T F +4307 F T F F T T F +4308 F T F F T T F +4309 F T F F T T F +4310 F T F F T T F +4311 F T F F T T F +4312 F T F F T T F +4313 F T F F T T F +4314 F T F F T T F +4315 F T F F T T F +4316 F T F F T T F +4317 F T F F T T F +4318 F T F F T T F +4319 F T F F T T F +4320 F T F F T T F +4321 F T F F T T F +4322 F T F F T T F +4323 F T F F T T F +4324 F T F F T T F +4325 F T F F T T F +4326 F T F F T T F +4327 F T F F T T F +4328 F T F F T T F +4329 F T F F T T F +4330 F T F F T T F +4331 F T F F T T F +4332 F T F F T T F +4333 F T F F T T F +4334 F T F F T T F +4335 F T F F T T F +4336 F T F F T T F +4337 F T F F T T F +4338 F T F F T T F +4339 F T F F T T F +4340 F T F F T T F +4341 F T F F T T F +4342 F T F F T T F +4343 F T F F T T F +4344 F T F F T T F +4345 F T F F T T F +4346 F T F F T T F 4347 F T F F F F F 4348 F T F F F T F -4349 F T F F F T F -4350 F T F F F T F -4351 F T F F F T F +4349 F T F F T T F +4350 F T F F T T F +4351 F T F F T T F 4352 F T F F F T F 4353 F T F F F T F 4354 F T F F F T F @@ -5023,100 +5023,100 @@ Code C P S U L A D 5021 F F F F F F F 5022 F F F F F F F 5023 F F F F F F F -5024 F T F F F T F -5025 F T F F F T F -5026 F T F F F T F -5027 F T F F F T F -5028 F T F F F T F -5029 F T F F F T F -5030 F T F F F T F -5031 F T F F F T F -5032 F T F F F T F -5033 F T F F F T F -5034 F T F F F T F -5035 F T F F F T F -5036 F T F F F T F -5037 F T F F F T F -5038 F T F F F T F -5039 F T F F F T F -5040 F T F F F T F -5041 F T F F F T F -5042 F T F F F T F -5043 F T F F F T F -5044 F T F F F T F -5045 F T F F F T F -5046 F T F F F T F -5047 F T F F F T F -5048 F T F F F T F -5049 F T F F F T F -5050 F T F F F T F -5051 F T F F F T F -5052 F T F F F T F -5053 F T F F F T F -5054 F T F F F T F -5055 F T F F F T F -5056 F T F F F T F -5057 F T F F F T F -5058 F T F F F T F -5059 F T F F F T F -5060 F T F F F T F -5061 F T F F F T F -5062 F T F F F T F -5063 F T F F F T F -5064 F T F F F T F -5065 F T F F F T F -5066 F T F F F T F -5067 F T F F F T F -5068 F T F F F T F -5069 F T F F F T F -5070 F T F F F T F -5071 F T F F F T F -5072 F T F F F T F -5073 F T F F F T F -5074 F T F F F T F -5075 F T F F F T F -5076 F T F F F T F -5077 F T F F F T F -5078 F T F F F T F -5079 F T F F F T F -5080 F T F F F T F -5081 F T F F F T F -5082 F T F F F T F -5083 F T F F F T F -5084 F T F F F T F -5085 F T F F F T F -5086 F T F F F T F -5087 F T F F F T F -5088 F T F F F T F -5089 F T F F F T F -5090 F T F F F T F -5091 F T F F F T F -5092 F T F F F T F -5093 F T F F F T F -5094 F T F F F T F -5095 F T F F F T F -5096 F T F F F T F -5097 F T F F F T F -5098 F T F F F T F -5099 F T F F F T F -5100 F T F F F T F -5101 F T F F F T F -5102 F T F F F T F -5103 F T F F F T F -5104 F T F F F T F -5105 F T F F F T F -5106 F T F F F T F -5107 F T F F F T F -5108 F T F F F T F -5109 F F F F F F F +5024 F T F T F T F +5025 F T F T F T F +5026 F T F T F T F +5027 F T F T F T F +5028 F T F T F T F +5029 F T F T F T F +5030 F T F T F T F +5031 F T F T F T F +5032 F T F T F T F +5033 F T F T F T F +5034 F T F T F T F +5035 F T F T F T F +5036 F T F T F T F +5037 F T F T F T F +5038 F T F T F T F +5039 F T F T F T F +5040 F T F T F T F +5041 F T F T F T F +5042 F T F T F T F +5043 F T F T F T F +5044 F T F T F T F +5045 F T F T F T F +5046 F T F T F T F +5047 F T F T F T F +5048 F T F T F T F +5049 F T F T F T F +5050 F T F T F T F +5051 F T F T F T F +5052 F T F T F T F +5053 F T F T F T F +5054 F T F T F T F +5055 F T F T F T F +5056 F T F T F T F +5057 F T F T F T F +5058 F T F T F T F +5059 F T F T F T F +5060 F T F T F T F +5061 F T F T F T F +5062 F T F T F T F +5063 F T F T F T F +5064 F T F T F T F +5065 F T F T F T F +5066 F T F T F T F +5067 F T F T F T F +5068 F T F T F T F +5069 F T F T F T F +5070 F T F T F T F +5071 F T F T F T F +5072 F T F T F T F +5073 F T F T F T F +5074 F T F T F T F +5075 F T F T F T F +5076 F T F T F T F +5077 F T F T F T F +5078 F T F T F T F +5079 F T F T F T F +5080 F T F T F T F +5081 F T F T F T F +5082 F T F T F T F +5083 F T F T F T F +5084 F T F T F T F +5085 F T F T F T F +5086 F T F T F T F +5087 F T F T F T F +5088 F T F T F T F +5089 F T F T F T F +5090 F T F T F T F +5091 F T F T F T F +5092 F T F T F T F +5093 F T F T F T F +5094 F T F T F T F +5095 F T F T F T F +5096 F T F T F T F +5097 F T F T F T F +5098 F T F T F T F +5099 F T F T F T F +5100 F T F T F T F +5101 F T F T F T F +5102 F T F T F T F +5103 F T F T F T F +5104 F T F T F T F +5105 F T F T F T F +5106 F T F T F T F +5107 F T F T F T F +5108 F T F T F T F +5109 F T F T F T F 5110 F F F F F F F 5111 F F F F F F F -5112 F F F F F F F -5113 F F F F F F F -5114 F F F F F F F -5115 F F F F F F F -5116 F F F F F F F -5117 F F F F F F F +5112 F T F F T T F +5113 F T F F T T F +5114 F T F F T T F +5115 F T F F T T F +5116 F T F F T T F +5117 F T F F T T F 5118 F F F F F F F 5119 F F F F F F F 5120 F T F F F F F @@ -6263,7 +6263,7 @@ Code C P S U L A D 6261 F T F F F T F 6262 F T F F F T F 6263 F T F F F T F -6264 F F F F F F F +6264 F T F F F T F 6265 F F F F F F F 6266 F F F F F F F 6267 F F F F F F F @@ -6276,8 +6276,8 @@ Code C P S U L A D 6274 F T F F F T F 6275 F T F F F T F 6276 F T F F F T F -6277 F T F F F T F -6278 F T F F F T F +6277 F T F F F F F +6278 F T F F F F F 6279 F T F F F T F 6280 F T F F F T F 6281 F T F F F T F |