diff options
Diffstat (limited to 'libraries/base/Control')
| -rw-r--r-- | libraries/base/Control/Applicative.hs | 22 | ||||
| -rw-r--r-- | libraries/base/Control/Arrow.hs | 4 | ||||
| -rw-r--r-- | libraries/base/Control/Category.hs | 9 | ||||
| -rw-r--r-- | libraries/base/Control/Concurrent.hs | 18 | ||||
| -rw-r--r-- | libraries/base/Control/Concurrent/Chan.hs | 42 | ||||
| -rw-r--r-- | libraries/base/Control/Concurrent/MVar.hs | 12 | ||||
| -rw-r--r-- | libraries/base/Control/Concurrent/QSem.hs | 2 | ||||
| -rw-r--r-- | libraries/base/Control/Concurrent/QSemN.hs | 2 | ||||
| -rw-r--r-- | libraries/base/Control/Exception.hs | 19 | ||||
| -rw-r--r-- | libraries/base/Control/Exception/Base.hs | 12 | ||||
| -rw-r--r-- | libraries/base/Control/Monad.hs | 134 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/Fail.hs | 4 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/Fix.hs | 28 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/ST.hs | 2 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/ST/Imp.hs | 58 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/ST/Lazy/Imp.hs | 16 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/ST/Lazy/Safe.hs | 2 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/ST/Lazy/Unsafe.hs | 2 | ||||
| -rw-r--r-- | libraries/base/Control/Monad/Zip.hs | 14 |
19 files changed, 277 insertions, 125 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 |