packages feed

transformers 0.2.2.0 → 0.6.3.0

raw patch · 41 files changed

Files

+ Control/Applicative/Backwards.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Applicative.Backwards+-- Copyright   :  (c) Russell O'Connor 2009+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Making functors with an 'Applicative' instance that performs actions+-- in the reverse order.+-----------------------------------------------------------------------------++module Control.Applicative.Backwards (+    Backwards(..),+  ) where++#if MIN_VERSION_base(4,18,0)+import Data.Foldable1 (Foldable1(foldMap1))+#endif+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length)+import Control.Applicative+import Data.Foldable+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Traversable (Traversable(traverse, sequenceA))+#endif++-- | The same functor, but with an 'Applicative' instance that performs+-- actions in the reverse order.+newtype Backwards f a = Backwards { forwards :: f a }+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, Generic1)+#elif __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++instance (Eq1 f) => Eq1 (Backwards f) where+    liftEq eq (Backwards x) (Backwards y) = liftEq eq x y+    {-# INLINE liftEq #-}++instance (Ord1 f) => Ord1 (Backwards f) where+    liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y+    {-# INLINE liftCompare #-}++instance (Read1 f) => Read1 (Backwards f) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards++instance (Show1 f) => Show1 (Backwards f) where+    liftShowsPrec sp sl d (Backwards x) =+        showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x++instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1+instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1++-- | Derived instance.+instance (Functor f) => Functor (Backwards f) where+    fmap f (Backwards a) = Backwards (fmap f a)+    {-# INLINE fmap #-}+    x <$ Backwards a = Backwards (x <$ a)+    {-# INLINE (<$) #-}++-- | Apply @f@-actions in the reverse order.+instance (Applicative f) => Applicative (Backwards f) where+    pure a = Backwards (pure a)+    {-# INLINE pure #-}+    Backwards f <*> Backwards a = Backwards (a <**> f)+    {-# INLINE (<*>) #-}+#if MIN_VERSION_base(4,10,0)+    liftA2 f (Backwards m) (Backwards n) = Backwards $ liftA2 (flip f) n m+    {-# INLINE liftA2 #-}+#endif+#if MIN_VERSION_base(4,2,0)+    Backwards xs *> Backwards ys = Backwards (ys <* xs)+    {-# INLINE (*>) #-}+    Backwards ys <* Backwards xs = Backwards (xs *> ys)+    {-# INLINE (<*) #-}+#endif++-- | Try alternatives in the same order as @f@.+instance (Alternative f) => Alternative (Backwards f) where+    empty = Backwards empty+    {-# INLINE empty #-}+    Backwards x <|> Backwards y = Backwards (x <|> y)+    {-# INLINE (<|>) #-}++-- | Derived instance.+instance (Foldable f) => Foldable (Backwards f) where+    foldMap f (Backwards t) = foldMap f t+    {-# INLINE foldMap #-}+    foldr f z (Backwards t) = foldr f z t+    {-# INLINE foldr #-}+    foldl f z (Backwards t) = foldl f z t+    {-# INLINE foldl #-}+    foldr1 f (Backwards t) = foldr1 f t+    {-# INLINE foldr1 #-}+    foldl1 f (Backwards t) = foldl1 f t+    {-# INLINE foldl1 #-}+#if MIN_VERSION_base(4,8,0)+    null (Backwards t) = null t+    length (Backwards t) = length t+#endif++#if MIN_VERSION_base(4,18,0)+-- | Derived instance.+instance (Foldable1 f) => Foldable1 (Backwards f) where+    foldMap1 f (Backwards t) = foldMap1 f t+    {-# INLINE foldMap1 #-}+#endif++-- | Derived instance.+instance (Traversable f) => Traversable (Backwards f) where+    traverse f (Backwards t) = fmap Backwards (traverse f t)+    {-# INLINE traverse #-}+    sequenceA (Backwards t) = fmap Backwards (sequenceA t)+    {-# INLINE sequenceA #-}++#if MIN_VERSION_base(4,12,0)+-- | Derived instance.+instance (Contravariant f) => Contravariant (Backwards f) where+    contramap f = Backwards . contramap f . forwards+    {-# INLINE contramap #-}+#endif
+ Control/Applicative/Lift.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Applicative.Lift+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Adding a new kind of pure computation to an applicative functor.+-----------------------------------------------------------------------------++module Control.Applicative.Lift (+    -- * Lifting an applicative+    Lift(..),+    unLift,+    mapLift,+    elimLift,+    -- * Collecting errors+    Errors,+    runErrors,+    failure,+    eitherToErrors+  ) where++#if MIN_VERSION_base(4,18,0)+import Data.Foldable1 (Foldable1(foldMap1))+#endif+import Data.Functor.Classes++import Control.Applicative+import Data.Functor.Constant+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (Monoid(..))+import Data.Traversable (Traversable(traverse))+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | Applicative functor formed by adding pure computations to a given+-- applicative functor.+data Lift f a = Pure a | Other (f a)+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, Generic1)+#elif __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++instance (Eq1 f) => Eq1 (Lift f) where+    liftEq eq (Pure x1) (Pure x2) = eq x1 x2+    liftEq _ (Pure _) (Other _) = False+    liftEq _ (Other _) (Pure _) = False+    liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2+    {-# INLINE liftEq #-}++instance (Ord1 f) => Ord1 (Lift f) where+    liftCompare comp (Pure x1) (Pure x2) = comp x1 x2+    liftCompare _ (Pure _) (Other _) = LT+    liftCompare _ (Other _) (Pure _) = GT+    liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2+    {-# INLINE liftCompare #-}++instance (Read1 f) => Read1 (Lift f) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith rp "Pure" Pure `mappend`+        readsUnaryWith (liftReadsPrec rp rl) "Other" Other++instance (Show1 f) => Show1 (Lift f) where+    liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x+    liftShowsPrec sp sl d (Other y) =+        showsUnaryWith (liftShowsPrec sp sl) "Other" d y++instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1+instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1++instance (Functor f) => Functor (Lift f) where+    fmap f (Pure x) = Pure (f x)+    fmap f (Other y) = Other (fmap f y)+    {-# INLINE fmap #-}++instance (Foldable f) => Foldable (Lift f) where+    foldMap f (Pure x) = f x+    foldMap f (Other y) = foldMap f y+    {-# INLINE foldMap #-}++instance (Traversable f) => Traversable (Lift f) where+    traverse f (Pure x) = Pure <$> f x+    traverse f (Other y) = Other <$> traverse f y+    {-# INLINE traverse #-}++-- | A combination is 'Pure' only if both parts are.+instance (Applicative f) => Applicative (Lift f) where+    pure = Pure+    {-# INLINE pure #-}+    Pure f <*> ax = f <$> ax+    Other f <*> ax = Other (f <*> unLift ax)+    {-# INLINE (<*>) #-}++-- | A combination is 'Pure' only either part is.+instance (Alternative f) => Alternative (Lift f) where+    empty = Other empty+    {-# INLINE empty #-}+    Pure x <|> _ = Pure x+    Other _ <|> Pure y = Pure y+    Other x <|> Other y = Other (x <|> y)+    {-# INLINE (<|>) #-}++#if MIN_VERSION_base(4,18,0)+instance (Foldable1 f) => Foldable1 (Lift f) where+    foldMap1 f (Pure x)  = f x+    foldMap1 f (Other y) = foldMap1 f y+    {-# INLINE foldMap1 #-}+#endif++-- | Projection to the other functor.+unLift :: (Applicative f) => Lift f a -> f a+unLift (Pure x) = pure x+unLift (Other e) = e+{-# INLINE unLift #-}++-- | Apply a transformation to the other computation.+mapLift :: (f a -> g a) -> Lift f a -> Lift g a+mapLift _ (Pure x) = Pure x+mapLift f (Other e) = Other (f e)+{-# INLINE mapLift #-}++-- | Eliminator for 'Lift'.+--+-- * @'elimLift' f g . 'pure' = f@+--+-- * @'elimLift' f g . 'Other' = g@+--+elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r+elimLift f _ (Pure x) = f x+elimLift _ g (Other e) = g e+{-# INLINE elimLift #-}++-- | An applicative functor that collects a monoid (e.g. lists) of errors.+-- A sequence of computations fails if any of its components do, but+-- unlike monads made with 'Control.Monad.Trans.Except.ExceptT' from+-- "Control.Monad.Trans.Except", these computations continue after an+-- error, collecting all the errors.+--+-- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@+--+-- * @'pure' f '<*>' 'failure' e = 'failure' e@+--+-- * @'failure' e '<*>' 'pure' x = 'failure' e@+--+-- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@+--+type Errors e = Lift (Constant e)++-- | Extractor for computations with accumulating errors.+--+-- * @'runErrors' ('pure' x) = 'Right' x@+--+-- * @'runErrors' ('failure' e) = 'Left' e@+--+runErrors :: Errors e a -> Either e a+runErrors (Other (Constant e)) = Left e+runErrors (Pure x) = Right x+{-# INLINE runErrors #-}++-- | Report an error.+failure :: e -> Errors e a+failure e = Other (Constant e)+{-# INLINE failure #-}++-- | Convert from 'Either' to 'Errors' (inverse of 'runErrors').+eitherToErrors :: Either e a -> Errors e a+eitherToErrors = either failure Pure
− Control/Monad/IO/Class.hs 
@@ -1,37 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.IO.Class--- Copyright   :  (c) Andy Gill 2001,---                (c) Oregon Graduate Institute of Science and Technology, 2001--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  portable------ Class of monads based on @IO@.--------------------------------------------------------------------------------module Control.Monad.IO.Class (-    MonadIO(..)-  ) where--import System.IO (IO)---- | Monads in which 'IO' computations may be embedded.--- Any monad built by applying a sequence of monad transformers to the--- 'IO' monad will be an instance of this class.------ Instances should satisfy the following laws, which state that 'liftIO'--- is a transformer of monads:------ * @'liftIO' . 'return' = 'return'@------ * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@--class (Monad m) => MonadIO m where-    -- | Lift a computation from the 'IO' monad.-    liftIO :: IO a -> m a--instance MonadIO IO where-    liftIO = id
+ Control/Monad/Signatures.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Signatures+-- Copyright   :  (c) Ross Paterson 2012+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Signatures for monad operations that require specialized lifting.+-- Each signature has a uniformity property that the lifting should satisfy.+-----------------------------------------------------------------------------++module Control.Monad.Signatures (+    CallCC, Catch, Listen, Pass+  ) where++-- | Signature of the @callCC@ operation,+-- introduced in "Control.Monad.Trans.Cont".+-- Any lifting function @liftCallCC@ should satisfy+--+-- @'Control.Monad.Trans.Class.lift' (f k) = f' ('Control.Monad.Trans.Class.lift' . k) => 'Control.Monad.Trans.Class.lift' (cf f) = liftCallCC cf f'@+--+-- This implies that on entry to the continuation any outer monad+-- transformer effect inside @callCC@ will have been rolled back.+type CallCC m a b = ((a -> m b) -> m a) -> m a++-- | Signature of the @catchE@ operation,+-- introduced in "Control.Monad.Trans.Except".+-- Any lifting function @liftCatch@ should satisfy+--+-- @'Control.Monad.Trans.Class.lift' (cf m h) = liftCatch cf ('Control.Monad.Trans.Class.lift' m) ('Control.Monad.Trans.Class.lift' . h)@+--+-- This implies that on entry to the handler function any outer monad+-- transformer effect inside @catchE@ will have been rolled back.+type Catch e m a = m a -> (e -> m a) -> m a++-- | Signature of the @listen@ operation,+-- introduced in "Control.Monad.Trans.Writer".+-- Any lifting function @liftListen@ should satisfy+--+-- @'Control.Monad.Trans.Class.lift' . liftListen = liftListen . 'Control.Monad.Trans.Class.lift'@+--+type Listen w m a = m a -> m (a, w)++-- | Signature of the @pass@ operation,+-- introduced in "Control.Monad.Trans.Writer".+-- Any lifting function @liftPass@ should satisfy+--+-- @'Control.Monad.Trans.Class.lift' . liftPass = liftPass . 'Control.Monad.Trans.Class.lift'@+--+type Pass w m a =  m (a, w -> w) -> m a
+ Control/Monad/Trans/Accum.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Accum+-- Copyright   :  (c) Nickolay Kudasov 2016+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The lazy 'AccumT' monad transformer, which adds accumulation+-- capabilities (such as declarations or document patches) to a given monad.+-- Each computation has access to the combination of the input environment+-- and outputs added so far, and returns the outputs added.+--+-- In applications requiring only the ability to accumulate an output and+-- to inspect the output so far, it would be considerably more efficient+-- to use "Control.Monad.Trans.State" instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Accum (+    -- * The Accum monad+    Accum,+    accum,+    runAccum,+    execAccum,+    evalAccum,+    mapAccum,+    -- * The AccumT monad transformer+    AccumT(..),+    execAccumT,+    evalAccumT,+    mapAccumT,+    -- * Accum operations+    look,+    looks,+    add,+    -- * Lifting other operations+    liftCallCC,+    liftCallCC',+    liftCatch,+    liftListen,+    liftPass,+    -- * Monad transformations+    readerToAccumT,+    writerToAccumT,+    accumToStateT,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.Writer (WriterT(..))+import Control.Monad.Trans.State  (StateT(..))+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Fix+import Control.Monad.Signatures+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- ---------------------------------------------------------------------------+-- | An accumulation monad (non-strict) parameterized by the type @w@+-- of output to accumulate.+--+-- This monad is a more complex extension of both the reader and writer+-- monads.  The 'return' function produces the output 'mempty', while @m+-- '>>=' k@ uses the output of @m@ both to extend the initial environment+-- of @k@ and to combine with the output of @k@:+--+-- <<images/bind-AccumT.svg>>+--+-- In applications requiring only the ability to accumulate an output and+-- to inspect the output so far, it would be considerably more efficient+-- to use a state monad.+type Accum w = AccumT w Identity++-- | Construct an accumulation computation from a (result, output) pair.+-- (The inverse of 'runAccum'.)+accum :: (Monad m) => (w -> (a, w)) -> AccumT w m a+accum f = AccumT $ \ w -> return (f w)+{-# INLINE accum #-}++-- | Unwrap an accumulation computation as a (result, output) pair.+-- (The inverse of 'accum'.)+runAccum :: Accum w a -> w -> (a, w)+runAccum m = runIdentity . runAccumT m+{-# INLINE runAccum #-}++-- | Extract the output from an accumulation computation.+--+-- * @'execAccum' m w = 'snd' ('runAccum' m w)@+execAccum :: Accum w a -> w -> w+execAccum m w = snd (runAccum m w)+{-# INLINE execAccum #-}++-- | Evaluate an accumulation computation with the given initial output history+-- and return the final value, discarding the final output.+--+-- * @'evalAccum' m w = 'fst' ('runAccum' m w)@+evalAccum :: (Monoid w) => Accum w a -> w -> a+evalAccum m w = fst (runAccum m w)+{-# INLINE evalAccum #-}++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runAccum' ('mapAccum' f m) = f . 'runAccum' m@+mapAccum :: ((a, w) -> (b, w)) -> Accum w a -> Accum w b+mapAccum f = mapAccumT (Identity . f . runIdentity)+{-# INLINE mapAccum #-}++-- ---------------------------------------------------------------------------+-- | An accumulation monad parameterized by:+--+--   * @w@ - the output to accumulate.+--+--   * @m@ - The inner monad.+--+-- This monad transformer is a more complex extension of both the reader+-- and writer monad transformers.  The 'return' function produces the+-- output 'mempty', while @m '>>=' k@ uses the output of @m@ both to+-- extend the initial environment of @k@ and to combine with the output+-- of @k@:+--+-- <<images/bind-AccumT.svg>>+--+-- In applications requiring only the ability to accumulate an output and+-- to inspect the output so far, it would be considerably more efficient+-- to use a state monad transformer.+--+-- @AccumT w m@ is strict if and only if @m@ is.+newtype AccumT w m a = AccumT {+    -- | Unwrap an accumulation computation.  For example, in the call+    --+    -- @    (value, locals) <- runAccumT action globals@+    --+    -- the action is fed an initial environment @globals@, and @locals@ is+    -- the sum of all arguments to calls of 'add' executed by the action.+    runAccumT :: w -> m (a, w)+    }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++-- | Extract the output from an accumulation computation.+--+-- * @'execAccumT' m w = 'liftM' 'snd' ('runAccumT' m w)@+execAccumT :: (Monad m) => AccumT w m a -> w -> m w+execAccumT m w = do+    ~(_, w') <- runAccumT m w+    return w'+{-# INLINE execAccumT #-}++-- | Evaluate an accumulation computation with the given initial output+-- history and return the final value, discarding the final output.+--+-- * @'evalAccumT' m w = 'liftM' 'fst' ('runAccumT' m w)@+evalAccumT :: (Monad m, Monoid w) => AccumT w m a -> w -> m a+evalAccumT m w = do+    ~(a, _) <- runAccumT m w+    return a+{-# INLINE evalAccumT #-}++-- | Map both the return value and output of a computation using the+-- given function.+--+-- * @'runAccumT' ('mapAccumT' f m) = f . 'runAccumT' m@+mapAccumT :: (m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b+mapAccumT f m = AccumT (f . runAccumT m)+{-# INLINE mapAccumT #-}++instance (Functor m) => Functor (AccumT w m) where+    fmap f = mapAccumT $ fmap $ \ ~(a, w) -> (f a, w)+    {-# INLINE fmap #-}++instance (Monoid w, Functor m, Monad m) => Applicative (AccumT w m) where+    pure a  = AccumT $ const $ return (a, mempty)+    {-# INLINE pure #-}+    mf <*> mv = AccumT $ \ w -> do+      ~(f, w')  <- runAccumT mf w+      ~(v, w'') <- runAccumT mv (w `mappend` w')+      return (f v, w' `mappend` w'')+    {-# INLINE (<*>) #-}++instance (Monoid w, Functor m, MonadPlus m) => Alternative (AccumT w m) where+    empty   = AccumT $ const mzero+    {-# INLINE empty #-}+    m <|> n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w+    {-# INLINE (<|>) #-}++instance (Monoid w, Functor m, Monad m) => Monad (AccumT w m) where+#if !(MIN_VERSION_base(4,8,0))+    return a  = AccumT $ const $ return (a, mempty)+    {-# INLINE return #-}+#endif+    m >>= k  = AccumT $ \ w -> do+        ~(a, w')  <- runAccumT m w+        ~(b, w'') <- runAccumT (k a) (w `mappend` w')+        return (b, w' `mappend` w'')+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail msg = AccumT $ const (fail msg)+    {-# INLINE fail #-}+#endif++#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where+    fail msg = AccumT $ const (Fail.fail msg)+    {-# INLINE fail #-}+#endif++instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where+    mzero       = AccumT $ const mzero+    {-# INLINE mzero #-}+    m `mplus` n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w+    {-# INLINE mplus #-}++instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where+    mfix m = AccumT $ \ w -> mfix $ \ ~(a, _) -> runAccumT (m a) w+    {-# INLINE mfix #-}++instance (Monoid w) => MonadTrans (AccumT w) where+    lift m = AccumT $ const $ do+        a <- m+        return (a, mempty)+    {-# INLINE lift #-}++instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}++-- | @'look'@ is an action that fetches all the previously accumulated output.+look :: (Monoid w, Monad m) => AccumT w m w+look = AccumT $ \ w -> return (w, mempty)++-- | @'look'@ is an action that retrieves a function of the previously accumulated output.+looks :: (Monoid w, Monad m) => (w -> a) -> AccumT w m a+looks f = AccumT $ \ w -> return (f w, mempty)++-- | @'add' w@ is an action that produces the output @w@.+add :: (Monad m) => w -> AccumT w m ()+add w = accum $ const ((), w)+{-# INLINE add #-}++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original output history on entering the+-- continuation.+liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b+liftCallCC callCC f = AccumT $ \ w ->+    callCC $ \ c ->+    runAccumT (f (\ a -> AccumT $ \ _ -> c (a, w))) w+{-# INLINE liftCallCC #-}++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current output history on entering the continuation.+-- It does not satisfy the uniformity property (see "Control.Monad.Signatures").+liftCallCC' :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b+liftCallCC' callCC f = AccumT $ \ s ->+    callCC $ \ c ->+    runAccumT (f (\ a -> AccumT $ \ s' -> c (a, s'))) s+{-# INLINE liftCallCC' #-}++-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @catchE@ discards any output from the body on entering+-- the handler.+liftCatch :: Catch e m (a, w) -> Catch e (AccumT w m) a+liftCatch catchE m h =+    AccumT $ \ w -> runAccumT m w `catchE` \ e -> runAccumT (h e) w+{-# INLINE liftCatch #-}++-- | Lift a @listen@ operation to the new monad.+liftListen :: (Monad m) => Listen w m (a, s) -> Listen w (AccumT s m) a+liftListen listen m = AccumT $ \ s -> do+    ~((a, s'), w) <- listen (runAccumT m s)+    return ((a, w), s')+{-# INLINE liftListen #-}++-- | Lift a @pass@ operation to the new monad.+liftPass :: (Monad m) => Pass w m (a, s) -> Pass w (AccumT s m) a+liftPass pass m = AccumT $ \ s -> pass $ do+    ~((a, f), s') <- runAccumT m s+    return ((a, s'), f)+{-# INLINE liftPass #-}++-- | Convert a read-only computation into an accumulation computation.+readerToAccumT :: (Functor m, Monoid w) => ReaderT w m a -> AccumT w m a+readerToAccumT (ReaderT f) = AccumT $ \ w -> fmap (\ a -> (a, mempty)) (f w)+{-# INLINE readerToAccumT #-}++-- | Convert a writer computation into an accumulation computation.+writerToAccumT :: WriterT w m a -> AccumT w m a+writerToAccumT (WriterT m) = AccumT $ const $ m+{-# INLINE writerToAccumT #-}++-- | Convert an accumulation (append-only) computation into a fully+-- stateful computation.+accumToStateT :: (Functor m, Monoid s) => AccumT s m a -> StateT s m a+accumToStateT (AccumT f) =+    StateT $ \ w -> fmap (\ ~(a, w') -> (a, w `mappend` w')) (f w)+{-# INLINE accumToStateT #-}
Control/Monad/Trans/Class.hs view
@@ -1,3 +1,13 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE QuantifiedConstraints #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Class@@ -5,52 +15,150 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- Classes for monad transformers.+-- The class of monad transformers. ----- A monad transformer makes new monad out of an existing monad, such+-- A monad transformer makes a new monad out of an existing monad, such -- that computations of the old monad may be embedded in the new one. -- To construct a monad with a desired set of features, one typically--- starts with a base monad, such as @Identity@, @[]@ or 'IO', and+-- starts with a base monad, such as 'Data.Functor.Identity.Identity', @[]@ or 'IO', and -- applies a sequence of monad transformers.------ Most monad transformer modules include the special case of applying the--- transformer to @Identity@.  For example, @State s@ is an abbreviation--- for @StateT s Identity@.------ Each monad transformer also comes with an operation @run@/XXX/ to--- unwrap the transformer, exposing a computation of the inner monad. -----------------------------------------------------------------------------  module Control.Monad.Trans.Class (     -- * Transformer class     MonadTrans(..) +    -- * Conventions+    -- $conventions++    -- * Strict monads+    -- $strict+     -- * Examples     -- ** Parsing     -- $example1      -- ** Parsing and counting     -- $example2++    -- ** Interpreter monad+    -- $example3   ) where --- | The class of monad transformers.  Instances should satisfy the--- following laws, which state that 'lift' is a transformer of monads:+-- | The class of monad transformers.+-- For any monad @m@, the result @t m@ should also be a monad,+-- and 'lift' should be a monad transformation from @m@ to @t m@,+-- i.e. it should satisfy the following laws: -- -- * @'lift' . 'return' = 'return'@ -- -- * @'lift' (m >>= f) = 'lift' m >>= ('lift' . f)@-+--+-- Since 0.6.0.0 and for GHC 8.6 and later, the requirement that @t m@+-- be a 'Monad' is enforced by the implication constraint+-- @forall m. 'Monad' m => 'Monad' (t m)@ enabled by the+-- @QuantifiedConstraints@ extension.+--+-- === __Ambiguity error with GHC 9.0 to 9.2.2__+-- These versions of GHC have a bug+-- (<https://gitlab.haskell.org/ghc/ghc/-/issues/20582>)+-- which causes constraints like+--+-- @+-- (MonadTrans t, forall m. Monad m => Monad (t m)) => ...+-- @+--+-- to be reported as ambiguous.  For transformers 0.6 and later, this can+-- be fixed by removing the second constraint, which is implied by the first.+#if __GLASGOW_HASKELL__ >= 806+class (forall m. Monad m => Monad (t m)) => MonadTrans t where+#else+-- Prior to GHC 8.8 (base-4.13), the Monad class included fail.+-- GHC 8.6 (base-4.12) has MonadFailDesugaring on by default, so there+-- is no need for users defining monad transformers to define fail in+-- the Monad instance of the transformed monad. class MonadTrans t where+#endif     -- | Lift a computation from the argument monad to the constructed monad.-    lift :: Monad m => m a -> t m a+    lift :: (Monad m) => m a -> t m a +{- $conventions+All monad transformer modules except 'Control.Monad.Trans.Maybe'+include the special case of applying the transformer+to 'Data.Functor.Identity.Identity'.  For example,+@'Control.Monad.Trans.State.Lazy.State' s@ is an abbreviation for+@'Control.Monad.Trans.State.Lazy.StateT' s 'Data.Functor.Identity.Identity'@.+As a consequence, operations defined on the monad transformer can also+be used on this special case.++Each monad transformer also comes with an operation @run@/XXX/@T@ to+unwrap the transformer, exposing a computation of the inner monad.+(Currently these functions are defined as field labels, but in a future+major release they may be separate functions.)++All of the monad transformers except 'Control.Monad.Trans.Cont.ContT'+and 'Control.Monad.Trans.Cont.SelectT' are functors on the category+of monads: in addition to defining a mapping of monads, they+also define a mapping from transformations between base monads to+transformations between transformed monads, called @map@/XXX/@T@.+Thus given a monad transformation @t :: M a -> N a@, the combinator+'Control.Monad.Trans.State.Lazy.mapStateT' constructs a monad+transformation++> mapStateT t :: StateT s M a -> StateT s N a++For these monad transformers, 'lift' is a natural transformation in the+category of monads, i.e. for any monad transformation @t :: M a -> N a@,++* @map@/XXX/@T t . 'lift' = 'lift' . t@++Each of the monad transformers introduces relevant operations.+In a sequence of monad transformers, most of these operations.can be+lifted through other transformers using 'lift' or the @map@/XXX/@T@+combinator, but a few with more complex type signatures require+specialized lifting combinators, called @lift@/Op/+(see "Control.Monad.Signatures").+-}++{- $strict++A monad is said to be /strict/ if its '>>=' operation (and therefore also+'>>') is strict in its first argument.  The base monads 'Maybe', @[]@+and 'IO' are strict:++>>> undefined >> Just 2+*** Exception: Prelude.undefined+>>> undefined >> [2]+*** Exception: Prelude.undefined+>>> undefined >> print 2+*** Exception: Prelude.undefined++However, the monads 'Data.Functor.Identity.Identity' and @(->) a@ are not:++>>> undefined >> Identity 2+Identity 2+>>> (undefined >> (+1)) 5+6++In a strict monad you know when each action is executed, but the monad+is not necessarily strict in the return value, or in other components+of the monad, such as a state.  However, you can use 'seq' to create+an action that is strict in the component you want evaluated.+-}+ {- $example1 -One might define a parsing monad by adding a state (the 'String' remaining+The first example is a parser monad in the style of++* \"Monadic parsing in Haskell\", by Graham Hutton and Erik Meijer,+/Journal of Functional Programming/ 8(4):437-444, July 1998+(<http://www.cs.nott.ac.uk/~pszgmh/bib.html#pearl>).++We can define such a parser monad by adding a state (the 'String' remaining to be parsed) to the @[]@ monad, which provides non-determinism:  > import Control.Monad.Trans.State@@ -58,9 +166,8 @@ > type Parser = StateT String []  Then @Parser@ is an instance of @MonadPlus@: monadic sequencing implements-concatenation of parsers, while @mplus@ provides choice.-To use parsers, we need a primitive to run a constructed parser on an-input string:+concatenation of parsers, while @mplus@ provides choice.  To use parsers,+we need a primitive to run a constructed parser on an input string:  > runParser :: Parser a -> String -> [a] > runParser p s = [x | (x, "") <- runStateT p s]@@ -76,14 +183,15 @@  In this example we use the operations @get@ and @put@ from "Control.Monad.Trans.State", which are defined only for monads that are-applications of @StateT@.  Alternatively one could use monad classes-from other packages, which contain methods @get@ and @put@ with types-generalized over all suitable monads.+applications of 'Control.Monad.Trans.State.Lazy.StateT'.  Alternatively one+could use monad classes from the @mtl@ package or similar, which contain+methods @get@ and @put@ with types generalized over all suitable monads. -}  {- $example2 -We can define a parser that also counts by adding a @WriterT@ transformer:+We can define a parser that also counts by adding a+'Control.Monad.Trans.Writer.Lazy.WriterT' transformer:  > import Control.Monad.Trans.Class > import Control.Monad.Trans.State@@ -98,8 +206,9 @@ > runParser :: Parser a -> String -> [(a, Int)] > runParser p s = [(x, n) | ((x, Sum n), "") <- runStateT (runWriterT p) s] -To define @item@ parser, we need to lift the @StateT@ operations through-the @WriterT@ transformers.+To define the @item@ parser, we need to lift the+'Control.Monad.Trans.State.Lazy.StateT' operations through the+'Control.Monad.Trans.Writer.Lazy.WriterT' transformer.  > item :: Parser Char > item = do@@ -109,10 +218,10 @@  In this case, we were able to do this with 'lift', but operations with more complex types require special lifting functions, which are provided-by monad transformers for which they can be implemented.  If you use-one of packages of monad classes, this lifting is handled automatically-by the instances of the classes, and you need only use the generalized-methods @get@ and @put@.+by monad transformers for which they can be implemented.  If you use the+monad classes of the @mtl@ package or similar, this lifting is handled+automatically by the instances of the classes, and you need only use+the generalized methods @get@ and @put@.  We can also define a primitive using the Writer: @@ -120,4 +229,73 @@ > tick = tell (Sum 1)  Then the parser will keep track of how many @tick@s it executes.+-}++{- $example3++This example is a cut-down version of the one in++* \"Monad Transformers and Modular Interpreters\",+by Sheng Liang, Paul Hudak and Mark Jones in /POPL'95/+(<http://web.cecs.pdx.edu/~mpj/pubs/modinterp.html>).++Suppose we want to define an interpreter that can do I\/O and has+exceptions, an environment and a modifiable store.  We can define+a monad that supports all these things as a stack of monad transformers:++> import Control.Monad.Trans.Class+> import Control.Monad.Trans.State+> import qualified Control.Monad.Trans.Reader as R+> import qualified Control.Monad.Trans.Except as E+> import Control.Monad.IO.Class+>+> type InterpM = StateT Store (R.ReaderT Env (E.ExceptT Err IO))++for suitable types @Store@, @Env@ and @Err@.++Now we would like to be able to use the operations associated with each+of those monad transformers on @InterpM@ actions.  Since the uppermost+monad transformer of @InterpM@ is 'Control.Monad.Trans.State.Lazy.StateT',+it already has the state operations @get@ and @set@.++The first of the 'Control.Monad.Trans.Reader.ReaderT' operations,+'Control.Monad.Trans.Reader.ask', is a simple action, so we can lift it+through 'Control.Monad.Trans.State.Lazy.StateT' to @InterpM@ using 'lift':++> ask :: InterpM Env+> ask = lift R.ask++The other 'Control.Monad.Trans.Reader.ReaderT' operation,+'Control.Monad.Trans.Reader.local', has a suitable type for lifting+using 'Control.Monad.Trans.State.Lazy.mapStateT':++> local :: (Env -> Env) -> InterpM a -> InterpM a+> local f = mapStateT (R.local f)++We also wish to lift the operations of 'Control.Monad.Trans.Except.ExceptT'+through both 'Control.Monad.Trans.Reader.ReaderT' and+'Control.Monad.Trans.State.Lazy.StateT'.  For the operation+'Control.Monad.Trans.Except.throwE', we know @throwE e@ is a simple+action, so we can lift it through the two monad transformers to @InterpM@+with two 'lift's:++> throwE :: Err -> InterpM a+> throwE e = lift (lift (E.throwE e))++The 'Control.Monad.Trans.Except.catchE' operation has a more+complex type, so we need to use the special-purpose lifting function+@liftCatch@ provided by most monad transformers.  Here we use+the 'Control.Monad.Trans.Reader.ReaderT' version followed by the+'Control.Monad.Trans.State.Lazy.StateT' version:++> catchE :: InterpM a -> (Err -> InterpM a) -> InterpM a+> catchE = liftCatch (R.liftCatch E.catchE)++We could lift 'IO' actions to @InterpM@ using three 'lift's, but @InterpM@+is automatically an instance of 'Control.Monad.IO.Class.MonadIO',+so we can use 'Control.Monad.IO.Class.liftIO' instead:++> putStr :: String -> InterpM ()+> putStr s = liftIO (Prelude.putStr s)+ -}
Control/Monad/Trans/Cont.hs view
@@ -1,15 +1,30 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Cont -- Copyright   :  (c) The University of Glasgow 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable -- -- Continuation monads. --+-- Delimited continuation operators are taken from Kenichi Asai and Oleg+-- Kiselyov's tutorial at CW 2011, \"Introduction to programming with+-- shift and reset\" (<http://okmij.org/ftp/continuations/#tutorial>).+-- -----------------------------------------------------------------------------  module Control.Monad.Trans.Cont (@@ -17,13 +32,19 @@     Cont,     cont,     runCont,+    evalCont,     mapCont,     withCont,+    -- ** Delimited continuations+    reset, shift,     -- * The ContT monad transformer     ContT(..),+    evalContT,     mapContT,     withContT,     callCC,+    -- ** Delimited continuations+    resetT, shiftT,     -- * Lifting other operations     liftLocal,   ) where@@ -32,13 +53,21 @@ import Control.Monad.Trans.Class import Data.Functor.Identity +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative-import Control.Monad+#endif+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  {- |-Continuation monad.-@Cont r a@ is a CPS computation that produces an intermediate result-of type @a@ within a CPS computation whose final result type is @r@.+The continuation monad, which is non-strict.+@Cont r a@ is a CPS ("continuation-passing style") computation that produces an+intermediate result of type @a@ within a CPS computation whose final result type+is @r@.  The @return@ function simply creates a continuation which passes the value on. @@ -47,62 +76,144 @@ type Cont r = ContT r Identity  -- | Construct a continuation-passing computation from a function.--- (The inverse of 'runCont'.)+-- (The inverse of 'runCont') cont :: ((a -> r) -> r) -> Cont r a-cont f = ContT (\ k -> Identity (f (runIdentity . k)))+cont f = ContT (\ c -> Identity (f (runIdentity . c)))+{-# INLINE cont #-} --- | Runs a CPS computation, returns its result after applying the final--- continuation to it.--- (The inverse of 'cont'.)-runCont :: Cont r a	-- ^ continuation computation (@Cont@).-    -> (a -> r)		-- ^ the final continuation, which produces-			-- the final result (often 'id').+-- | The result of running a CPS computation with a given final continuation.+-- (The inverse of 'cont')+runCont+    :: Cont r a         -- ^ continuation computation (@Cont@).+    -> (a -> r)         -- ^ the final continuation, which produces+                        -- the final result (often 'id').     -> r runCont m k = runIdentity (runContT m (Identity . k))+{-# INLINE runCont #-} +-- | The result of running a CPS computation with the identity as the+-- final continuation.+--+-- * @'evalCont' ('return' x) = x@+evalCont :: Cont r r -> r+evalCont m = runIdentity (evalContT m)+{-# INLINE evalCont #-}++-- | Apply a function to transform the result of a continuation-passing+-- computation.+--+-- * @'runCont' ('mapCont' f m) = f . 'runCont' m@ mapCont :: (r -> r) -> Cont r a -> Cont r a mapCont f = mapContT (Identity . f . runIdentity)+{-# INLINE mapCont #-} +-- | Apply a function to transform the continuation passed to a CPS+-- computation.+--+-- * @'runCont' ('withCont' f m) = 'runCont' m . f@ withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b withCont f = withContT ((Identity .) . f . (runIdentity .))+{-# INLINE withCont #-} -{- |-The continuation monad transformer.-Can be used to add continuation handling to other monads.--}+-- | @'reset' m@ delimits the continuation of any 'shift' inside @m@.+--+-- * @'reset' ('return' m) = 'return' m@+--+reset :: Cont r r -> Cont r' r+reset = resetT+{-# INLINE reset #-}++-- | @'shift' f@ captures the continuation up to the nearest enclosing+-- 'reset' and passes it to @f@:+--+-- * @'reset' ('shift' f >>= k) = 'reset' (f ('evalCont' . k))@+--+shift :: ((a -> r) -> Cont r r) -> Cont r a+shift f = shiftT (f . (runIdentity .))+{-# INLINE shift #-}++-- | The continuation monad transformer.+-- Can be used to add continuation handling to any type constructor:+-- the 'Monad' instance and most of the operations do not require @m@+-- to be a monad.+--+-- 'ContT' is not a functor on the category of monads, and many operations+-- cannot be lifted through it.+--+-- @ContT r m@ is strict if and only if @m@ is. newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif +-- | The result of running a CPS computation with 'return' as the+-- final continuation.+--+-- * @'evalContT' ('lift' m) = m@+evalContT :: (Monad m) => ContT r m r -> m r+evalContT m = runContT m return+{-# INLINE evalContT #-}++-- | Apply a function to transform the result of a continuation-passing+-- computation.  This has a more restricted type than the @map@ operations+-- for other monad transformers, because 'ContT' does not define a functor+-- in the category of monads.+--+-- * @'runContT' ('mapContT' f m) = f . 'runContT' m@ mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a mapContT f m = ContT $ f . runContT m+{-# INLINE mapContT #-} +-- | Apply a function to transform the continuation passed to a CPS+-- computation.+--+-- * @'runContT' ('withContT' f m) = 'runContT' m . f@ withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b withContT f m = ContT $ runContT m . f+{-# INLINE withContT #-}  instance Functor (ContT r m) where-    fmap f m = ContT $ \c -> runContT m (c . f)+    fmap f m = ContT $ \ c -> runContT m (c . f)+    {-# INLINE fmap #-}  instance Applicative (ContT r m) where-    pure a  = ContT ($ a)-    f <*> v = ContT $ \ k -> runContT f $ \ g -> runContT v (k . g)+    pure x  = ContT ($ x)+    {-# INLINE pure #-}+    f <*> v = ContT $ \ c -> runContT f $ \ g -> runContT v (c . g)+    {-# INLINE (<*>) #-}+    m *> k = m >>= \_ -> k+    {-# INLINE (*>) #-}  instance Monad (ContT r m) where-    return a = ContT ($ a)-    m >>= k  = ContT $ \c -> runContT m (\a -> runContT (k a) c)+#if !(MIN_VERSION_base(4,8,0))+    return x = ContT ($ x)+    {-# INLINE return #-}+#endif+    m >>= k  = ContT $ \ c -> runContT m (\ x -> runContT (k x) c)+    {-# INLINE (>>=) #-} +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where+    fail msg = ContT $ \ _ -> Fail.fail msg+    {-# INLINE fail #-}+#endif+ instance MonadTrans (ContT r) where     lift m = ContT (m >>=)+    {-# INLINE lift #-}  instance (MonadIO m) => MonadIO (ContT r m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-}  -- | @callCC@ (call-with-current-continuation) calls its argument -- function, passing it the current continuation.  It provides -- an escape continuation mechanism for use with continuation -- monads.  Escape continuations one allow to abort the current--- computation and return a value immediately.  They achieve a--- similar effect to 'Control.Monad.Trans.Error.throwError'--- and 'Control.Monad.Trans.Error.catchError' within an--- 'Control.Monad.Trans.Error.ErrorT' monad.  The advantage of this+-- computation and return a value immediately.  They achieve+-- a similar effect to 'Control.Monad.Trans.Except.throwE'+-- and 'Control.Monad.Trans.Except.catchE' within an+-- 'Control.Monad.Trans.Except.ExceptT' monad.  The advantage of this -- function over calling 'return' is that it makes the continuation -- explicit, allowing more flexibility and better control. --@@ -111,11 +222,30 @@ -- within its scope will escape from the computation, even if it is many -- layers deep within nested computations. callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a-callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c+callCC f = ContT $ \ c -> runContT (f (\ x -> ContT $ \ _ -> c x)) c+{-# INLINE callCC #-} +-- | @'resetT' m@ delimits the continuation of any 'shiftT' inside @m@.+--+-- * @'resetT' ('lift' m) = 'lift' m@+--+resetT :: (Monad m) => ContT r m r -> ContT r' m r+resetT = lift . evalContT+{-# INLINE resetT #-}++-- | @'shiftT' f@ captures the continuation up to the nearest enclosing+-- 'resetT' and passes it to @f@:+--+-- * @'resetT' ('shiftT' f >>= k) = 'resetT' (f ('evalContT' . k))@+--+shiftT :: (Monad m) => ((a -> m r) -> ContT r m r) -> ContT r m a+shiftT f = ContT (evalContT . f)+{-# INLINE shiftT #-}+ -- | @'liftLocal' ask local@ yields a @local@ function for @'ContT' r m@.-liftLocal :: Monad m => m r' -> ((r' -> r') -> m r -> m r) ->+liftLocal :: (Monad m) => m r' -> ((r' -> r') -> m r -> m r) ->     (r' -> r') -> ContT r m a -> ContT r m a-liftLocal ask local f m = ContT $ \c -> do+liftLocal ask local f m = ContT $ \ c -> do     r <- ask     local f (runContT m (local (const r) . c))+{-# INLINE liftLocal #-}
− Control/Monad/Trans/Error.hs 
@@ -1,245 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Trans.Error--- Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,---                (c) Jeff Newbern 2003-2006,---                (c) Andriy Palamarchuk 2006--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  portable------ This monad transformer adds the ability to fail or throw exceptions--- to a monad.------ A sequence of actions succeeds, producing a value, only if all the--- actions in the sequence are successful.  If one fails with an error,--- the rest of the sequence is skipped and the composite action fails--- with that error.------ If the value of the error is not required, the variant in--- "Control.Monad.Trans.Maybe" may be used instead.--------------------------------------------------------------------------------module Control.Monad.Trans.Error (-    -- * The ErrorT monad transformer-    Error(..),-    ErrorList(..),-    ErrorT(..),-    mapErrorT,-    -- * Error operations-    throwError,-    catchError,-    -- * Lifting other operations-    liftCallCC,-    liftListen,-    liftPass,-    -- * Examples-    -- $examples-  ) where--import Control.Monad.IO.Class-import Control.Monad.Trans.Class--import Control.Applicative-import Control.Exception (IOException)-import Control.Monad-import Control.Monad.Fix-import Control.Monad.Instances ()-import System.IO--instance MonadPlus IO where-    mzero       = ioError (userError "mzero")-    m `mplus` n = m `catch` \_ -> n---- | An exception to be thrown.------ Minimal complete definition: 'noMsg' or 'strMsg'.-class Error a where-    -- | Creates an exception without a message.-    -- The default implementation is @'strMsg' \"\"@.-    noMsg  :: a-    -- | Creates an exception with a message.-    -- The default implementation of @'strMsg' s@ is 'noMsg'.-    strMsg :: String -> a--    noMsg    = strMsg ""-    strMsg _ = noMsg--instance Error IOException where-    strMsg = userError---- | A string can be thrown as an error.-instance ErrorList a => Error [a] where-    strMsg = listMsg---- | Workaround so that we can have a Haskell 98 instance @'Error' 'String'@.-class ErrorList a where-    listMsg :: String -> [a]--instance ErrorList Char where-    listMsg = id---- ------------------------------------------------------------------------------ Our parameterizable error monad--#if !(MIN_VERSION_base(4,2,1))---- These instances are in base-4.3--instance Applicative (Either e) where-    pure          = Right-    Left  e <*> _ = Left e-    Right f <*> r = fmap f r--instance Monad (Either e) where-    return        = Right-    Left  l >>= _ = Left l-    Right r >>= k = k r--instance MonadFix (Either e) where-    mfix f = let-        a = f $ case a of-            Right r -> r-            _       -> error "empty mfix argument"-        in a--#endif /* base to 4.2.0.x */--instance (Error e) => Alternative (Either e) where-    empty        = Left noMsg-    Left _ <|> n = n-    m      <|> _ = m--instance (Error e) => MonadPlus (Either e) where-    mzero            = Left noMsg-    Left _ `mplus` n = n-    m      `mplus` _ = m---- | The error monad transformer. It can be used to add error handling--- to other monads.------ The @ErrorT@ Monad structure is parameterized over two things:------ * e - The error type.------ * m - The inner monad.------ The 'return' function yields a successful computation, while @>>=@--- sequences two subcomputations, failing on the first error.-newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }---- | Map the unwrapped computation using the given function.------ * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m@)-mapErrorT :: (m (Either e a) -> n (Either e' b))-          -> ErrorT e m a-          -> ErrorT e' n b-mapErrorT f m = ErrorT $ f (runErrorT m)--instance (Functor m) => Functor (ErrorT e m) where-    fmap f = ErrorT . fmap (fmap f) . runErrorT--instance (Functor m, Monad m) => Applicative (ErrorT e m) where-    pure a  = ErrorT $ return (Right a)-    f <*> v = ErrorT $ do-        mf <- runErrorT f-        case mf of-            Left  e -> return (Left e)-            Right k -> do-                mv <- runErrorT v-                case mv of-                    Left  e -> return (Left e)-                    Right x -> return (Right (k x))--instance (Functor m, Monad m, Error e) => Alternative (ErrorT e m) where-    empty = mzero-    (<|>) = mplus--instance (Monad m, Error e) => Monad (ErrorT e m) where-    return a = ErrorT $ return (Right a)-    m >>= k  = ErrorT $ do-        a <- runErrorT m-        case a of-            Left  l -> return (Left l)-            Right r -> runErrorT (k r)-    fail msg = ErrorT $ return (Left (strMsg msg))--instance (Monad m, Error e) => MonadPlus (ErrorT e m) where-    mzero       = ErrorT $ return (Left noMsg)-    m `mplus` n = ErrorT $ do-        a <- runErrorT m-        case a of-            Left  _ -> runErrorT n-            Right r -> return (Right r)--instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where-    mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of-        Right r -> r-        _       -> error "empty mfix argument"--instance (Error e) => MonadTrans (ErrorT e) where-    lift m = ErrorT $ do-        a <- m-        return (Right a)--instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where-    liftIO = lift . liftIO---- | Signal an error value @e@.------ * @'runErrorT' ('throwErrorT' e) = 'return' ('Left' e)@-throwError :: (Monad m, Error e) => e -> ErrorT e m a-throwError l = ErrorT $ return (Left l)---- | Handle an error.-catchError :: (Monad m, Error e) =>-    ErrorT e m a                -- ^ the inner computation-    -> (e -> ErrorT e m a)      -- ^ a handler for errors in the inner-                                -- computation-    -> ErrorT e m a-m `catchError` h = ErrorT $ do-    a <- runErrorT m-    case a of-        Left  l -> runErrorT (h l)-        Right r -> return (Right r)---- | Lift a @callCC@ operation to the new monad.-liftCallCC :: (((Either e a -> m (Either e b)) -> m (Either e a)) ->-    m (Either e a)) -> ((a -> ErrorT e m b) -> ErrorT e m a) -> ErrorT e m a-liftCallCC callCC f = ErrorT $-    callCC $ \c ->-    runErrorT (f (\a -> ErrorT $ c (Right a)))---- | Lift a @listen@ operation to the new monad.-liftListen :: Monad m =>-    (m (Either e a) -> m (Either e a,w)) -> ErrorT e m a -> ErrorT e m (a,w)-liftListen listen = mapErrorT $ \ m -> do-    (a, w) <- listen m-    return $! fmap (\ r -> (r, w)) a---- | Lift a @pass@ operation to the new monad.-liftPass :: Monad m => (m (Either e a,w -> w) -> m (Either e a)) ->-    ErrorT e m (a,w -> w) -> ErrorT e m a-liftPass pass = mapErrorT $ \ m -> pass $ do-    a <- m-    return $! case a of-        Left  l      -> (Left  l, id)-        Right (r, f) -> (Right r, f)--{- $examples--Wrapping an IO action that can throw an error @e@:--> type ErrorWithIO e a = ErrorT e IO a-> ==> ErrorT (IO (Either e a))--An IO monad wrapped in @StateT@ inside of @ErrorT@:--> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a-> ==> ErrorT (StateT s IO (Either e a))-> ==> ErrorT (StateT (s -> IO (Either e a,s)))---}
+ Control/Monad/Trans/Except.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Except+-- Copyright   :  (C) 2013 Ross Paterson+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- This monad transformer extends a monad with the ability to throw+-- and catch exceptions.+--+-- A sequence of actions terminates normally, producing a value,+-- only if none of the actions in the sequence throws an exception.+-- If one throws an exception, the rest of the sequence is skipped and+-- the composite action exits with that exception.+--+-- If the value of the exception is not required, the variant in+-- "Control.Monad.Trans.Maybe" may be used instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Except (+    -- * The Except monad+    Except,+    except,+    runExcept,+    mapExcept,+    withExcept,+    -- * The ExceptT monad transformer+    ExceptT(..),+    mapExceptT,+    withExceptT,+    -- * Exception operations+    throwE,+    catchE,+    handleE,+    tryE,+    finallyE,+    onE,+    -- * Lifting other operations+    liftCallCC,+    liftListen,+    liftPass,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Signatures+import Control.Monad.Trans.Class+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Fix+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (Monoid(mempty, mappend))+import Data.Traversable (Traversable(traverse))+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | The parameterizable exception monad, which is strict.+--+-- Computations are either exceptions (of any type) or normal values.+-- These computations are plain values, and are unrelated to the+-- "Control.Exception" mechanism, which is tied to the 'IO' monad.+--+-- The 'return' function returns a normal value, while @>>=@ exits on+-- the first exception.  For a variant that continues after an error+-- and collects all the errors, see 'Control.Applicative.Lift.Errors'.+type Except e = ExceptT e Identity++-- | Constructor for computations in the exception monad.+-- (The inverse of 'runExcept').+except :: (Monad m) => Either e a -> ExceptT e m a+except m = ExceptT (return m)+{-# INLINE except #-}++-- | Extractor for computations in the exception monad.+-- (The inverse of 'except').+runExcept :: Except e a -> Either e a+runExcept (ExceptT m) = runIdentity m+{-# INLINE runExcept #-}++-- | Map the unwrapped computation using the given function.+--+-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@+mapExcept :: (Either e a -> Either e' b)+        -> Except e a+        -> Except e' b+mapExcept f = mapExceptT (Identity . f . runIdentity)+{-# INLINE mapExcept #-}++-- | Transform any exceptions thrown by the computation using the given+-- function (a specialization of 'withExceptT').+withExcept :: (e -> e') -> Except e a -> Except e' a+withExcept = withExceptT+{-# INLINE withExcept #-}++-- | A monad transformer that adds exceptions to other monads.+--+-- @ExceptT@ constructs a strict monad parameterized over two things:+--+-- * e - An arbitrary exception type.+--+-- * m - The inner monad.+--+-- The monadic computations are a plain values.  They are unrelated to+-- the "Control.Exception" mechanism, which is tied to the 'IO' monad.+--+-- The 'return' function yields a computation that produces the given+-- value, while @>>=@ sequences two subcomputations, exiting on the+-- first exception.+newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, Generic1)+#elif __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where+    liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y+    {-# INLINE liftEq #-}++instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where+    liftCompare comp (ExceptT x) (ExceptT y) =+        liftCompare (liftCompare comp) x y+    {-# INLINE liftCompare #-}++instance (Read e, Read1 m) => Read1 (ExceptT e m) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++instance (Show e, Show1 m) => Show1 (ExceptT e m) where+    liftShowsPrec sp sl d (ExceptT m) =+        showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a)+    where (==) = eq1+instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a)+    where compare = compare1+instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where+    readsPrec = readsPrec1+instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where+    showsPrec = showsPrec1++-- | Map the unwrapped computation using the given function.+--+-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@+mapExceptT :: (m (Either e a) -> n (Either e' b))+        -> ExceptT e m a+        -> ExceptT e' n b+mapExceptT f m = ExceptT $ f (runExceptT m)+{-# INLINE mapExceptT #-}++-- | Transform any exceptions thrown by the computation using the+-- given function.+withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a+withExceptT f = mapExceptT $ fmap $ either (Left . f) Right+{-# INLINE withExceptT #-}++instance (Functor m) => Functor (ExceptT e m) where+    fmap f = ExceptT . fmap (fmap f) . runExceptT+    {-# INLINE fmap #-}++instance (Foldable f) => Foldable (ExceptT e f) where+    foldMap f (ExceptT a) = foldMap (either (const mempty) f) a+    {-# INLINE foldMap #-}++instance (Traversable f) => Traversable (ExceptT e f) where+    traverse f (ExceptT a) =+        ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a+    {-# INLINE traverse #-}++instance (Functor m, Monad m) => Applicative (ExceptT e m) where+    pure a = ExceptT $ return (Right a)+    {-# INLINE pure #-}+    ExceptT f <*> ExceptT v = ExceptT $ do+        mf <- f+        case mf of+            Left e -> return (Left e)+            Right k -> do+                mv <- v+                case mv of+                    Left e -> return (Left e)+                    Right x -> return (Right (k x))+    {-# INLINEABLE (<*>) #-}+    m *> k = m >>= \_ -> k+    {-# INLINE (*>) #-}++instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where+    empty = ExceptT $ return (Left mempty)+    {-# INLINE empty #-}+    ExceptT mx <|> ExceptT my = ExceptT $ do+        ex <- mx+        case ex of+            Left e -> liftM (either (Left . mappend e) Right) my+            Right x -> return (Right x)+    {-# INLINEABLE (<|>) #-}++instance (Monad m) => Monad (ExceptT e m) where+#if !(MIN_VERSION_base(4,8,0))+    return a = ExceptT $ return (Right a)+    {-# INLINE return #-}+#endif+    m >>= k = ExceptT $ do+        a <- runExceptT m+        case a of+            Left e -> return (Left e)+            Right x -> runExceptT (k x)+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail = ExceptT . fail+    {-# INLINE fail #-}+#endif++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where+    fail = ExceptT . Fail.fail+    {-# INLINE fail #-}+#endif++instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where+    mzero = ExceptT $ return (Left mempty)+    {-# INLINE mzero #-}+    ExceptT mx `mplus` ExceptT my = ExceptT $ do+        ex <- mx+        case ex of+            Left e -> liftM (either (Left . mappend e) Right) my+            Right x -> return (Right x)+    {-# INLINEABLE mplus #-}++instance (MonadFix m) => MonadFix (ExceptT e m) where+    mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id))+      where bomb = error "mfix (ExceptT): inner computation returned Left value"+    {-# INLINE mfix #-}++instance MonadTrans (ExceptT e) where+    lift = ExceptT . liftM Right+    {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (ExceptT e m) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}++#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (ExceptT e m) where+    mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b+    {-# INLINE mzipWith #-}+#endif++#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (ExceptT e m) where+    contramap f = ExceptT . contramap (fmap f) . runExceptT+    {-# INLINE contramap #-}+#endif++-- | Signal an exception value @e@.+--+-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@+--+-- * @'throwE' e >>= m = 'throwE' e@+throwE :: (Monad m) => e -> ExceptT e m a+throwE = ExceptT . return . Left+{-# INLINE throwE #-}++-- | Handle an exception.+--+-- * @'catchE' ('lift' m) h = 'lift' m@+--+-- * @'catchE' ('throwE' e) h = h e@+catchE :: (Monad m) =>+    ExceptT e m a               -- ^ the inner computation+    -> (e -> ExceptT e' m a)    -- ^ a handler for exceptions in the inner+                                -- computation+    -> ExceptT e' m a+m `catchE` h = ExceptT $ do+    a <- runExceptT m+    case a of+        Left  l -> runExceptT (h l)+        Right r -> return (Right r)+{-# INLINE catchE #-}++-- | The same as @'flip' 'catchE'@, which is useful in situations where+-- the code for the handler is shorter.+handleE :: Monad m => (e -> ExceptT e' m a) -> ExceptT e m a -> ExceptT e' m a+handleE = flip catchE+{-# INLINE handleE #-}++-- | Similar to 'catchE', but returns an 'Either' result which is+-- @('Right' a)@ if no exception was thown, or @('Left' ex)@ if an+-- exception @ex@ was thrown.+tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)+tryE m = catchE (liftM Right m) (return . Left)+{-# INLINE tryE #-}++-- | @'finallyE' a b@ executes computation @a@ followed by computation @b@,+-- even if @a@ exits early by throwing an exception.  In the latter case,+-- the exception is re-thrown after @b@ has been executed.+finallyE :: Monad m => ExceptT e m a -> ExceptT e m () -> ExceptT e m a+finallyE m closer = do+    res <- tryE m+    closer+    either throwE return res+{-# INLINE finallyE #-}++-- | If the first action succeeds, return its value, ignoring the+-- second action.  If the first action throws an exception, run the+-- second action and then throw an exception, either the one thrown by+-- the second action, if any, or the one thrown by the first action.+onE :: (Monad m) => ExceptT e m a -> ExceptT e m b -> ExceptT e m a+onE action1 action2 = action1 `catchE` \ e -> action2 >> throwE e+{-# INLINE onE #-}++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b+liftCallCC callCC f = ExceptT $+    callCC $ \ c ->+    runExceptT (f (\ a -> ExceptT $ c (Right a)))+{-# INLINE liftCallCC #-}++-- | Lift a @listen@ operation to the new monad.+liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a+liftListen listen = mapExceptT $ \ m -> do+    (a, w) <- listen m+    return $! fmap (\ r -> (r, w)) a+{-# INLINE liftListen #-}++-- | Lift a @pass@ operation to the new monad.+liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a+liftPass pass = mapExceptT $ \ m -> pass $ do+    a <- m+    return $! case a of+        Left l -> (Left l, id)+        Right (r, f) -> (Right r, f)+{-# INLINE liftPass #-}
Control/Monad/Trans/Identity.hs view
@@ -1,10 +1,21 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Identity -- Copyright   :  (c) 2007 Magnus Therning -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable --@@ -22,56 +33,176 @@     liftCallCC,   ) where -import Control.Applicative-import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Signatures import Control.Monad.Trans.Class (MonadTrans(lift))+#if MIN_VERSION_base(4,18,0)+import Data.Foldable1 (Foldable1(foldMap1))+#endif+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif +import Control.Applicative+import Control.Monad (MonadPlus(mzero, mplus))+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Fix (MonadFix(mfix))+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+import Data.Foldable+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Traversable (Traversable(traverse))+#endif+import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length)+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif+ -- | The trivial monad transformer, which maps a monad to an equivalent monad.-newtype IdentityT m a = IdentityT { runIdentityT :: m a }+newtype IdentityT f a = IdentityT { runIdentityT :: f a }+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, Generic1)+#elif __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif +instance (Eq1 f) => Eq1 (IdentityT f) where+    liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y+    {-# INLINE liftEq #-}++instance (Ord1 f) => Ord1 (IdentityT f) where+    liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y+    {-# INLINE liftCompare #-}++instance (Read1 f) => Read1 (IdentityT f) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT++instance (Show1 f) => Show1 (IdentityT f) where+    liftShowsPrec sp sl d (IdentityT m) =+        showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m++instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1+instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1+ instance (Functor m) => Functor (IdentityT m) where     fmap f = mapIdentityT (fmap f)+    {-# INLINE fmap #-} +instance (Foldable f) => Foldable (IdentityT f) where+    foldMap f (IdentityT t) = foldMap f t+    {-# INLINE foldMap #-}+    foldr f z (IdentityT t) = foldr f z t+    {-# INLINE foldr #-}+    foldl f z (IdentityT t) = foldl f z t+    {-# INLINE foldl #-}+    foldr1 f (IdentityT t) = foldr1 f t+    {-# INLINE foldr1 #-}+    foldl1 f (IdentityT t) = foldl1 f t+    {-# INLINE foldl1 #-}+#if MIN_VERSION_base(4,8,0)+    null (IdentityT t) = null t+    length (IdentityT t) = length t+#endif++#if MIN_VERSION_base(4,18,0)+instance (Foldable1 m) => Foldable1 (IdentityT m) where+    foldMap1 f (IdentityT t) = foldMap1 f t+    {-# INLINE foldMap1 #-}+#endif++instance (Traversable f) => Traversable (IdentityT f) where+    traverse f (IdentityT a) = IdentityT <$> traverse f a+    {-# INLINE traverse #-}+ instance (Applicative m) => Applicative (IdentityT m) where     pure x = IdentityT (pure x)+    {-# INLINE pure #-}     (<*>) = lift2IdentityT (<*>)- +    {-# INLINE (<*>) #-}+    (*>) = lift2IdentityT (*>)+    {-# INLINE (*>) #-}+    (<*) = lift2IdentityT (<*)+    {-# INLINE (<*) #-}+ instance (Alternative m) => Alternative (IdentityT m) where     empty = IdentityT empty+    {-# INLINE empty #-}     (<|>) = lift2IdentityT (<|>)+    {-# INLINE (<|>) #-}  instance (Monad m) => Monad (IdentityT m) where+#if !(MIN_VERSION_base(4,8,0))     return = IdentityT . return+    {-# INLINE return #-}+#endif     m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))     fail msg = IdentityT $ fail msg- +    {-# INLINE fail #-}+#endif++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where+    fail msg = IdentityT $ Fail.fail msg+    {-# INLINE fail #-}+#endif+ instance (MonadPlus m) => MonadPlus (IdentityT m) where     mzero = IdentityT mzero+    {-# INLINE mzero #-}     mplus = lift2IdentityT mplus+    {-# INLINE mplus #-} +instance (MonadFix m) => MonadFix (IdentityT m) where+    mfix f = IdentityT (mfix (runIdentityT . f))+    {-# INLINE mfix #-}+ instance (MonadIO m) => MonadIO (IdentityT m) where     liftIO = IdentityT . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (IdentityT m) where+    mzipWith f = lift2IdentityT (mzipWith f)+    {-# INLINE mzipWith #-}+#endif+ instance MonadTrans IdentityT where     lift = IdentityT+    {-# INLINE lift #-} +#if MIN_VERSION_base(4,12,0)+instance (Contravariant f) => Contravariant (IdentityT f) where+    contramap f = IdentityT . contramap f . runIdentityT+    {-# INLINE contramap #-}+#endif+ -- | Lift a unary operation to the new monad. mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b mapIdentityT f = IdentityT . f . runIdentityT+{-# INLINE mapIdentityT #-}  -- | Lift a binary operation to the new monad. lift2IdentityT ::     (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b))+{-# INLINE lift2IdentityT #-}  -- | Lift a @callCC@ operation to the new monad.-liftCallCC :: (((a -> m b) -> m a) ->-    m a) -> ((a -> IdentityT m b) -> IdentityT m a) -> IdentityT m a+liftCallCC :: CallCC m a b -> CallCC (IdentityT m) a b liftCallCC callCC f =     IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c))+{-# INLINE liftCallCC #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m a -> (e -> m a) -> m a) ->-    IdentityT m a -> (e -> IdentityT m a) -> IdentityT m a+-- | Lift a @catchE@ operation to the new monad.+liftCatch :: Catch e m a -> Catch e (IdentityT m) a liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h)+{-# INLINE liftCatch #-}
− Control/Monad/Trans/List.hs 
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Trans.List--- Copyright   :  (c) Andy Gill 2001,---                (c) Oregon Graduate Institute of Science and Technology, 2001--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  portable------ The ListT monad transformer, adding backtracking to a given monad,--- which must be commutative.--------------------------------------------------------------------------------module Control.Monad.Trans.List (-    -- * The ListT monad transformer-    ListT(..),-    mapListT,-    -- * Lifting other operations-    liftCallCC,-    liftCatch,-  ) where--import Control.Monad.IO.Class-import Control.Monad.Trans.Class--import Control.Applicative-import Control.Monad---- | Parameterizable list monad, with an inner monad.------ /Note:/ this does not yield a monad unless the argument monad is commutative.-newtype ListT m a = ListT { runListT :: m [a] }---- | Map between 'ListT' computations.------ * @'runListT' ('mapListT' f m) = f ('runListT' m@)-mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b-mapListT f m = ListT $ f (runListT m)--instance (Functor m) => Functor (ListT m) where-    fmap f = mapListT $ fmap $ map f--instance (Applicative m) => Applicative (ListT m) where-    pure a  = ListT $ pure [a]-    f <*> v = ListT $ (<*>) <$> runListT f <*> runListT v--instance (Applicative m) => Alternative (ListT m) where-    empty   = ListT $ pure []-    m <|> n = ListT $ (++) <$> runListT m <*> runListT n--instance (Monad m) => Monad (ListT m) where-    return a = ListT $ return [a]-    m >>= k  = ListT $ do-        a <- runListT m-        b <- mapM (runListT . k) a-        return (concat b)-    fail _ = ListT $ return []--instance (Monad m) => MonadPlus (ListT m) where-    mzero       = ListT $ return []-    m `mplus` n = ListT $ do-        a <- runListT m-        b <- runListT n-        return (a ++ b)--instance MonadTrans ListT where-    lift m = ListT $ do-        a <- m-        return [a]--instance (MonadIO m) => MonadIO (ListT m) where-    liftIO = lift . liftIO---- | Lift a @callCC@ operation to the new monad.-liftCallCC :: ((([a] -> m [b]) -> m [a]) -> m [a]) ->-    ((a -> ListT m b) -> ListT m a) -> ListT m a-liftCallCC callCC f = ListT $-    callCC $ \c ->-    runListT (f (\a -> ListT $ c [a]))---- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m [a] -> (e -> m [a]) -> m [a]) ->-    ListT m a -> (e -> ListT m a) -> ListT m a-liftCatch catchError m h = ListT $ runListT m-    `catchError` \e -> runListT (h e)
Control/Monad/Trans/Maybe.hs view
@@ -1,27 +1,40 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Maybe -- Copyright   :  (c) 2007 Yitzak Gale, Eric Kidd -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- The 'MaybeT' monad transformer adds the ability to fail to a monad.+-- The 'MaybeT' monad transformer extends a monad with the ability to exit+-- the computation without returning a value. ----- A sequence of actions succeeds, producing a value, only if all the--- actions in the sequence are successful.  If one fails, the rest of--- the sequence is skipped and the composite action fails.+-- A sequence of actions produces a value only if all the actions in+-- the sequence do.  If one exits, the rest of the sequence is skipped+-- and the composite action exits. ----- For a variant allowing a range of error values, see--- "Control.Monad.Trans.Error".+-- For a variant allowing a range of exception values, see+-- "Control.Monad.Trans.Except". -----------------------------------------------------------------------------  module Control.Monad.Trans.Maybe (     -- * The MaybeT monad transformer     MaybeT(..),     mapMaybeT,+    -- * Monad transformations+    hoistMaybe,+    maybeToExceptT,+    exceptToMaybeT,     -- * Lifting other operations     liftCallCC,     liftCatch,@@ -30,81 +43,215 @@   ) where  import Control.Monad.IO.Class+import Control.Monad.Signatures import Control.Monad.Trans.Class+import Control.Monad.Trans.Except (ExceptT(..))+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif  import Control.Applicative-import Control.Monad (MonadPlus(mzero, mplus), liftM, ap)+import Control.Monad (MonadPlus(mzero, mplus), liftM)+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Fix (MonadFix(mfix))+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+import Data.Maybe (fromMaybe)+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif --- | The parameterizable maybe monad, obtained by composing an arbitrary--- monad with the 'Maybe' monad.+-- | The parameterizable maybe monad, a strict monad obtained by composing+-- an arbitrary monad with the 'Maybe' monad. ----- Computations are actions that may produce a value or fail.+-- Computations are actions that may produce a value or exit. ----- The 'return' function yields a successful computation, while @>>=@--- sequences two subcomputations, failing on the first error.+-- The 'return' function yields a computation that produces that+-- value, while @>>=@ sequences two subcomputations, exiting if either+-- computation does. newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, Generic1)+#elif __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif +instance (Eq1 m) => Eq1 (MaybeT m) where+    liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y+    {-# INLINE liftEq #-}++instance (Ord1 m) => Ord1 (MaybeT m) where+    liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y+    {-# INLINE liftCompare #-}++instance (Read1 m) => Read1 (MaybeT m) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++instance (Show1 m) => Show1 (MaybeT m) where+    liftShowsPrec sp sl d (MaybeT m) =+        showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1+instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1+instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1+instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1+ -- | Transform the computation inside a @MaybeT@.+--+-- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@ mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b mapMaybeT f = MaybeT . f . runMaybeT+{-# INLINE mapMaybeT #-} +-- | Convert a 'Maybe' computation to 'MaybeT'.+hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b+hoistMaybe = MaybeT . pure++-- | Convert a 'MaybeT' computation to 'ExceptT', with a default+-- exception value.+maybeToExceptT :: (Functor m) => e -> MaybeT m a -> ExceptT e m a+maybeToExceptT e (MaybeT m) = ExceptT $ fmap (maybe (Left e) Right) m+{-# INLINE maybeToExceptT #-}++-- | Convert a 'ExceptT' computation to 'MaybeT', discarding the+-- value of any exception.+exceptToMaybeT :: (Functor m) => ExceptT e m a -> MaybeT m a+exceptToMaybeT (ExceptT m) = MaybeT $ fmap (either (const Nothing) Just) m+{-# INLINE exceptToMaybeT #-}+ instance (Functor m) => Functor (MaybeT m) where     fmap f = mapMaybeT (fmap (fmap f))+    {-# INLINE fmap #-} +instance (Foldable f) => Foldable (MaybeT f) where+    foldMap f (MaybeT a) = foldMap (foldMap f) a+    {-# INLINE foldMap #-}++instance (Traversable f) => Traversable (MaybeT f) where+    traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a+    {-# INLINE traverse #-}+ instance (Functor m, Monad m) => Applicative (MaybeT m) where-    pure = return-    (<*>) = ap- +    pure = MaybeT . return . Just+    {-# INLINE pure #-}+    mf <*> mx = MaybeT $ do+        mb_f <- runMaybeT mf+        case mb_f of+            Nothing -> return Nothing+            Just f  -> do+                mb_x <- runMaybeT mx+                case mb_x of+                    Nothing -> return Nothing+                    Just x  -> return (Just (f x))+    {-# INLINE (<*>) #-}+    m *> k = m >>= \_ -> k+    {-# INLINE (*>) #-}+ instance (Functor m, Monad m) => Alternative (MaybeT m) where-    empty = mzero-    (<|>) = mplus+    empty = MaybeT (return Nothing)+    {-# INLINE empty #-}+    x <|> y = MaybeT $ do+        v <- runMaybeT x+        case v of+            Nothing -> runMaybeT y+            Just _  -> return v+    {-# INLINE (<|>) #-}  instance (Monad m) => Monad (MaybeT m) where-    fail _ = MaybeT (return Nothing)-    return = lift . return+#if !(MIN_VERSION_base(4,8,0))+    return = MaybeT . return . Just+    {-# INLINE return #-}+#endif     x >>= f = MaybeT $ do         v <- runMaybeT x         case v of             Nothing -> return Nothing             Just y  -> runMaybeT (f y)+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail _ = MaybeT (return Nothing)+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Monad m) => Fail.MonadFail (MaybeT m) where+    fail _ = MaybeT (return Nothing)+    {-# INLINE fail #-}+#endif+ instance (Monad m) => MonadPlus (MaybeT m) where     mzero = MaybeT (return Nothing)+    {-# INLINE mzero #-}     mplus x y = MaybeT $ do         v <- runMaybeT x         case v of             Nothing -> runMaybeT y             Just _  -> return v+    {-# INLINE mplus #-} +instance (MonadFix m) => MonadFix (MaybeT m) where+    mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb))+      where bomb = error "mfix (MaybeT): inner computation returned Nothing"+    {-# INLINE mfix #-}+ instance MonadTrans MaybeT where     lift = MaybeT . liftM Just+    {-# INLINE lift #-}  instance (MonadIO m) => MonadIO (MaybeT m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (MaybeT m) where+    mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b+    {-# INLINE mzipWith #-}+#endif++#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (MaybeT m) where+    contramap f = MaybeT . contramap (fmap f) . runMaybeT+    {-# INLINE contramap #-}+#endif+ -- | Lift a @callCC@ operation to the new monad.-liftCallCC :: (((Maybe a -> m (Maybe b)) -> m (Maybe a)) ->-    m (Maybe a)) -> ((a -> MaybeT m b) -> MaybeT m a) -> MaybeT m a+liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b liftCallCC callCC f =     MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just))+{-# INLINE liftCallCC #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) ->-    MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a+-- | Lift a @catchE@ operation to the new monad.+liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h)+{-# INLINE liftCatch #-}  -- | Lift a @listen@ operation to the new monad.-liftListen :: Monad m =>-    (m (Maybe a) -> m (Maybe a,w)) -> MaybeT m a -> MaybeT m (a,w)+liftListen :: (Monad m) => Listen w m (Maybe a) -> Listen w (MaybeT m) a liftListen listen = mapMaybeT $ \ m -> do     (a, w) <- listen m     return $! fmap (\ r -> (r, w)) a+{-# INLINE liftListen #-}  -- | Lift a @pass@ operation to the new monad.-liftPass :: Monad m => (m (Maybe a,w -> w) -> m (Maybe a)) ->-    MaybeT m (a,w -> w) -> MaybeT m a+liftPass :: (Monad m) => Pass w m (Maybe a) -> Pass w (MaybeT m) a liftPass pass = mapMaybeT $ \ m -> pass $ do     a <- m     return $! case a of         Nothing     -> (Nothing, id)         Just (v, f) -> (Just v, f)+{-# INLINE liftPass #-}
Control/Monad/Trans/RWS.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.RWS@@ -5,13 +9,15 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'.--- This version is lazy; for a strict version, see--- "Control.Monad.Trans.RWS.Strict", which has the same interface.+-- A monad transformer that combines 'Control.Monad.Trans.Reader.ReaderT',+-- 'Control.Monad.Trans.Writer.Lazy.WriterT' and+-- 'Control.Monad.Trans.State.Lazy.StateT'.+-- This version is lazy; for a constant-space version with almost the+-- same interface, see "Control.Monad.Trans.RWS.CPS". -----------------------------------------------------------------------------  module Control.Monad.Trans.RWS (
+ Control/Monad/Trans/RWS/CPS.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.RWS.CPS+-- Copyright   :  (c) Daniel Mendler 2016,+--                (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- A monad transformer that combines 'Control.Monad.Trans.Reader.ReaderT',+-- 'Control.Monad.Trans.Writer.CPS.WriterT' and+-- 'Control.Monad.Trans.State.Strict.StateT'.+-- This version uses continuation-passing-style for the writer part+-- to achieve constant space usage.+-- For a lazy version with the same interface,+-- see "Control.Monad.Trans.RWS.Lazy".+-----------------------------------------------------------------------------++module Control.Monad.Trans.RWS.CPS (+    -- * The RWS monad+    RWS,+    rws,+    runRWS,+    evalRWS,+    execRWS,+    mapRWS,+    withRWS,+    -- * The RWST monad transformer+    RWST,+    rwsT,+    runRWST,+    evalRWST,+    execRWST,+    mapRWST,+    withRWST,+    -- * Reader operations+    reader,+    ask,+    local,+    asks,+    -- * Writer operations+    writer,+    tell,+    listen,+    listens,+    pass,+    censor,+    -- * State operations+    state,+    get,+    put,+    modify,+    gets,+    -- * Lifting other operations+    liftCallCC,+    liftCallCC',+    liftCatch,+  ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Signatures+import Data.Functor.Identity++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | A monad containing an environment of type @r@, output of type @w@+-- and an updatable state of type @s@.+type RWS r w s = RWST r w s Identity++-- | Construct an RWS computation from a function.+-- (The inverse of 'runRWS'.)+rws :: (Monoid w) => (r -> s -> (a, s, w)) -> RWS r w s a+rws f = RWST $ \ r s w ->+    let (a, s', w') = f r s; wt = w `mappend` w' in wt `seq` return (a, s', wt)+{-# INLINE rws #-}++-- | Unwrap an RWS computation as a function.+-- (The inverse of 'rws'.)+runRWS :: (Monoid w) => RWS r w s a -> r -> s -> (a, s, w)+runRWS m r s = runIdentity (runRWST m r s)+{-# INLINE runRWS #-}++-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWS :: (Monoid w)+        => RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (a, w)       -- ^final value and output+evalRWS m r s = let+    (a, _, w) = runRWS m r s+    in (a, w)+{-# INLINE evalRWS #-}++-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWS :: (Monoid w)+        => RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (s, w)       -- ^final state and output+execRWS m r s = let+    (_, s', w) = runRWS m r s+    in (s', w)+{-# INLINE execRWS #-}++-- | Map the return value, final state and output of a computation using+-- the given function.+--+-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@+mapRWS :: (Monoid w, Monoid w') => ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b+mapRWS f = mapRWST (Identity . f . runIdentity)+{-# INLINE mapRWS #-}++-- | @'withRWS' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@+withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a+withRWS = withRWST+{-# INLINE withRWS #-}++-- ---------------------------------------------------------------------------+-- | A monad transformer adding reading an environment of type @r@,+-- collecting an output of type @w@ and updating a state of type @s@+-- to an inner monad @m@.+newtype RWST r w s m a = RWST { unRWST :: r -> s -> w -> m (a, s, w) }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++-- | Construct an RWST computation from a function.+-- (The inverse of 'runRWST'.)+rwsT :: (Functor m, Monoid w) => (r -> s -> m (a, s, w)) -> RWST r w s m a+rwsT f = RWST $ \ r s w ->+     (\ (a, s', w') -> let wt = w `mappend` w' in wt `seq` (a, s', wt)) <$> f r s+{-# INLINE rwsT #-}++-- | Unwrap an RWST computation as a function.+-- (The inverse of 'rwsT'.)+runRWST :: (Monoid w) => RWST r w s m a -> r -> s -> m (a, s, w)+runRWST m r s = unRWST m r s mempty+{-# INLINE runRWST #-}++-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWST :: (Monad m, Monoid w)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (a, w)            -- ^computation yielding final value and output+evalRWST m r s = do+    (a, _, w) <- runRWST m r s+    return (a, w)+{-# INLINE evalRWST #-}++-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWST :: (Monad m, Monoid w)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (s, w)            -- ^computation yielding final state and output+execRWST m r s = do+    (_, s', w) <- runRWST m r s+    return (s', w)+{-# INLINE execRWST #-}++-- | Map the inner computation using the given function.+--+-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@+--mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b+mapRWST :: (Monad n, Monoid w, Monoid w') =>+    (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b+mapRWST f m = RWST $ \ r s w -> do+    (a, s', w') <- f (runRWST m r s)+    let wt = w `mappend` w'+    wt `seq` return (a, s', wt)+{-# INLINE mapRWST #-}++-- | @'withRWST' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@+withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a+withRWST f m = RWST $ \ r s -> uncurry (unRWST m) (f r s)+{-# INLINE withRWST #-}++instance (Functor m) => Functor (RWST r w s m) where+    fmap f m = RWST $ \ r s w -> (\ (a, s', w') -> (f a, s', w')) <$> unRWST m r s w+    {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (RWST r w s m) where+    pure a = RWST $ \ _ s w -> return (a, s, w)+    {-# INLINE pure #-}++    RWST mf <*> RWST mx = RWST $ \ r s w -> do+        (f, s', w')    <- mf r s w+        (x, s'', w'') <- mx r s' w'+        return (f x, s'', w'')+    {-# INLINE (<*>) #-}++instance (Functor m, MonadPlus m) => Alternative (RWST r w s m) where+    empty = RWST $ \ _ _ _ -> mzero+    {-# INLINE empty #-}++    RWST m <|> RWST n = RWST $ \ r s w -> m r s w `mplus` n r s w+    {-# INLINE (<|>) #-}++instance (Monad m) => Monad (RWST r w s m) where+#if !(MIN_VERSION_base(4,8,0))+    return a = RWST $ \ _ s w -> return (a, s, w)+    {-# INLINE return #-}+#endif++    m >>= k = RWST $ \ r s w -> do+        (a, s', w')    <- unRWST m r s w+        unRWST (k a) r s' w'+    {-# INLINE (>>=) #-}++#if !(MIN_VERSION_base(4,13,0))+    fail msg = RWST $ \ _ _ _ -> fail msg+    {-# INLINE fail #-}+#endif++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where+    fail msg = RWST $ \ _ _ _ -> Fail.fail msg+    {-# INLINE fail #-}+#endif++instance (Functor m, MonadPlus m) => MonadPlus (RWST r w s m) where+    mzero = empty+    {-# INLINE mzero #-}+    mplus = (<|>)+    {-# INLINE mplus #-}++instance (MonadFix m) => MonadFix (RWST r w s m) where+    mfix f = RWST $ \ r s w -> mfix $ \ ~(a, _, _) -> unRWST (f a) r s w+    {-# INLINE mfix #-}++instance MonadTrans (RWST r w s) where+    lift m = RWST $ \ _ s w -> do+        a <- m+        return (a, s, w)+    {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (RWST r w s m) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}+-- ---------------------------------------------------------------------------+-- Reader operations++-- | Constructor for computations in the reader monad (equivalent to 'asks').+reader :: (Monad m) => (r -> a) -> RWST r w s m a+reader = asks+{-# INLINE reader #-}++-- | Fetch the value of the environment.+ask :: (Monad m) => RWST r w s m r+ask = asks id+{-# INLINE ask #-}++-- | Execute a computation in a modified environment+--+-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@+local :: (r -> r) -> RWST r w s m a -> RWST r w s m a+local f m = RWST $ \ r s w -> unRWST m (f r) s w+{-# INLINE local #-}++-- | Retrieve a function of the current environment.+--+-- * @'asks' f = 'liftM' f 'ask'@+asks :: (Monad m) => (r -> a) -> RWST r w s m a+asks f = RWST $ \ r s w -> return (f r, s, w)+{-# INLINE asks #-}++-- ---------------------------------------------------------------------------+-- Writer operations++-- | Construct a writer computation from a (result, output) pair.+writer :: (Monoid w, Monad m) => (a, w) -> RWST r w s m a+writer (a, w') = RWST $ \ _ s w -> let wt = w `mappend` w' in wt `seq` return (a, s, wt)+{-# INLINE writer #-}++-- | @'tell' w@ is an action that produces the output @w@.+tell :: (Monoid w, Monad m) => w -> RWST r w s m ()+tell w' = writer ((), w')+{-# INLINE tell #-}++-- | @'listen' m@ is an action that executes the action @m@ and adds its+-- output to the value of the computation.+--+-- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@+listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w)+listen = listens id+{-# INLINE listen #-}++-- | @'listens' f m@ is an action that executes the action @m@ and adds+-- the result of applying @f@ to the output to the value of the computation.+--+-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@+--+-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@+listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b)+listens f m = RWST $ \ r s w -> do+    (a, s', w') <- runRWST m r s+    let wt = w `mappend` w'+    wt `seq` return ((a, f w'), s', wt)+{-# INLINE listens #-}++-- | @'pass' m@ is an action that executes the action @m@, which returns+-- a value and a function, and returns the value, applying the function+-- to the output.+--+-- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@+pass :: (Monoid w, Monoid w', Monad m) => RWST r w s m (a, w -> w') -> RWST r w' s m a+pass m = RWST $ \ r s w -> do+    ((a, f), s', w') <- runRWST m r s+    let wt = w `mappend` f w'+    wt `seq` return (a, s', wt)+{-# INLINE pass #-}++-- | @'censor' f m@ is an action that executes the action @m@ and+-- applies the function @f@ to its output, leaving the return value+-- unchanged.+--+-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@+--+-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@+censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a+censor f m = RWST $ \ r s w -> do+    (a, s', w') <- runRWST m r s+    let wt = w `mappend` f w'+    wt `seq` return (a, s', wt)+{-# INLINE censor #-}++-- ---------------------------------------------------------------------------+-- State operations++-- | Construct a state monad computation from a state transformer function.+state :: (Monad m) => (s -> (a, s)) -> RWST r w s m a+state f = RWST $ \ _ s w -> let (a, s') = f s in return (a, s', w)+{-# INLINE state #-}++-- | Fetch the current value of the state within the monad.+get :: (Monad m) =>RWST r w s m s+get = gets id+{-# INLINE get #-}++-- | @'put' s@ sets the state within the monad to @s@.+put :: (Monad m) =>s -> RWST r w s m ()+put s = RWST $ \ _ _ w -> return ((), s, w)+{-# INLINE put #-}++-- | @'modify' f@ is an action that updates the state to the result of+-- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@+modify :: (Monad m) =>(s -> s) -> RWST r w s m ()+modify f = RWST $ \ _ s w -> return ((), f s, w)+{-# INLINE modify #-}++-- | Get a specific component of the state, using a projection function+-- supplied.+--+-- * @'gets' f = 'liftM' f 'get'@+gets :: (Monad m) =>(s -> a) -> RWST r w s m a+gets f = RWST $ \ _ s w -> return (f s, s, w)+{-# INLINE gets #-}++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original state on entering the+-- continuation.+liftCallCC :: CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b+liftCallCC callCC f = RWST $ \ r s w ->+    callCC $ \ c -> unRWST (f (\ a -> RWST $ \ _ _ _ -> c (a, s, w))) r s w+{-# INLINE liftCallCC #-}++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current state on entering the continuation.+liftCallCC' :: CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b+liftCallCC' callCC f = RWST $ \ r s w ->+    callCC $ \ c -> unRWST (f (\ a -> RWST $ \ _ s' _ -> c (a, s', w))) r s w+{-# INLINE liftCallCC' #-}++-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @catchE@ discards any output or changes to the state from+-- the body on entering the handler.+liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a+liftCatch catchE m h =+    RWST $ \ r s w -> unRWST m r s w `catchE` \ e -> unRWST (h e) r s w+{-# INLINE liftCatch #-}
Control/Monad/Trans/RWS/Lazy.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.RWS.Lazy@@ -5,13 +13,15 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'.--- This version is lazy; for a strict version, see--- "Control.Monad.Trans.RWS.Strict", which has the same interface.+-- A monad transformer that combines 'Control.Monad.Trans.Reader.ReaderT',+-- 'Control.Monad.Trans.Writer.Lazy.WriterT' and+-- 'Control.Monad.Trans.State.Lazy.StateT'.+-- This version is lazy; for a constant-space version with almost the+-- same interface, see "Control.Monad.Trans.RWS.CPS". -----------------------------------------------------------------------------  module Control.Monad.Trans.RWS.Lazy (@@ -30,16 +40,19 @@     mapRWST,     withRWST,     -- * Reader operations+    reader,     ask,     local,     asks,     -- * Writer operations+    writer,     tell,     listen,     listens,     pass,     censor,     -- * State operations+    state,     get,     put,     modify,@@ -51,13 +64,25 @@   ) where  import Control.Monad.IO.Class+import Control.Monad.Signatures import Control.Monad.Trans.Class+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif import Data.Functor.Identity  import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix+#if !(MIN_VERSION_base(4,8,0)) import Data.Monoid+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  -- | A monad containing an environment of type @r@, output of type @w@ -- and an updatable state of type @s@.@@ -67,191 +92,311 @@ -- (The inverse of 'runRWS'.) rws :: (r -> s -> (a, s, w)) -> RWS r w s a rws f = RWST (\ r s -> Identity (f r s))+{-# INLINE rws #-}  -- | Unwrap an RWS computation as a function. -- (The inverse of 'rws'.) runRWS :: RWS r w s a -> r -> s -> (a, s, w) runRWS m r s = runIdentity (runRWST m r s)+{-# INLINE runRWS #-} -evalRWS :: RWS r w s a -> r -> s -> (a, w)+-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (a, w)       -- ^final value and output evalRWS m r s = let     (a, _, w) = runRWS m r s     in (a, w)+{-# INLINE evalRWS #-} -execRWS :: RWS r w s a -> r -> s -> (s, w)+-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (s, w)       -- ^final state and output execRWS m r s = let     (_, s', w) = runRWS m r s     in (s', w)+{-# INLINE execRWS #-} +-- | Map the return value, final state and output of a computation using+-- the given function.+--+-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b mapRWS f = mapRWST (Identity . f . runIdentity)+{-# INLINE mapRWS #-} +-- | @'withRWS' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a withRWS = withRWST+{-# INLINE withRWS #-}  -- --------------------------------------------------------------------------- -- | A monad transformer adding reading an environment of type @r@, -- collecting an output of type @w@ and updating a state of type @s@ -- to an inner monad @m@. newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }--evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif+-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (a, w)            -- ^computation yielding final value and output evalRWST m r s = do     ~(a, _, w) <- runRWST m r s     return (a, w)+{-# INLINE evalRWST #-} -execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)+-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (s, w)            -- ^computation yielding final state and output execRWST m r s = do     ~(_, s', w) <- runRWST m r s     return (s', w)+{-# INLINE execRWST #-} +-- | Map the inner computation using the given function.+--+-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b-mapRWST f m = RWST $ \r s -> f (runRWST m r s)+mapRWST f m = RWST $ \ r s -> f (runRWST m r s)+{-# INLINE mapRWST #-} +-- | @'withRWST' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a-withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)+withRWST f m = RWST $ \ r s -> uncurry (runRWST m) (f r s)+{-# INLINE withRWST #-}  instance (Functor m) => Functor (RWST r w s m) where-    fmap f m = RWST $ \r s ->+    fmap f m = RWST $ \ r s ->         fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s+    {-# INLINE fmap #-}  instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where-    pure = return-    (<*>) = ap+    pure a = RWST $ \ _ s -> return (a, s, mempty)+    {-# INLINE pure #-}+    RWST mf <*> RWST mx  = RWST $ \ r s -> do+        ~(f, s', w)  <- mf r s+        ~(x, s'',w') <- mx r s'+        return (f x, s'', w `mappend` w')+    {-# INLINE (<*>) #-}  instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where-    empty = mzero-    (<|>) = mplus+    empty = RWST $ \ _ _ -> mzero+    {-# INLINE empty #-}+    RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s+    {-# INLINE (<|>) #-}  instance (Monoid w, Monad m) => Monad (RWST r w s m) where-    return a = RWST $ \_ s -> return (a, s, mempty)-    m >>= k  = RWST $ \r s -> do+#if !(MIN_VERSION_base(4,8,0))+    return a = RWST $ \ _ s -> return (a, s, mempty)+    {-# INLINE return #-}+#endif+    m >>= k  = RWST $ \ r s -> do         ~(a, s', w)  <- runRWST m r s         ~(b, s'',w') <- runRWST (k a) r s'         return (b, s'', w `mappend` w')-    fail msg = RWST $ \_ _ -> fail msg+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail msg = RWST $ \ _ _ -> fail msg+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where+    fail msg = RWST $ \ _ _ -> Fail.fail msg+    {-# INLINE fail #-}+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where-    mzero       = RWST $ \_ _ -> mzero-    m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s+    mzero = RWST $ \ _ _ -> mzero+    {-# INLINE mzero #-}+    RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s+    {-# INLINE mplus #-}  instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where-    mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s+    mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s+    {-# INLINE mfix #-}  instance (Monoid w) => MonadTrans (RWST r w s) where-    lift m = RWST $ \_ s -> do+    lift m = RWST $ \ _ s -> do         a <- m         return (a, s, mempty)+    {-# INLINE lift #-}  instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (RWST r w s m) where+    contramap f m = RWST $ \r s ->+      contramap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s+    {-# INLINE contramap #-}+#endif+ -- --------------------------------------------------------------------------- -- Reader operations +-- | Constructor for computations in the reader monad (equivalent to 'asks').+reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a+reader = asks+{-# INLINE reader #-}+ -- | Fetch the value of the environment. ask :: (Monoid w, Monad m) => RWST r w s m r-ask = RWST $ \r s -> return (r, s, mempty)+ask = RWST $ \ r s -> return (r, s, mempty)+{-# INLINE ask #-}  -- | Execute a computation in a modified environment-local :: (Monoid w, Monad m) => (r -> r) -> RWST r w s m a -> RWST r w s m a-local f m = RWST $ \r s -> runRWST m (f r) s+--+-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@+local :: (r -> r) -> RWST r w s m a -> RWST r w s m a+local f m = RWST $ \ r s -> runRWST m (f r) s+{-# INLINE local #-}  -- | Retrieve a function of the current environment.+--+-- * @'asks' f = 'liftM' f 'ask'@ asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a-asks f = do-    r <- ask-    return (f r)+asks f = RWST $ \ r s -> return (f r, s, mempty)+{-# INLINE asks #-}  -- --------------------------------------------------------------------------- -- Writer operations +-- | Construct a writer computation from a (result, output) pair.+writer :: (Monad m) => (a, w) -> RWST r w s m a+writer (a, w) = RWST $ \ _ s -> return (a, s, w)+{-# INLINE writer #-}+ -- | @'tell' w@ is an action that produces the output @w@.-tell :: (Monoid w, Monad m) => w -> RWST r w s m ()-tell w = RWST $ \_ s -> return ((),s,w)+tell :: (Monad m) => w -> RWST r w s m ()+tell w = RWST $ \ _ s -> return ((),s,w)+{-# INLINE tell #-}  -- | @'listen' m@ is an action that executes the action @m@ and adds its -- output to the value of the computation.-listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w)-listen m = RWST $ \r s -> do+--+-- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@+listen :: (Monad m) => RWST r w s m a -> RWST r w s m (a, w)+listen m = RWST $ \ r s -> do     ~(a, s', w) <- runRWST m r s     return ((a, w), s', w)+{-# INLINE listen #-}  -- | @'listens' f m@ is an action that executes the action @m@ and adds -- the result of applying @f@ to the output to the value of the computation. -- -- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@-listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b)-listens f m = do-    ~(a, w) <- listen m-    return (a, f w)+--+-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@+listens :: (Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b)+listens f m = RWST $ \ r s -> do+    ~(a, s', w) <- runRWST m r s+    return ((a, f w), s', w)+{-# INLINE listens #-}  -- | @'pass' m@ is an action that executes the action @m@, which returns -- a value and a function, and returns the value, applying the function -- to the output.-pass :: (Monoid w, Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a-pass m = RWST $ \r s -> do+--+-- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@+pass :: (Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a+pass m = RWST $ \ r s -> do     ~((a, f), s', w) <- runRWST m r s     return (a, s', f w)+{-# INLINE pass #-}  -- | @'censor' f m@ is an action that executes the action @m@ and -- applies the function @f@ to its output, leaving the return value -- unchanged. ----- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@-censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a-censor f m = pass $ do-    a <- m-    return (a, f)+-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@+--+-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@+censor :: (Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a+censor f m = RWST $ \ r s -> do+    ~(a, s', w) <- runRWST m r s+    return (a, s', f w)+{-# INLINE censor #-}  -- --------------------------------------------------------------------------- -- State operations +-- | Construct a state monad computation from a state transformer function.+state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a+state f = RWST $ \ _ s -> let (a,s') = f s  in  return (a, s', mempty)+{-# INLINE state #-}+ -- | Fetch the current value of the state within the monad. get :: (Monoid w, Monad m) => RWST r w s m s-get = RWST $ \_ s -> return (s, s, mempty)+get = RWST $ \ _ s -> return (s, s, mempty)+{-# INLINE get #-}  -- | @'put' s@ sets the state within the monad to @s@. put :: (Monoid w, Monad m) => s -> RWST r w s m ()-put s = RWST $ \_ _ -> return ((), s, mempty)+put s = RWST $ \ _ _ -> return ((), s, mempty)+{-# INLINE put #-}  -- | @'modify' f@ is an action that updates the state to the result of -- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@ modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()-modify f = do-    s <- get-    put (f s)- +modify f = RWST $ \ _ s -> return ((), f s, mempty)+{-# INLINE modify #-}+ -- | Get a specific component of the state, using a projection function -- supplied. -- -- * @'gets' f = 'liftM' f 'get'@ gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a-gets f = do-    s <- get-    return (f s)+gets f = RWST $ \ _ s -> return (f s, s, mempty)+{-# INLINE gets #-}  -- | Uniform lifting of a @callCC@ operation to the new monad. -- This version rolls back to the original state on entering the -- continuation. liftCallCC :: (Monoid w) =>-    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->-    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a-liftCallCC callCC f = RWST $ \r s ->-    callCC $ \c ->-    runRWST (f (\a -> RWST $ \_ _ -> c (a, s, mempty))) r s+    CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b+liftCallCC callCC f = RWST $ \ r s ->+    callCC $ \ c ->+    runRWST (f (\ a -> RWST $ \ _ _ -> c (a, s, mempty))) r s+{-# INLINE liftCallCC #-}  -- | In-situ lifting of a @callCC@ operation to the new monad. -- This version uses the current state on entering the continuation. liftCallCC' :: (Monoid w) =>-    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->-    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a-liftCallCC' callCC f = RWST $ \r s ->-    callCC $ \c ->-    runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s+    CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b+liftCallCC' callCC f = RWST $ \ r s ->+    callCC $ \ c ->+    runRWST (f (\ a -> RWST $ \ _ s' -> c (a, s', mempty))) r s+{-# INLINE liftCallCC' #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m (a,s,w) -> (e -> m (a,s,w)) -> m (a,s,w)) ->-    RWST l w s m a -> (e -> RWST l w s m a) -> RWST l w s m a-liftCatch catchError m h =-    RWST $ \r s -> runRWST m r s `catchError` \e -> runRWST (h e) r s+-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @catchE@ discards any output or changes to the state from+-- the body on entering the handler.+liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a+liftCatch catchE m h =+    RWST $ \ r s -> runRWST m r s `catchE` \ e -> runRWST (h e) r s+{-# INLINE liftCatch #-}
Control/Monad/Trans/RWS/Strict.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.RWS.Strict@@ -5,13 +13,18 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'.--- This version is strict; for a lazy version, see--- "Control.Monad.Trans.RWS.Lazy", which has the same interface.+-- A monad transformer that combines 'Control.Monad.Trans.Reader.ReaderT',+-- 'Control.Monad.Trans.Writer.Strict.WriterT' and+-- 'Control.Monad.Trans.State.Strict.StateT'.+-- This version is strict; for a lazy version with the same interface,+-- see "Control.Monad.Trans.RWS.Lazy".+-- Although the output is built strictly, it is not possible to+-- achieve constant space behaviour with this transformer: for that,+-- use "Control.Monad.Trans.RWS.CPS" instead. -----------------------------------------------------------------------------  module Control.Monad.Trans.RWS.Strict (@@ -30,16 +43,19 @@     mapRWST,     withRWST,     -- * Reader operations+    reader,     ask,     local,     asks,     -- * Writer operations+    writer,     tell,     listen,     listens,     pass,     censor,     -- * State operations+    state,     get,     put,     modify,@@ -51,13 +67,25 @@   ) where  import Control.Monad.IO.Class+import Control.Monad.Signatures import Control.Monad.Trans.Class+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif import Data.Functor.Identity  import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix+#if !(MIN_VERSION_base(4,8,0)) import Data.Monoid+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  -- | A monad containing an environment of type @r@, output of type @w@ -- and an updatable state of type @s@.@@ -67,191 +95,312 @@ -- (The inverse of 'runRWS'.) rws :: (r -> s -> (a, s, w)) -> RWS r w s a rws f = RWST (\ r s -> Identity (f r s))+{-# INLINE rws #-}  -- | Unwrap an RWS computation as a function. -- (The inverse of 'rws'.) runRWS :: RWS r w s a -> r -> s -> (a, s, w) runRWS m r s = runIdentity (runRWST m r s)+{-# INLINE runRWS #-} -evalRWS :: RWS r w s a -> r -> s -> (a, w)+-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (a, w)       -- ^final value and output evalRWS m r s = let     (a, _, w) = runRWS m r s     in (a, w)+{-# INLINE evalRWS #-} -execRWS :: RWS r w s a -> r -> s -> (s, w)+-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (s, w)       -- ^final state and output execRWS m r s = let     (_, s', w) = runRWS m r s     in (s', w)+{-# INLINE execRWS #-} +-- | Map the return value, final state and output of a computation using+-- the given function.+--+-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b mapRWS f = mapRWST (Identity . f . runIdentity)+{-# INLINE mapRWS #-} +-- | @'withRWS' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a withRWS = withRWST+{-# INLINE withRWS #-}  -- --------------------------------------------------------------------------- -- | A monad transformer adding reading an environment of type @r@, -- collecting an output of type @w@ and updating a state of type @s@ -- to an inner monad @m@. newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif -evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)+-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (a, w)            -- ^computation yielding final value and output evalRWST m r s = do     (a, _, w) <- runRWST m r s     return (a, w)+{-# INLINE evalRWST #-} -execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)+-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (s, w)            -- ^computation yielding final state and output execRWST m r s = do     (_, s', w) <- runRWST m r s     return (s', w)+{-# INLINE execRWST #-} +-- | Map the inner computation using the given function.+--+-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b-mapRWST f m = RWST $ \r s -> f (runRWST m r s)+mapRWST f m = RWST $ \ r s -> f (runRWST m r s)+{-# INLINE mapRWST #-} +-- | @'withRWST' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a-withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)+withRWST f m = RWST $ \ r s -> uncurry (runRWST m) (f r s)+{-# INLINE withRWST #-}  instance (Functor m) => Functor (RWST r w s m) where-    fmap f m = RWST $ \r s ->+    fmap f m = RWST $ \ r s ->         fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s+    {-# INLINE fmap #-}  instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where-    pure = return-    (<*>) = ap+    pure a = RWST $ \ _ s -> return (a, s, mempty)+    {-# INLINE pure #-}+    RWST mf <*> RWST mx = RWST $ \ r s -> do+        (f, s', w)  <- mf r s+        (x, s'',w') <- mx r s'+        return (f x, s'', w `mappend` w')+    {-# INLINE (<*>) #-}  instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where-    empty = mzero-    (<|>) = mplus+    empty = RWST $ \ _ _ -> mzero+    {-# INLINE empty #-}+    RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s+    {-# INLINE (<|>) #-}  instance (Monoid w, Monad m) => Monad (RWST r w s m) where-    return a = RWST $ \_ s -> return (a, s, mempty)-    m >>= k  = RWST $ \r s -> do+#if !(MIN_VERSION_base(4,8,0))+    return a = RWST $ \ _ s -> return (a, s, mempty)+    {-# INLINE return #-}+#endif+    m >>= k  = RWST $ \ r s -> do         (a, s', w)  <- runRWST m r s         (b, s'',w') <- runRWST (k a) r s'         return (b, s'', w `mappend` w')-    fail msg = RWST $ \_ _ -> fail msg+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail msg = RWST $ \ _ _ -> fail msg+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where+    fail msg = RWST $ \ _ _ -> Fail.fail msg+    {-# INLINE fail #-}+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where-    mzero       = RWST $ \_ _ -> mzero-    m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s+    mzero = RWST $ \ _ _ -> mzero+    {-# INLINE mzero #-}+    RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s+    {-# INLINE mplus #-}  instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where-    mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s+    mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s+    {-# INLINE mfix #-}  instance (Monoid w) => MonadTrans (RWST r w s) where-    lift m = RWST $ \_ s -> do+    lift m = RWST $ \ _ s -> do         a <- m         return (a, s, mempty)+    {-# INLINE lift #-}  instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (RWST r w s m) where+    contramap f m = RWST $ \r s ->+      contramap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s+    {-# INLINE contramap #-}+#endif+ -- --------------------------------------------------------------------------- -- Reader operations +-- | Constructor for computations in the reader monad (equivalent to 'asks').+reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a+reader = asks+{-# INLINE reader #-}+ -- | Fetch the value of the environment. ask :: (Monoid w, Monad m) => RWST r w s m r-ask = RWST $ \r s -> return (r, s, mempty)+ask = RWST $ \ r s -> return (r, s, mempty)+{-# INLINE ask #-}  -- | Execute a computation in a modified environment-local :: (Monoid w, Monad m) => (r -> r) -> RWST r w s m a -> RWST r w s m a-local f m = RWST $ \r s -> runRWST m (f r) s+--+-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@+local :: (r -> r) -> RWST r w s m a -> RWST r w s m a+local f m = RWST $ \ r s -> runRWST m (f r) s+{-# INLINE local #-}  -- | Retrieve a function of the current environment.+--+-- * @'asks' f = 'liftM' f 'ask'@ asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a-asks f = do-    r <- ask-    return (f r)+asks f = RWST $ \ r s -> return (f r, s, mempty)+{-# INLINE asks #-}  -- --------------------------------------------------------------------------- -- Writer operations +-- | Construct a writer computation from a (result, output) pair.+writer :: (Monad m) => (a, w) -> RWST r w s m a+writer (a, w) = RWST $ \ _ s -> return (a, s, w)+{-# INLINE writer #-}+ -- | @'tell' w@ is an action that produces the output @w@.-tell :: (Monoid w, Monad m) => w -> RWST r w s m ()-tell w = RWST $ \_ s -> return ((),s,w)+tell :: (Monad m) => w -> RWST r w s m ()+tell w = RWST $ \ _ s -> return ((),s,w)+{-# INLINE tell #-}  -- | @'listen' m@ is an action that executes the action @m@ and adds its -- output to the value of the computation.-listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w)-listen m = RWST $ \r s -> do+--+-- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@+listen :: (Monad m) => RWST r w s m a -> RWST r w s m (a, w)+listen m = RWST $ \ r s -> do     (a, s', w) <- runRWST m r s     return ((a, w), s', w)+{-# INLINE listen #-}  -- | @'listens' f m@ is an action that executes the action @m@ and adds -- the result of applying @f@ to the output to the value of the computation. -- -- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@-listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b)-listens f m = do-    (a, w) <- listen m-    return (a, f w)+--+-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@+listens :: (Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b)+listens f m = RWST $ \ r s -> do+    (a, s', w) <- runRWST m r s+    return ((a, f w), s', w)+{-# INLINE listens #-}  -- | @'pass' m@ is an action that executes the action @m@, which returns -- a value and a function, and returns the value, applying the function -- to the output.-pass :: (Monoid w, Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a-pass m = RWST $ \r s -> do+--+-- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@+pass :: (Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a+pass m = RWST $ \ r s -> do     ((a, f), s', w) <- runRWST m r s     return (a, s', f w)+{-# INLINE pass #-}  -- | @'censor' f m@ is an action that executes the action @m@ and -- applies the function @f@ to its output, leaving the return value -- unchanged. ----- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@-censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a-censor f m = pass $ do-    a <- m-    return (a, f)+-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@+--+-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@+censor :: (Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a+censor f m = RWST $ \ r s -> do+    (a, s', w) <- runRWST m r s+    return (a, s', f w)+{-# INLINE censor #-}  -- --------------------------------------------------------------------------- -- State operations +-- | Construct a state monad computation from a state transformer function.+state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a+state f = RWST $ \ _ s -> case f s of (a,s') -> return (a, s', mempty)+{-# INLINE state #-}+ -- | Fetch the current value of the state within the monad. get :: (Monoid w, Monad m) => RWST r w s m s-get = RWST $ \_ s -> return (s, s, mempty)+get = RWST $ \ _ s -> return (s, s, mempty)+{-# INLINE get #-}  -- | @'put' s@ sets the state within the monad to @s@. put :: (Monoid w, Monad m) => s -> RWST r w s m ()-put s = RWST $ \_ _ -> return ((), s, mempty)+put s = RWST $ \ _ _ -> return ((), s, mempty)+{-# INLINE put #-}  -- | @'modify' f@ is an action that updates the state to the result of -- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@ modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()-modify f = do-    s <- get-    put (f s)- +modify f = RWST $ \ _ s -> return ((), f s, mempty)+{-# INLINE modify #-}+ -- | Get a specific component of the state, using a projection function -- supplied. -- -- * @'gets' f = 'liftM' f 'get'@ gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a-gets f = do-    s <- get-    return (f s)+gets f = RWST $ \ _ s -> return (f s, s, mempty)+{-# INLINE gets #-}  -- | Uniform lifting of a @callCC@ operation to the new monad. -- This version rolls back to the original state on entering the -- continuation. liftCallCC :: (Monoid w) =>-    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->-    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a-liftCallCC callCC f = RWST $ \r s ->-    callCC $ \c ->-    runRWST (f (\a -> RWST $ \_ _ -> c (a, s, mempty))) r s+    CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b+liftCallCC callCC f = RWST $ \ r s ->+    callCC $ \ c ->+    runRWST (f (\ a -> RWST $ \ _ _ -> c (a, s, mempty))) r s+{-# INLINE liftCallCC #-}  -- | In-situ lifting of a @callCC@ operation to the new monad. -- This version uses the current state on entering the continuation. liftCallCC' :: (Monoid w) =>-    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->-    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a-liftCallCC' callCC f = RWST $ \r s ->-    callCC $ \c ->-    runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s+    CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b+liftCallCC' callCC f = RWST $ \ r s ->+    callCC $ \ c ->+    runRWST (f (\ a -> RWST $ \ _ s' -> c (a, s', mempty))) r s+{-# INLINE liftCallCC' #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m (a,s,w) -> (e -> m (a,s,w)) -> m (a,s,w)) ->-    RWST l w s m a -> (e -> RWST l w s m a) -> RWST l w s m a-liftCatch catchError m h =-    RWST $ \r s -> runRWST m r s `catchError` \e -> runRWST (h e) r s+-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @catchE@ discards any output or changes to the state from+-- the body on entering the handler.+liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a+liftCatch catchE m h =+    RWST $ \ r s -> runRWST m r s `catchE` \ e -> runRWST (h e) r s+{-# INLINE liftCatch #-}
Control/Monad/Trans/Reader.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Reader@@ -5,7 +13,7 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable --@@ -37,131 +45,235 @@     ) where  import Control.Monad.IO.Class+import Control.Monad.Signatures import Control.Monad.Trans.Class+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif import Data.Functor.Identity  import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix-import Control.Monad.Instances ()+#if !(MIN_VERSION_base(4,6,0))+import Control.Monad.Instances ()  -- deprecated from base-4.6+#endif+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+#if (MIN_VERSION_base(4,2,0)) && !(MIN_VERSION_base(4,8,0))+import Data.Functor ((<$))+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif --- | The parameterizable reader monad.+-- | The parameterizable reader monad, which is non-strict. -- -- Computations are functions of a shared environment. ----- The 'return' function ignores the environment, while @>>=@ passes--- the inherited environment to both subcomputations.+-- The 'return' function ignores the environment, while @m '>>=' k@+-- passes the inherited environment to both subcomputations:+--+-- <<images/bind-ReaderT.svg>>+-- type Reader r = ReaderT r Identity --- | Constructor for computations in the reader monad.-reader :: (r -> a) -> Reader r a-reader f = ReaderT (Identity . f)+-- | Constructor for computations in the reader monad (equivalent to 'asks').+reader :: (Monad m) => (r -> a) -> ReaderT r m a+reader f = ReaderT (return . f)+{-# INLINE reader #-}  -- | Runs a @Reader@ and extracts the final value from it.-runReader :: Reader r a		-- ^ A @Reader@ to run.-    -> r			-- ^ An initial environment.+-- (The inverse of 'reader'.)+runReader+    :: Reader r a       -- ^ A @Reader@ to run.+    -> r                -- ^ An initial environment.     -> a runReader m = runIdentity . runReaderT m+{-# INLINE runReader #-}  -- | Transform the value returned by a @Reader@.+--+-- * @'runReader' ('mapReader' f m) = f . 'runReader' m@ mapReader :: (a -> b) -> Reader r a -> Reader r b mapReader f = mapReaderT (Identity . f . runIdentity)+{-# INLINE mapReader #-}  -- | Execute a computation in a modified environment -- (a specialization of 'withReaderT').+--+-- * @'runReader' ('withReader' f m) = 'runReader' m . f@ withReader     :: (r' -> r)        -- ^ The function to modify the environment.     -> Reader r a       -- ^ Computation to run in the modified environment.     -> Reader r' a withReader = withReaderT+{-# INLINE withReader #-}  -- | The reader monad transformer, -- which adds a read-only environment to the given monad. ----- The 'return' function ignores the environment, while @>>=@ passes--- the inherited environment to both subcomputations.-newtype ReaderT r m a = ReaderT {-        -- | The underlying computation, as a function of the environment.-        runReaderT :: r -> m a-    }+-- The 'return' function ignores the environment, while @m '>>=' k@+-- passes the inherited environment to both subcomputations:+--+-- <<images/bind-ReaderT.svg>>+--+--+-- @ReaderT r m@ is strict if and only if @m@ is.+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, Generic1)+#elif __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif  -- | Transform the computation inside a @ReaderT@.+--+-- * @'runReaderT' ('mapReaderT' f m) = f . 'runReaderT' m@ mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b mapReaderT f m = ReaderT $ f . runReaderT m+{-# INLINE mapReaderT #-}  -- | Execute a computation in a modified environment--- (a  more general version of 'local').+-- (a more general version of 'local').+--+-- * @'runReaderT' ('withReaderT' f m) = 'runReaderT' m . f@ withReaderT     :: (r' -> r)        -- ^ The function to modify the environment.     -> ReaderT r m a    -- ^ Computation to run in the modified environment.     -> ReaderT r' m a withReaderT f m = ReaderT $ runReaderT m . f+{-# INLINE withReaderT #-}  instance (Functor m) => Functor (ReaderT r m) where     fmap f  = mapReaderT (fmap f)+    {-# INLINE fmap #-}+#if MIN_VERSION_base(4,2,0)+    x <$ v = mapReaderT (x <$) v+    {-# INLINE (<$) #-}+#endif  instance (Applicative m) => Applicative (ReaderT r m) where     pure    = liftReaderT . pure+    {-# INLINE pure #-}     f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r+    {-# INLINE (<*>) #-}+#if MIN_VERSION_base(4,2,0)+    u *> v = ReaderT $ \ r -> runReaderT u r *> runReaderT v r+    {-# INLINE (*>) #-}+    u <* v = ReaderT $ \ r -> runReaderT u r <* runReaderT v r+    {-# INLINE (<*) #-}+#endif+#if MIN_VERSION_base(4,10,0)+    liftA2 f x y = ReaderT $ \ r -> liftA2 f (runReaderT x r) (runReaderT y r)+    {-# INLINE liftA2 #-}+#endif  instance (Alternative m) => Alternative (ReaderT r m) where     empty   = liftReaderT empty+    {-# INLINE empty #-}     m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r+    {-# INLINE (<|>) #-}  instance (Monad m) => Monad (ReaderT r m) where+#if !(MIN_VERSION_base(4,8,0))     return   = lift . return+    {-# INLINE return #-}+#endif     m >>= k  = ReaderT $ \ r -> do         a <- runReaderT m r         runReaderT (k a) r+    {-# INLINE (>>=) #-}+#if MIN_VERSION_base(4,8,0)+    (>>) = (*>)+#else+    m >> k = ReaderT $ \ r -> runReaderT m r >> runReaderT k r+#endif+    {-# INLINE (>>) #-}+#if !(MIN_VERSION_base(4,13,0))     fail msg = lift (fail msg)+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where+    fail msg = lift (Fail.fail msg)+    {-# INLINE fail #-}+#endif+ instance (MonadPlus m) => MonadPlus (ReaderT r m) where     mzero       = lift mzero+    {-# INLINE mzero #-}     m `mplus` n = ReaderT $ \ r -> runReaderT m r `mplus` runReaderT n r+    {-# INLINE mplus #-}  instance (MonadFix m) => MonadFix (ReaderT r m) where     mfix f = ReaderT $ \ r -> mfix $ \ a -> runReaderT (f a) r+    {-# INLINE mfix #-}  instance MonadTrans (ReaderT r) where     lift   = liftReaderT+    {-# INLINE lift #-}  instance (MonadIO m) => MonadIO (ReaderT r m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (ReaderT r m) where+    mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a ->+        mzipWith f (m a) (n a)+    {-# INLINE mzipWith #-}+#endif++#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (ReaderT r m) where+    contramap f = ReaderT . fmap (contramap f) . runReaderT+    {-# INLINE contramap #-}+#endif+ liftReaderT :: m a -> ReaderT r m a liftReaderT m = ReaderT (const m)+{-# INLINE liftReaderT #-}  -- | Fetch the value of the environment. ask :: (Monad m) => ReaderT r m r ask = ReaderT return+{-# INLINE ask #-}  -- | Execute a computation in a modified environment -- (a specialization of 'withReaderT').-local :: (Monad m)-    => (r -> r)         -- ^ The function to modify the environment.+--+-- * @'runReaderT' ('local' f m) = 'runReaderT' m . f@+local+    :: (r -> r)         -- ^ The function to modify the environment.     -> ReaderT r m a    -- ^ Computation to run in the modified environment.     -> ReaderT r m a local = withReaderT+{-# INLINE local #-}  -- | Retrieve a function of the current environment.+--+-- * @'asks' f = 'liftM' f 'ask'@ asks :: (Monad m)     => (r -> a)         -- ^ The selector function to apply to the environment.     -> ReaderT r m a-asks f = liftM f ask+asks f = ReaderT (return . f)+{-# INLINE asks #-}  -- | Lift a @callCC@ operation to the new monad.-liftCallCC ::-    (((a -> m b) -> m a) -> m a)        -- ^ @callCC@ on the argument monad.-    -> ((a -> ReaderT r m b) -> ReaderT r m a) -> ReaderT r m a+liftCallCC :: CallCC m a b -> CallCC (ReaderT r m) a b liftCallCC callCC f = ReaderT $ \ r ->     callCC $ \ c ->     runReaderT (f (ReaderT . const . c)) r+{-# INLINE liftCallCC #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch ::-    (m a -> (e -> m a) -> m a)          -- ^ @catch@ on the argument monad.-    -> ReaderT r m a                    -- ^ Computation to attempt.-    -> (e -> ReaderT r m a)             -- ^ Exception handler.-    -> ReaderT r m a+-- | Lift a @catchE@ operation to the new monad.+liftCatch :: Catch e m a -> Catch e (ReaderT r m) a liftCatch f m h =     ReaderT $ \ r -> f (runReaderT m r) (\ e -> runReaderT (h e) r)+{-# INLINE liftCatch #-}
+ Control/Monad/Trans/Select.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Select+-- Copyright   :  (c) Ross Paterson 2017+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Selection monad transformer, modelling search algorithms.+--+-- * Martin Escardo and Paulo Oliva.+--   "Selection functions, bar recursion and backward induction",+--   /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168.+--   <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf>+--+-- * Jules Hedges. "Monad transformers for backtracking search".+--   In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058>+-----------------------------------------------------------------------------++module Control.Monad.Trans.Select (+    -- * The Select monad+    Select,+    select,+    runSelect,+    mapSelect,+    -- * The SelectT monad transformer+    SelectT(..),+    mapSelectT,+    -- * Monad transformation+    selectToContT,+    ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont++import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Data.Functor.Identity+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | The selection monad, which is non-strict.+type Select r = SelectT r Identity++-- | Constructor for computations in the selection monad.+select :: ((a -> r) -> a) -> Select r a+select f = SelectT $ \ k -> Identity (f (runIdentity . k))+{-# INLINE select #-}++-- | Runs a @Select@ computation with a function for evaluating answers+-- to select a particular answer.  (The inverse of 'select'.)+runSelect :: Select r a -> (a -> r) -> a+runSelect m k = runIdentity (runSelectT m (Identity . k))+{-# INLINE runSelect #-}++-- | Apply a function to transform the result of a selection computation.+--+-- * @'runSelect' ('mapSelect' f m) = f . 'runSelect' m@+mapSelect :: (a -> a) -> Select r a -> Select r a+mapSelect f = mapSelectT (Identity . f . runIdentity)+{-# INLINE mapSelect #-}++-- | Selection monad transformer.+--+-- 'SelectT' is not a functor on the category of monads, and many operations+-- cannot be lifted through it.+--+-- @SelectT r m@ is strict if and only if @m@ is.+newtype SelectT r m a = SelectT {+    -- | Runs a @SelectT@ computation with a function for evaluating+    -- answers to select a particular answer.+    runSelectT :: (a -> m r) -> m a }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++-- | Apply a function to transform the result of a selection computation.+-- This has a more restricted type than the @map@ operations for other+-- monad transformers, because 'SelectT' does not define a functor in+-- the category of monads.+--+-- * @'runSelectT' ('mapSelectT' f m) = f . 'runSelectT' m@+mapSelectT :: (m a -> m a) -> SelectT r m a -> SelectT r m a+mapSelectT f m = SelectT $ f . runSelectT m+{-# INLINE mapSelectT #-}++instance (Functor m) => Functor (SelectT r m) where+    fmap f (SelectT g) = SelectT (fmap f . g . (. f))+    {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (SelectT r m) where+    pure = lift . return+    {-# INLINE pure #-}+    SelectT gf <*> SelectT gx = SelectT $ \ k -> do+        let h f = liftM f (gx (k . f))+        f <- gf ((>>= k) . h)+        h f+    {-# INLINE (<*>) #-}+    m *> k = m >>= \_ -> k+    {-# INLINE (*>) #-}++instance (Functor m, MonadPlus m) => Alternative (SelectT r m) where+    empty = mzero+    {-# INLINE empty #-}+    (<|>) = mplus+    {-# INLINE (<|>) #-}++instance (Monad m) => Monad (SelectT r m) where+#if !(MIN_VERSION_base(4,8,0))+    return = lift . return+    {-# INLINE return #-}+#endif+    SelectT g >>= f = SelectT $ \ k -> do+        let h x = runSelectT (f x) k+        y <- g ((>>= k) . h)+        h y+    {-# INLINE (>>=) #-}++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where+    fail msg = lift (Fail.fail msg)+    {-# INLINE fail #-}+#endif++instance (MonadPlus m) => MonadPlus (SelectT r m) where+    mzero = SelectT (const mzero)+    {-# INLINE mzero #-}+    SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k+    {-# INLINE mplus #-}++instance MonadTrans (SelectT r) where+    lift = SelectT . const+    {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (SelectT r m) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}++-- | Convert a selection computation to a continuation-passing computation.+selectToContT :: (Monad m) => SelectT r m a -> ContT r m a+selectToContT (SelectT g) = ContT $ \ k -> g k >>= k+{-# INLINE selectToContT #-}
Control/Monad/Trans/State.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.State@@ -5,11 +9,11 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- State monads, passing an updateable state through a computation.+-- State monads, passing an updatable state through a computation. -- -- Some computations may not require the full power of state transformers: --
Control/Monad/Trans/State/Lazy.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.State.Lazy@@ -5,23 +13,27 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- Lazy state monads, passing an updateable state through a computation.+-- Lazy state monads, passing an updatable state through a computation. -- See below for examples. ----- In this version, sequencing of computations is lazy in the state.--- For a strict version, see "Control.Monad.Trans.Writer.Strict", which--- has the same interface.--- -- Some computations may not require the full power of state transformers: -- -- * For a read-only state, see "Control.Monad.Trans.Reader". -- -- * To accumulate a value without using it on the way, see --   "Control.Monad.Trans.Writer".+--+-- In this version, sequencing of computations is lazy, so that for+-- example the following produces a usable result:+--+-- > evalState (sequence $ repeat $ do { n <- get; put (n*2); return n }) 1+--+-- For a strict version with the same interface, see+-- "Control.Monad.Trans.State.Strict". -----------------------------------------------------------------------------  module Control.Monad.Trans.State.Lazy (@@ -43,6 +55,8 @@     get,     put,     modify,+    modify',+    modifyM,     gets,     -- * Lifting other operations     liftCallCC,@@ -50,6 +64,9 @@     liftCatch,     liftListen,     liftPass,+    -- * Conversion to and from the strict version+    strictToLazyStateT,+    lazyToStrictStateT,     -- * Examples     -- ** State monads     -- $examples@@ -62,12 +79,23 @@   ) where  import Control.Monad.IO.Class+import Control.Monad.Signatures import Control.Monad.Trans.Class+import qualified Control.Monad.Trans.State.Strict as Strict+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif import Data.Functor.Identity  import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  -- --------------------------------------------------------------------------- -- | A state monad parameterized by the type @s@ of the state to carry.@@ -79,9 +107,11 @@  -- | Construct a state monad computation from a function. -- (The inverse of 'runState'.)-state :: (s -> (a, s))  -- ^pure state transformer-      -> State s a      -- ^equivalent state-passing computation-state f = StateT (Identity . f)+state :: (Monad m)+      => (s -> (a, s))  -- ^pure state transformer+      -> StateT s m a   -- ^equivalent state-passing computation+state f = StateT (return . f)+{-# INLINE state #-}  -- | Unwrap a state monad computation as a function. -- (The inverse of 'state'.)@@ -89,6 +119,7 @@          -> s           -- ^initial state          -> (a, s)      -- ^return value and final state runState m = runIdentity . runStateT m+{-# INLINE runState #-}  -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state.@@ -98,6 +129,7 @@           -> s          -- ^initial value           -> a          -- ^return value of the state computation evalState m s = fst (runState m s)+{-# INLINE evalState #-}  -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value.@@ -107,6 +139,7 @@           -> s          -- ^initial value           -> s          -- ^final state execState m s = snd (runState m s)+{-# INLINE execState #-}  -- | Map both the return value and final state of a computation using -- the given function.@@ -114,6 +147,7 @@ -- * @'runState' ('mapState' f m) = f . 'runState' m@ mapState :: ((a, s) -> (b, s)) -> State s a -> State s b mapState f = mapStateT (Identity . f . runIdentity)+{-# INLINE mapState #-}  -- | @'withState' f m@ executes action @m@ on a state modified by -- applying @f@.@@ -121,6 +155,7 @@ -- * @'withState' f m = 'modify' f >> m@ withState :: (s -> s) -> State s a -> State s a withState = withStateT+{-# INLINE withState #-}  -- --------------------------------------------------------------------------- -- | A state transformer monad parameterized by:@@ -133,6 +168,9 @@ -- the final state of the first computation as the initial state of -- the second. newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif  -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state.@@ -142,6 +180,7 @@ evalStateT m s = do     ~(a, _) <- runStateT m s     return a+{-# INLINE evalStateT #-}  -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value.@@ -151,6 +190,7 @@ execStateT m s = do     ~(_, s') <- runStateT m s     return s'+{-# INLINE execStateT #-}  -- | Map both the return value and final state of a computation using -- the given function.@@ -158,6 +198,7 @@ -- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b mapStateT f m = StateT $ f . runStateT m+{-# INLINE mapStateT #-}  -- | @'withStateT' f m@ executes action @m@ on a state modified by -- applying @f@.@@ -165,103 +206,172 @@ -- * @'withStateT' f m = 'modify' f >> m@ withStateT :: (s -> s) -> StateT s m a -> StateT s m a withStateT f m = StateT $ runStateT m . f+{-# INLINE withStateT #-}  instance (Functor m) => Functor (StateT s m) where     fmap f m = StateT $ \ s ->         fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s+    {-# INLINE fmap #-}  instance (Functor m, Monad m) => Applicative (StateT s m) where-    pure = return-    (<*>) = ap+    pure a = StateT $ \ s -> return (a, s)+    {-# INLINE pure #-}+    StateT mf <*> StateT mx = StateT $ \ s -> do+        ~(f, s') <- mf s+        ~(x, s'') <- mx s'+        return (f x, s'')+    {-# INLINE (<*>) #-}+    m *> k = m >>= \_ -> k+    {-# INLINE (*>) #-}  instance (Functor m, MonadPlus m) => Alternative (StateT s m) where-    empty = mzero-    (<|>) = mplus+    empty = StateT $ \ _ -> mzero+    {-# INLINE empty #-}+    StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s+    {-# INLINE (<|>) #-}  instance (Monad m) => Monad (StateT s m) where-    return a = StateT $ \s -> return (a, s)-    m >>= k  = StateT $ \s -> do+#if !(MIN_VERSION_base(4,8,0))+    return a = StateT $ \ s -> return (a, s)+    {-# INLINE return #-}+#endif+    m >>= k  = StateT $ \ s -> do         ~(a, s') <- runStateT m s         runStateT (k a) s'-    fail str = StateT $ \_ -> fail str+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail str = StateT $ \ _ -> fail str+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where+    fail str = StateT $ \ _ -> Fail.fail str+    {-# INLINE fail #-}+#endif+ instance (MonadPlus m) => MonadPlus (StateT s m) where-    mzero       = StateT $ \_ -> mzero-    m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s+    mzero       = StateT $ \ _ -> mzero+    {-# INLINE mzero #-}+    StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s+    {-# INLINE mplus #-}  instance (MonadFix m) => MonadFix (StateT s m) where-    mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s+    mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s+    {-# INLINE mfix #-}  instance MonadTrans (StateT s) where-    lift m = StateT $ \s -> do+    lift m = StateT $ \ s -> do         a <- m         return (a, s)+    {-# INLINE lift #-}  instance (MonadIO m) => MonadIO (StateT s m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (StateT s m) where+    contramap f m = StateT $ \s ->+      contramap (\ ~(a, s') -> (f a, s')) $ runStateT m s+    {-# INLINE contramap #-}+#endif+ -- | Fetch the current value of the state within the monad. get :: (Monad m) => StateT s m s-get = StateT $ \s -> return (s, s)+get = state $ \ s -> (s, s)+{-# INLINE get #-}  -- | @'put' s@ sets the state within the monad to @s@. put :: (Monad m) => s -> StateT s m ()-put s = StateT $ \_ -> return ((), s)+put s = state $ \ _ -> ((), s)+{-# INLINE put #-}  -- | @'modify' f@ is an action that updates the state to the result of -- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@ modify :: (Monad m) => (s -> s) -> StateT s m ()-modify f = do+modify f = state $ \ s -> ((), f s)+{-# INLINE modify #-}++-- | A variant of 'modify' in which the computation is strict in the+-- new state.+--+-- * @'modify'' f = 'get' >>= (('$!') 'put' . f)@+modify' :: (Monad m) => (s -> s) -> StateT s m ()+modify' f = do     s <- get-    put (f s)+    put $! f s+{-# INLINE modify' #-} +-- | A variant of 'modify' in which the new state is generated by a+-- monadic action.+modifyM :: (Monad m) => (s -> m s) -> StateT s m ()+modifyM f = StateT $ \ s -> do+    s' <- f s+    return ((), s')+{-# INLINE modifyM #-}+ -- | Get a specific component of the state, using a projection function -- supplied. -- -- * @'gets' f = 'liftM' f 'get'@ gets :: (Monad m) => (s -> a) -> StateT s m a-gets f = do-    s <- get-    return (f s)+gets f = state $ \ s -> (f s, s)+{-# INLINE gets #-}  -- | Uniform lifting of a @callCC@ operation to the new monad. -- This version rolls back to the original state on entering the -- continuation.-liftCallCC :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->-    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a-liftCallCC callCC f = StateT $ \s ->-    callCC $ \c ->-    runStateT (f (\a -> StateT $ \ _ -> c (a, s))) s+liftCallCC :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b+liftCallCC callCC f = StateT $ \ s ->+    callCC $ \ c ->+    runStateT (f (\ a -> StateT $ \ _ -> c (a, s))) s+{-# INLINE liftCallCC #-}  -- | In-situ lifting of a @callCC@ operation to the new monad. -- This version uses the current state on entering the continuation.--- It does not satisfy the laws of a monad transformer.-liftCallCC' :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->-    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a-liftCallCC' callCC f = StateT $ \s ->-    callCC $ \c ->-    runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s+-- It does not satisfy the uniformity property (see "Control.Monad.Signatures").+liftCallCC' :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b+liftCallCC' callCC f = StateT $ \ s ->+    callCC $ \ c ->+    runStateT (f (\ a -> StateT $ \ s' -> c (a, s'))) s+{-# INLINE liftCallCC' #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m (a,s) -> (e -> m (a,s)) -> m (a,s)) ->-    StateT s m a -> (e -> StateT s m a) -> StateT s m a-liftCatch catchError m h =-    StateT $ \s -> runStateT m s `catchError` \e -> runStateT (h e) s+-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies+-- that the lifted @catchE@ rolls back to the original state on entering+-- the handler.+liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a+liftCatch catchE m h =+    StateT $ \ s -> runStateT m s `catchE` \ e -> runStateT (h e) s+{-# INLINE liftCatch #-}  -- | Lift a @listen@ operation to the new monad.-liftListen :: Monad m =>-    (m (a,s) -> m ((a,s),w)) -> StateT s m a -> StateT s m (a,w)-liftListen listen m = StateT $ \s -> do+liftListen :: (Monad m) => Listen w m (a,s) -> Listen w (StateT s m) a+liftListen listen m = StateT $ \ s -> do     ~((a, s'), w) <- listen (runStateT m s)     return ((a, w), s')+{-# INLINE liftListen #-}  -- | Lift a @pass@ operation to the new monad.-liftPass :: Monad m =>-    (m ((a,s),b) -> m (a,s)) -> StateT s m (a,b) -> StateT s m a-liftPass pass m = StateT $ \s -> pass $ do+liftPass :: (Monad m) => Pass w m (a,s) -> Pass w (StateT s m) a+liftPass pass m = StateT $ \ s -> pass $ do     ~((a, f), s') <- runStateT m s     return ((a, s'), f)+{-# INLINE liftPass #-} +-- | Convert from the strict version to the lazy version+strictToLazyStateT :: Strict.StateT s m a -> StateT s m a+strictToLazyStateT (Strict.StateT f) = StateT f+{-# INLINE strictToLazyStateT #-}++-- | Convert from the lazy version to the strict version+lazyToStrictStateT :: StateT s m a -> Strict.StateT s m a+lazyToStrictStateT (StateT f) = Strict.StateT f+{-# INLINE lazyToStrictStateT #-}+ {- $examples  Parser from ParseLib with Hugs:@@ -288,9 +398,9 @@  {- $counting -A function to increment a counter.  Taken from the paper-/Generalising Monads to Arrows/, John-Hughes (<http://www.math.chalmers.se/~rjmh/>), November 1998:+A function to increment a counter.+Taken from the paper \"Generalising Monads to Arrows\",+John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998:  > tick :: State Int Int > tick = do n <- get@@ -325,30 +435,20 @@  > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) > numberTree Nil = return Nil-> numberTree (Node x t1 t2)->        =  do num <- numberNode x->              nt1 <- numberTree t1->              nt2 <- numberTree t2->              return (Node num nt1 nt2)->     where+> numberTree (Node x t1 t2) = do+>     num <- numberNode x+>     nt1 <- numberTree t1+>     nt2 <- numberTree t2+>     return (Node num nt1 nt2)+>   where >     numberNode :: Eq a => a -> State (Table a) Int->     numberNode x->        = do table <- get->             (newTable, newPos) <- return (nNode x table)->             put newTable->             return newPos->     nNode::  (Eq a) => a -> Table a -> (Table a, Int)->     nNode x table->        = case (findIndexInList (== x) table) of->          Nothing -> (table ++ [x], length table)->          Just i  -> (table, i)->     findIndexInList :: (a -> Bool) -> [a] -> Maybe Int->     findIndexInList = findIndexInListHelp 0->     findIndexInListHelp _ _ [] = Nothing->     findIndexInListHelp count f (h:t)->        = if (f h)->          then Just count->          else findIndexInListHelp (count+1) f t+>     numberNode x = do+>         table <- get+>         case elemIndex x table of+>             Nothing -> do+>                 put (table ++ [x])+>                 return (length table)+>             Just i -> return i  numTree applies numberTree with an initial state: @@ -357,11 +457,5 @@  > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil--sumTree is a little helper function that does not use the State monad:--> sumTree :: (Num a) => Tree a -> a-> sumTree Nil = 0-> sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)  -}
Control/Monad/Trans/State/Strict.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.State.Strict@@ -5,23 +13,24 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable ----- Strict state monads, passing an updateable state through a computation.+-- Strict state monads, passing an updatable state through a computation. -- See below for examples. ----- In this version, sequencing of computations is strict in the state.--- For a lazy version, see "Control.Monad.Trans.Writer.Lazy", which--- has the same interface.--- -- Some computations may not require the full power of state transformers: -- -- * For a read-only state, see "Control.Monad.Trans.Reader". -- -- * To accumulate a value without using it on the way, see --   "Control.Monad.Trans.Writer".+--+-- In this version, sequencing of computations is strict (but computations+-- are not strict in the state unless you force it with 'seq' or the like).+-- For a lazy version with the same interface, see+-- "Control.Monad.Trans.State.Lazy". -----------------------------------------------------------------------------  module Control.Monad.Trans.State.Strict (@@ -43,6 +52,8 @@     get,     put,     modify,+    modify',+    modifyM,     gets,     -- * Lifting other operations     liftCallCC,@@ -62,12 +73,22 @@   ) where  import Control.Monad.IO.Class+import Control.Monad.Signatures import Control.Monad.Trans.Class+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif import Data.Functor.Identity  import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  -- --------------------------------------------------------------------------- -- | A state monad parameterized by the type @s@ of the state to carry.@@ -79,9 +100,11 @@  -- | Construct a state monad computation from a function. -- (The inverse of 'runState'.)-state :: (s -> (a, s))  -- ^pure state transformer-      -> State s a      -- ^equivalent state-passing computation-state f = StateT (Identity . f)+state :: (Monad m)+      => (s -> (a, s))  -- ^pure state transformer+      -> StateT s m a   -- ^equivalent state-passing computation+state f = StateT (return . f)+{-# INLINE state #-}  -- | Unwrap a state monad computation as a function. -- (The inverse of 'state'.)@@ -89,6 +112,7 @@          -> s           -- ^initial state          -> (a, s)      -- ^return value and final state runState m = runIdentity . runStateT m+{-# INLINE runState #-}  -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state.@@ -98,6 +122,7 @@           -> s          -- ^initial value           -> a          -- ^return value of the state computation evalState m s = fst (runState m s)+{-# INLINE evalState #-}  -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value.@@ -107,6 +132,7 @@           -> s          -- ^initial value           -> s          -- ^final state execState m s = snd (runState m s)+{-# INLINE execState #-}  -- | Map both the return value and final state of a computation using -- the given function.@@ -114,6 +140,7 @@ -- * @'runState' ('mapState' f m) = f . 'runState' m@ mapState :: ((a, s) -> (b, s)) -> State s a -> State s b mapState f = mapStateT (Identity . f . runIdentity)+{-# INLINE mapState #-}  -- | @'withState' f m@ executes action @m@ on a state modified by -- applying @f@.@@ -121,6 +148,7 @@ -- * @'withState' f m = 'modify' f >> m@ withState :: (s -> s) -> State s a -> State s a withState = withStateT+{-# INLINE withState #-}  -- --------------------------------------------------------------------------- -- | A state transformer monad parameterized by:@@ -133,6 +161,9 @@ -- the final state of the first computation as the initial state of -- the second. newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif  -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state.@@ -142,6 +173,7 @@ evalStateT m s = do     (a, _) <- runStateT m s     return a+{-# INLINE evalStateT #-}  -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value.@@ -151,6 +183,7 @@ execStateT m s = do     (_, s') <- runStateT m s     return s'+{-# INLINE execStateT #-}  -- | Map both the return value and final state of a computation using -- the given function.@@ -158,6 +191,7 @@ -- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b mapStateT f m = StateT $ f . runStateT m+{-# INLINE mapStateT #-}  -- | @'withStateT' f m@ executes action @m@ on a state modified by -- applying @f@.@@ -165,102 +199,165 @@ -- * @'withStateT' f m = 'modify' f >> m@ withStateT :: (s -> s) -> StateT s m a -> StateT s m a withStateT f m = StateT $ runStateT m . f+{-# INLINE withStateT #-}  instance (Functor m) => Functor (StateT s m) where     fmap f m = StateT $ \ s ->         fmap (\ (a, s') -> (f a, s')) $ runStateT m s+    {-# INLINE fmap #-}  instance (Functor m, Monad m) => Applicative (StateT s m) where-    pure = return-    (<*>) = ap+    pure a = StateT $ \ s -> return (a, s)+    {-# INLINE pure #-}+    StateT mf <*> StateT mx = StateT $ \ s -> do+        (f, s') <- mf s+        (x, s'') <- mx s'+        return (f x, s'')+    {-# INLINE (<*>) #-}+    m *> k = m >>= \_ -> k+    {-# INLINE (*>) #-}  instance (Functor m, MonadPlus m) => Alternative (StateT s m) where-    empty = mzero-    (<|>) = mplus+    empty = StateT $ \ _ -> mzero+    {-# INLINE empty #-}+    StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s+    {-# INLINE (<|>) #-}  instance (Monad m) => Monad (StateT s m) where-    return a = StateT $ \s -> return (a, s)-    m >>= k  = StateT $ \s -> do+#if !(MIN_VERSION_base(4,8,0))+    return a = StateT $ \ s -> return (a, s)+    {-# INLINE return #-}+#endif+    m >>= k  = StateT $ \ s -> do         (a, s') <- runStateT m s         runStateT (k a) s'-    fail str = StateT $ \_ -> fail str+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail str = StateT $ \ _ -> fail str+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where+    fail str = StateT $ \ _ -> Fail.fail str+    {-# INLINE fail #-}+#endif+ instance (MonadPlus m) => MonadPlus (StateT s m) where-    mzero       = StateT $ \_ -> mzero-    m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s+    mzero       = StateT $ \ _ -> mzero+    {-# INLINE mzero #-}+    StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s+    {-# INLINE mplus #-}  instance (MonadFix m) => MonadFix (StateT s m) where-    mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s+    mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s+    {-# INLINE mfix #-}  instance MonadTrans (StateT s) where-    lift m = StateT $ \s -> do+    lift m = StateT $ \ s -> do         a <- m         return (a, s)+    {-# INLINE lift #-}  instance (MonadIO m) => MonadIO (StateT s m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (StateT s m) where+    contramap f m = StateT $ \s ->+      contramap (\ (a, s') -> (f a, s')) $ runStateT m s+    {-# INLINE contramap #-}+#endif+ -- | Fetch the current value of the state within the monad. get :: (Monad m) => StateT s m s-get = StateT $ \s -> return (s, s)+get = state $ \ s -> (s, s)+{-# INLINE get #-}  -- | @'put' s@ sets the state within the monad to @s@. put :: (Monad m) => s -> StateT s m ()-put s = StateT $ \_ -> return ((), s)+put s = state $ \ _ -> ((), s)+{-# INLINE put #-}  -- | @'modify' f@ is an action that updates the state to the result of -- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@ modify :: (Monad m) => (s -> s) -> StateT s m ()-modify f = do+modify f = state $ \ s -> ((), f s)+{-# INLINE modify #-}++-- | A variant of 'modify' in which the computation is strict in the+-- new state.+--+-- * @'modify'' f = 'get' >>= (('$!') 'put' . f)@+--+-- Note that this is only strict in the top level of the state.+-- Lazy components of the state will not be evaluated unless @f@+-- evaluates them.+modify' :: (Monad m) => (s -> s) -> StateT s m ()+modify' f = do     s <- get-    put (f s)+    put $! f s+{-# INLINE modify' #-} +-- | A variant of 'modify' in which the new state is generated by a+-- monadic action.+modifyM :: (Monad m) => (s -> m s) -> StateT s m ()+modifyM f = StateT $ \ s -> do+    s' <- f s+    return ((), s')+{-# INLINE modifyM #-}+ -- | Get a specific component of the state, using a projection function -- supplied. -- -- * @'gets' f = 'liftM' f 'get'@ gets :: (Monad m) => (s -> a) -> StateT s m a-gets f = do-    s <- get-    return (f s)+gets f = state $ \ s -> (f s, s)+{-# INLINE gets #-}  -- | Uniform lifting of a @callCC@ operation to the new monad. -- This version rolls back to the original state on entering the -- continuation.-liftCallCC :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->-    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a-liftCallCC callCC f = StateT $ \s ->-    callCC $ \c ->-    runStateT (f (\a -> StateT $ \ _ -> c (a, s))) s+liftCallCC :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b+liftCallCC callCC f = StateT $ \ s ->+    callCC $ \ c ->+    runStateT (f (\ a -> StateT $ \ _ -> c (a, s))) s+{-# INLINE liftCallCC #-}  -- | In-situ lifting of a @callCC@ operation to the new monad. -- This version uses the current state on entering the continuation.--- It does not satisfy the laws of a monad transformer.-liftCallCC' :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->-    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a-liftCallCC' callCC f = StateT $ \s ->-    callCC $ \c ->-    runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s+-- It does not satisfy the uniformity property (see "Control.Monad.Signatures").+liftCallCC' :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b+liftCallCC' callCC f = StateT $ \ s ->+    callCC $ \ c ->+    runStateT (f (\ a -> StateT $ \ s' -> c (a, s'))) s+{-# INLINE liftCallCC' #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m (a,s) -> (e -> m (a,s)) -> m (a,s)) ->-    StateT s m a -> (e -> StateT s m a) -> StateT s m a-liftCatch catchError m h =-    StateT $ \s -> runStateT m s `catchError` \e -> runStateT (h e) s+-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies+-- that the lifted @catchE@ rolls back to the original state on entering+-- the handler.+liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a+liftCatch catchE m h =+    StateT $ \ s -> runStateT m s `catchE` \ e -> runStateT (h e) s+{-# INLINE liftCatch #-}  -- | Lift a @listen@ operation to the new monad.-liftListen :: Monad m =>-    (m (a,s) -> m ((a,s),w)) -> StateT s m a -> StateT s m (a,w)-liftListen listen m = StateT $ \s -> do+liftListen :: (Monad m) => Listen w m (a,s) -> Listen w (StateT s m) a+liftListen listen m = StateT $ \ s -> do     ((a, s'), w) <- listen (runStateT m s)     return ((a, w), s')+{-# INLINE liftListen #-}  -- | Lift a @pass@ operation to the new monad.-liftPass :: Monad m =>-    (m ((a,s),b) -> m (a,s)) -> StateT s m (a,b) -> StateT s m a-liftPass pass m = StateT $ \s -> pass $ do+liftPass :: (Monad m) => Pass w m (a,s) -> Pass w (StateT s m) a+liftPass pass m = StateT $ \ s -> pass $ do     ((a, f), s') <- runStateT m s     return ((a, s'), f)+{-# INLINE liftPass #-}  {- $examples @@ -288,9 +385,9 @@  {- $counting -A function to increment a counter.  Taken from the paper-/Generalising Monads to Arrows/, John-Hughes (<http://www.math.chalmers.se/~rjmh/>), November 1998:+A function to increment a counter.+Taken from the paper \"Generalising Monads to Arrows\",+John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998:  > tick :: State Int Int > tick = do n <- get@@ -325,30 +422,20 @@  > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) > numberTree Nil = return Nil-> numberTree (Node x t1 t2)->        =  do num <- numberNode x->              nt1 <- numberTree t1->              nt2 <- numberTree t2->              return (Node num nt1 nt2)->     where+> numberTree (Node x t1 t2) = do+>     num <- numberNode x+>     nt1 <- numberTree t1+>     nt2 <- numberTree t2+>     return (Node num nt1 nt2)+>   where >     numberNode :: Eq a => a -> State (Table a) Int->     numberNode x->        = do table <- get->             (newTable, newPos) <- return (nNode x table)->             put newTable->             return newPos->     nNode::  (Eq a) => a -> Table a -> (Table a, Int)->     nNode x table->        = case (findIndexInList (== x) table) of->          Nothing -> (table ++ [x], length table)->          Just i  -> (table, i)->     findIndexInList :: (a -> Bool) -> [a] -> Maybe Int->     findIndexInList = findIndexInListHelp 0->     findIndexInListHelp _ _ [] = Nothing->     findIndexInListHelp count f (h:t)->        = if (f h)->          then Just count->          else findIndexInListHelp (count+1) f t+>     numberNode x = do+>         table <- get+>         case elemIndex x table of+>             Nothing -> do+>                 put (table ++ [x])+>                 return (length table)+>             Just i -> return i  numTree applies numberTree with an initial state: @@ -357,11 +444,5 @@  > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil--sumTree is a little helper function that does not use the State monad:--> sumTree :: (Num a) => Tree a -> a-> sumTree Nil = 0-> sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)  -}
Control/Monad/Trans/Writer.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Writer@@ -5,13 +9,13 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable -- -- The WriterT monad transformer.--- This version is lazy; for a strict version, see--- "Control.Monad.Trans.Writer.Strict", which has the same interface.+-- This version builds its output lazily; for a constant-space version+-- with almost the same interface, see "Control.Monad.Trans.Writer.CPS". -----------------------------------------------------------------------------  module Control.Monad.Trans.Writer (
+ Control/Monad/Trans/Writer/CPS.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Writer.CPS+-- Copyright   :  (c) Daniel Mendler 2016,+--                (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The strict 'WriterT' monad transformer, which adds collection of+-- outputs (such as a count or string output) to a given monad.+--+-- This monad transformer provides only limited access to the output+-- during the computation. For more general access, use+-- "Control.Monad.Trans.State" instead.+--+-- This version builds its output strictly and uses continuation-passing-style+-- to achieve constant space usage. This transformer can be used as a+-- drop-in replacement for "Control.Monad.Trans.Writer.Strict".+-----------------------------------------------------------------------------++module Control.Monad.Trans.Writer.CPS (+    -- * The Writer monad+    Writer,+    writer,+    runWriter,+    execWriter,+    mapWriter,+    -- * The WriterT monad transformer+    WriterT,+    writerT,+    runWriterT,+    execWriterT,+    mapWriterT,+    -- * Writer operations+    tell,+    listen,+    listens,+    pass,+    censor,+    -- * Lifting other operations+    liftCallCC,+    liftCatch,+  ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Signatures+import Data.Functor.Identity++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- ---------------------------------------------------------------------------+-- | A writer monad parameterized by the type @w@ of output to accumulate.+--+-- The 'return' function produces the output 'mempty', while @m '>>=' k@+-- combines the outputs of the subcomputations using 'mappend' (also+-- known as @<>@):+--+-- <<images/bind-WriterT.svg>>+--+type Writer w = WriterT w Identity++-- | Construct a writer computation from a (result, output) pair.+-- (The inverse of 'runWriter'.)+writer :: (Monoid w, Monad m) => (a, w) -> WriterT w m a+writer (a, w') = WriterT $ \ w ->+    let wt = w `mappend` w' in wt `seq` return (a, wt)+{-# INLINE writer #-}++-- | Unwrap a writer computation as a (result, output) pair.+-- (The inverse of 'writer'.)+runWriter :: (Monoid w) => Writer w a -> (a, w)+runWriter = runIdentity . runWriterT+{-# INLINE runWriter #-}++-- | Extract the output from a writer computation.+--+-- * @'execWriter' m = 'snd' ('runWriter' m)@+execWriter :: (Monoid w) => Writer w a -> w+execWriter = runIdentity . execWriterT+{-# INLINE execWriter #-}++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@+mapWriter :: (Monoid w, Monoid w') =>+    ((a, w) -> (b, w')) -> Writer w a -> Writer w' b+mapWriter f = mapWriterT (Identity . f . runIdentity)+{-# INLINE mapWriter #-}++-- ---------------------------------------------------------------------------+-- | A writer monad parameterized by:+--+--   * @w@ - the output to accumulate.+--+--   * @m@ - The inner monad.+--+-- The 'return' function produces the output 'mempty', while @m '>>=' k@+-- combines the outputs of the subcomputations using 'mappend' (also+-- known as @<>@):+--+-- <<images/bind-WriterT.svg>>+--+newtype WriterT w m a = WriterT { unWriterT :: w -> m (a, w) }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++-- | Construct a writer computation from a (result, output) computation.+-- (The inverse of 'runWriterT'.)+writerT :: (Functor m, Monoid w) => m (a, w) -> WriterT w m a+writerT f = WriterT $ \ w ->+    (\ (a, w') -> let wt = w `mappend` w' in wt `seq` (a, wt)) <$> f+{-# INLINE writerT #-}++-- | Unwrap a writer computation.+-- (The inverse of 'writerT'.)+runWriterT :: (Monoid w) => WriterT w m a -> m (a, w)+runWriterT m = unWriterT m mempty+{-# INLINE runWriterT #-}++-- | Extract the output from a writer computation.+--+-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@+execWriterT :: (Monad m, Monoid w) => WriterT w m a -> m w+execWriterT m = do+    (_, w) <- runWriterT m+    return w+{-# INLINE execWriterT #-}++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@+mapWriterT :: (Monad n, Monoid w, Monoid w') =>+    (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b+mapWriterT f m = WriterT $ \ w -> do+    (a, w') <- f (runWriterT m)+    let wt = w `mappend` w'+    wt `seq` return (a, wt)+{-# INLINE mapWriterT #-}++instance (Functor m) => Functor (WriterT w m) where+    fmap f m = WriterT $ \ w -> (\ (a, w') -> (f a, w')) <$> unWriterT m w+    {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (WriterT w m) where+    pure a = WriterT $ \ w -> return (a, w)+    {-# INLINE pure #-}++    WriterT mf <*> WriterT mx = WriterT $ \ w -> do+        (f, w') <- mf w+        (x, w'') <- mx w'+        return (f x, w'')+    {-# INLINE (<*>) #-}++instance (Functor m, MonadPlus m) => Alternative (WriterT w m) where+    empty = WriterT $ const mzero+    {-# INLINE empty #-}++    WriterT m <|> WriterT n = WriterT $ \ w -> m w `mplus` n w+    {-# INLINE (<|>) #-}++instance (Monad m) => Monad (WriterT w m) where+#if !(MIN_VERSION_base(4,8,0))+    return a = WriterT $ \ w -> return (a, w)+    {-# INLINE return #-}+#endif++    m >>= k = WriterT $ \ w -> do+        (a, w') <- unWriterT m w+        unWriterT (k a) w'+    {-# INLINE (>>=) #-}++#if !(MIN_VERSION_base(4,13,0))+    fail msg = WriterT $ \ _ -> fail msg+    {-# INLINE fail #-}+#endif++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where+    fail msg = WriterT $ \ _ -> Fail.fail msg+    {-# INLINE fail #-}+#endif++instance (Functor m, MonadPlus m) => MonadPlus (WriterT w m) where+    mzero = empty+    {-# INLINE mzero #-}+    mplus = (<|>)+    {-# INLINE mplus #-}++instance (MonadFix m) => MonadFix (WriterT w m) where+    mfix f = WriterT $ \ w -> mfix $ \ ~(a, _) -> unWriterT (f a) w+    {-# INLINE mfix #-}++instance MonadTrans (WriterT w) where+    lift m = WriterT $ \ w -> do+        a <- m+        return (a, w)+    {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (WriterT w m) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}++-- | @'tell' w@ is an action that produces the output @w@.+tell :: (Monoid w, Monad m) => w -> WriterT w m ()+tell w = writer ((), w)+{-# INLINE tell #-}++-- | @'listen' m@ is an action that executes the action @m@ and adds its+-- output to the value of the computation.+--+-- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@+listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w)+listen = listens id+{-# INLINE listen #-}++-- | @'listens' f m@ is an action that executes the action @m@ and adds+-- the result of applying @f@ to the output to the value of the computation.+--+-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@+--+-- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@+listens :: (Monoid w, Monad m) =>+    (w -> b) -> WriterT w m a -> WriterT w m (a, b)+listens f m = WriterT $ \ w -> do+    (a, w') <- runWriterT m+    let wt = w `mappend` w'+    wt `seq` return ((a, f w'), wt)+{-# INLINE listens #-}++-- | @'pass' m@ is an action that executes the action @m@, which returns+-- a value and a function, and returns the value, applying the function+-- to the output.+--+-- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@+pass :: (Monoid w, Monoid w', Monad m) =>+    WriterT w m (a, w -> w') -> WriterT w' m a+pass m = WriterT $ \ w -> do+    ((a, f), w') <- runWriterT m+    let wt = w `mappend` f w'+    wt `seq` return (a, wt)+{-# INLINE pass #-}++-- | @'censor' f m@ is an action that executes the action @m@ and+-- applies the function @f@ to its output, leaving the return value+-- unchanged.+--+-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@+--+-- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@+censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a+censor f m = WriterT $ \ w -> do+    (a, w') <- runWriterT m+    let wt = w `mappend` f w'+    wt `seq` return (a, wt)+{-# INLINE censor #-}++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @callCC@ discards any output from the body on entering+-- the saved continuation.+liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (WriterT w m) a b+liftCallCC callCC f = WriterT $ \ w ->+    callCC $ \ c -> unWriterT (f (\ a -> WriterT $ \ _ -> c (a, w))) w+{-# INLINE liftCallCC #-}++-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @catchE@ discards any output from the body on entering+-- the handler.+liftCatch :: Catch e m (a, w) -> Catch e (WriterT w m) a+liftCatch catchE m h = WriterT $ \ w ->+    unWriterT m w `catchE` \ e -> unWriterT (h e) w+{-# INLINE liftCatch #-}
Control/Monad/Trans/Writer/Lazy.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Writer.Lazy@@ -5,19 +13,19 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable -- -- The lazy 'WriterT' monad transformer, which adds collection of -- outputs (such as a count or string output) to a given monad. ----- This version builds its output lazily; for a strict version, see--- "Control.Monad.Trans.Writer.Strict", which has the same interface.--- -- This monad transformer provides only limited access to the output -- during the computation.  For more general access, use -- "Control.Monad.Trans.State" instead.+--+-- This version builds its output lazily; for a constant-space version+-- with almost the same interface, see "Control.Monad.Trans.Writer.CPS". -----------------------------------------------------------------------------  module Control.Monad.Trans.Writer.Lazy (@@ -44,42 +52,69 @@  import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif import Data.Functor.Identity  import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix+import Control.Monad.Signatures+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+import Data.Foldable import Data.Monoid+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Traversable (Traversable(traverse))+#endif+import Prelude hiding (null, length)+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  -- --------------------------------------------------------------------------- -- | A writer monad parameterized by the type @w@ of output to accumulate. ----- The 'return' function produces the output 'mempty', while @>>=@--- combines the outputs of the subcomputations using 'mappend'.+-- The 'return' function produces the output 'mempty', while @m '>>=' k@+-- combines the outputs of the subcomputations using 'mappend' (also+-- known as @<>@):+--+-- <<images/bind-WriterT.svg>>+-- type Writer w = WriterT w Identity  -- | Construct a writer computation from a (result, output) pair. -- (The inverse of 'runWriter'.)-writer :: (a, w) -> Writer w a-writer = WriterT . Identity+writer :: (Monad m) => (a, w) -> WriterT w m a+writer = WriterT . return+{-# INLINE writer #-}  -- | Unwrap a writer computation as a (result, output) pair. -- (The inverse of 'writer'.) runWriter :: Writer w a -> (a, w) runWriter = runIdentity . runWriterT+{-# INLINE runWriter #-}  -- | Extract the output from a writer computation. -- -- * @'execWriter' m = 'snd' ('runWriter' m)@ execWriter :: Writer w a -> w execWriter m = snd (runWriter m)+{-# INLINE execWriter #-}  -- | Map both the return value and output of a computation using -- the given function. ----- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m@)+-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b mapWriter f = mapWriterT (Identity . f . runIdentity)+{-# INLINE mapWriter #-}  -- --------------------------------------------------------------------------- -- | A writer monad parameterized by:@@ -88,115 +123,214 @@ -- --   * @m@ - The inner monad. ----- The 'return' function produces the output 'mempty', while @>>=@--- combines the outputs of the subcomputations using 'mappend'.+-- The 'return' function produces the output 'mempty', while @m '>>=' k@+-- combines the outputs of the subcomputations using 'mappend' (also+-- known as @<>@):+--+-- <<images/bind-WriterT.svg>>+-- newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif +instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where+    liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2+    {-# INLINE liftEq #-}++instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where+    liftCompare comp (WriterT m1) (WriterT m2) =+        liftCompare (liftCompare2 comp compare) m1 m2+    {-# INLINE liftCompare #-}++instance (Read w, Read1 m) => Read1 (WriterT w m) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT+      where+        rp' = liftReadsPrec2 rp rl readsPrec readList+        rl' = liftReadList2 rp rl readsPrec readList++instance (Show w, Show1 m) => Show1 (WriterT w m) where+    liftShowsPrec sp sl d (WriterT m) =+        showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m+      where+        sp' = liftShowsPrec2 sp sl showsPrec showList+        sl' = liftShowList2 sp sl showsPrec showList++instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1+instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1+instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where+    readsPrec = readsPrec1+instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where+    showsPrec = showsPrec1+ -- | Extract the output from a writer computation. -- -- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@-execWriterT :: Monad m => WriterT w m a -> m w+execWriterT :: (Monad m) => WriterT w m a -> m w execWriterT m = do     ~(_, w) <- runWriterT m     return w+{-# INLINE execWriterT #-}  -- | Map both the return value and output of a computation using -- the given function. ----- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m@)+-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b mapWriterT f m = WriterT $ f (runWriterT m)+{-# INLINE mapWriterT #-}  instance (Functor m) => Functor (WriterT w m) where     fmap f = mapWriterT $ fmap $ \ ~(a, w) -> (f a, w)+    {-# INLINE fmap #-} +instance (Foldable f) => Foldable (WriterT w f) where+    foldMap f = foldMap (f . fst) . runWriterT+    {-# INLINE foldMap #-}+#if MIN_VERSION_base(4,8,0)+    null (WriterT t) = null t+    length (WriterT t) = length t+#endif++instance (Traversable f) => Traversable (WriterT w f) where+    traverse f = fmap WriterT . traverse f' . runWriterT where+       f' (a, b) = fmap (\ c -> (c, b)) (f a)+    {-# INLINE traverse #-}+ instance (Monoid w, Applicative m) => Applicative (WriterT w m) where     pure a  = WriterT $ pure (a, mempty)+    {-# INLINE pure #-}     f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v)       where k ~(a, w) ~(b, w') = (a b, w `mappend` w')+    {-# INLINE (<*>) #-}  instance (Monoid w, Alternative m) => Alternative (WriterT w m) where     empty   = WriterT empty+    {-# INLINE empty #-}     m <|> n = WriterT $ runWriterT m <|> runWriterT n+    {-# INLINE (<|>) #-}  instance (Monoid w, Monad m) => Monad (WriterT w m) where-    return a = WriterT $ return (a, mempty)+#if !(MIN_VERSION_base(4,8,0))+    return a = writer (a, mempty)+    {-# INLINE return #-}+#endif     m >>= k  = WriterT $ do         ~(a, w)  <- runWriterT m         ~(b, w') <- runWriterT (k a)         return (b, w `mappend` w')+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))     fail msg = WriterT $ fail msg+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where+    fail msg = WriterT $ Fail.fail msg+    {-# INLINE fail #-}+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where     mzero       = WriterT mzero+    {-# INLINE mzero #-}     m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n+    {-# INLINE mplus #-}  instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where     mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)+    {-# INLINE mfix #-}  instance (Monoid w) => MonadTrans (WriterT w) where     lift m = WriterT $ do         a <- m         return (a, mempty)+    {-# INLINE lift #-}  instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,4,0)+instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where+    mzipWith f (WriterT x) (WriterT y) = WriterT $+        mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y+    {-# INLINE mzipWith #-}+#endif++#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (WriterT w m) where+    contramap f = mapWriterT $ contramap $ \ ~(a, w) -> (f a, w)+    {-# INLINE contramap #-}+#endif+ -- | @'tell' w@ is an action that produces the output @w@.-tell :: (Monoid w, Monad m) => w -> WriterT w m ()-tell w = WriterT $ return ((), w)+tell :: (Monad m) => w -> WriterT w m ()+tell w = writer ((), w)+{-# INLINE tell #-}  -- | @'listen' m@ is an action that executes the action @m@ and adds its -- output to the value of the computation. ----- * @'runWriterT' ('listen' m) = 'liftM' (\\(a, w) -> ((a, w), w)) ('runWriterT' m)@-listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w)+-- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@+listen :: (Monad m) => WriterT w m a -> WriterT w m (a, w) listen m = WriterT $ do     ~(a, w) <- runWriterT m     return ((a, w), w)+{-# INLINE listen #-}  -- | @'listens' f m@ is an action that executes the action @m@ and adds -- the result of applying @f@ to the output to the value of the computation. -- -- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ ----- * @'runWriterT' ('listens' f m) = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runWriterT' m)@-listens :: (Monoid w, Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b)-listens f m = do-    ~(a, w) <- listen m-    return (a, f w)+-- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@+listens :: (Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b)+listens f m = WriterT $ do+    ~(a, w) <- runWriterT m+    return ((a, f w), w)+{-# INLINE listens #-}  -- | @'pass' m@ is an action that executes the action @m@, which returns -- a value and a function, and returns the value, applying the function -- to the output. ----- * @'runWriterT' ('pass' m) = 'liftM' (\\((a, f), w) -> (a, f w)) ('runWriterT' m)@-pass :: (Monoid w, Monad m) => WriterT w m (a, w -> w) -> WriterT w m a+-- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@+pass :: (Monad m) => WriterT w m (a, w -> w) -> WriterT w m a pass m = WriterT $ do     ~((a, f), w) <- runWriterT m     return (a, f w)+{-# INLINE pass #-}  -- | @'censor' f m@ is an action that executes the action @m@ and -- applies the function @f@ to its output, leaving the return value -- unchanged. ----- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@+-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ ----- * @'runWriterT' ('censor' f m) = 'liftM' (\\(a, w) -> (a, f w)) ('runWriterT' m)@-censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a-censor f m = pass $ do-    a <- m-    return (a, f)+-- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@+censor :: (Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a+censor f m = WriterT $ do+    ~(a, w) <- runWriterT m+    return (a, f w)+{-# INLINE censor #-}  -- | Lift a @callCC@ operation to the new monad.-liftCallCC :: (Monoid w) => ((((a,w) -> m (b,w)) -> m (a,w)) -> m (a,w)) ->-    ((a -> WriterT w m b) -> WriterT w m a) -> WriterT w m a+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @callCC@ discards any output from the body on entering+-- the saved condinuation.+liftCallCC :: (Monoid w) => CallCC m (a,w) (b,w) -> CallCC (WriterT w m) a b liftCallCC callCC f = WriterT $-    callCC $ \c ->-    runWriterT (f (\a -> WriterT $ c (a, mempty)))+    callCC $ \ c ->+    runWriterT (f (\ a -> WriterT $ c (a, mempty)))+{-# INLINE liftCallCC #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m (a,w) -> (e -> m (a,w)) -> m (a,w)) ->-    WriterT w m a -> (e -> WriterT w m a) -> WriterT w m a-liftCatch catchError m h =-    WriterT $ runWriterT m `catchError` \e -> runWriterT (h e)+-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @catchE@ discards any output from the body on entering+-- the handler.+liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a+liftCatch catchE m h =+    WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e)+{-# INLINE liftCatch #-}
Control/Monad/Trans/Writer/Strict.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Writer.Strict@@ -5,19 +13,22 @@ --                (c) Oregon Graduate Institute of Science and Technology, 2001 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable -- -- The strict 'WriterT' monad transformer, which adds collection of -- outputs (such as a count or string output) to a given monad. ----- This version builds its output strictly; for a lazy version, see--- "Control.Monad.Trans.Writer.Lazy", which has the same interface.--- -- This monad transformer provides only limited access to the output -- during the computation.  For more general access, use -- "Control.Monad.Trans.State" instead.+--+-- This version builds its output strictly; for a lazy version with+-- the same interface, see "Control.Monad.Trans.Writer.Lazy".+-- Although the output is built strictly, it is not possible to+-- achieve constant space behaviour with this transformer: for that,+-- use "Control.Monad.Trans.Writer.CPS" instead. -----------------------------------------------------------------------------  module Control.Monad.Trans.Writer.Strict (@@ -44,42 +55,69 @@  import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif import Data.Functor.Identity  import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix+import Control.Monad.Signatures+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+import Data.Foldable import Data.Monoid+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Traversable (Traversable(traverse))+#endif+import Prelude hiding (null, length)+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  -- --------------------------------------------------------------------------- -- | A writer monad parameterized by the type @w@ of output to accumulate. ----- The 'return' function produces the output 'mempty', while @>>=@--- combines the outputs of the subcomputations using 'mappend'.+-- The 'return' function produces the output 'mempty', while @m '>>=' k@+-- combines the outputs of the subcomputations using 'mappend' (also+-- known as @<>@):+--+-- <<images/bind-WriterT.svg>>+-- type Writer w = WriterT w Identity  -- | Construct a writer computation from a (result, output) pair. -- (The inverse of 'runWriter'.)-writer :: (a, w) -> Writer w a-writer = WriterT . Identity+writer :: (Monad m) => (a, w) -> WriterT w m a+writer = WriterT . return+{-# INLINE writer #-}  -- | Unwrap a writer computation as a (result, output) pair. -- (The inverse of 'writer'.) runWriter :: Writer w a -> (a, w) runWriter = runIdentity . runWriterT+{-# INLINE runWriter #-}  -- | Extract the output from a writer computation. -- -- * @'execWriter' m = 'snd' ('runWriter' m)@ execWriter :: Writer w a -> w execWriter m = snd (runWriter m)+{-# INLINE execWriter #-}  -- | Map both the return value and output of a computation using -- the given function. ----- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m@)+-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b mapWriter f = mapWriterT (Identity . f . runIdentity)+{-# INLINE mapWriter #-}  -- --------------------------------------------------------------------------- -- | A writer monad parameterized by:@@ -88,115 +126,214 @@ -- --   * @m@ - The inner monad. ----- The 'return' function produces the output 'mempty', while @>>=@--- combines the outputs of the subcomputations using 'mappend'.+-- The 'return' function produces the output 'mempty', while @m '>>=' k@+-- combines the outputs of the subcomputations using 'mappend' (also+-- known as @<>@):+--+-- <<images/bind-WriterT.svg>>+-- newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }+#if __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif +instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where+    liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2+    {-# INLINE liftEq #-}++instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where+    liftCompare comp (WriterT m1) (WriterT m2) =+        liftCompare (liftCompare2 comp compare) m1 m2+    {-# INLINE liftCompare #-}++instance (Read w, Read1 m) => Read1 (WriterT w m) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT+      where+        rp' = liftReadsPrec2 rp rl readsPrec readList+        rl' = liftReadList2 rp rl readsPrec readList++instance (Show w, Show1 m) => Show1 (WriterT w m) where+    liftShowsPrec sp sl d (WriterT m) =+        showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m+      where+        sp' = liftShowsPrec2 sp sl showsPrec showList+        sl' = liftShowList2 sp sl showsPrec showList++instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1+instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1+instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where+    readsPrec = readsPrec1+instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where+    showsPrec = showsPrec1+ -- | Extract the output from a writer computation. -- -- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@-execWriterT :: Monad m => WriterT w m a -> m w+execWriterT :: (Monad m) => WriterT w m a -> m w execWriterT m = do     (_, w) <- runWriterT m     return w+{-# INLINE execWriterT #-}  -- | Map both the return value and output of a computation using -- the given function. ----- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m@)+-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b mapWriterT f m = WriterT $ f (runWriterT m)+{-# INLINE mapWriterT #-}  instance (Functor m) => Functor (WriterT w m) where     fmap f = mapWriterT $ fmap $ \ (a, w) -> (f a, w)+    {-# INLINE fmap #-} +instance (Foldable f) => Foldable (WriterT w f) where+    foldMap f = foldMap (f . fst) . runWriterT+    {-# INLINE foldMap #-}+#if MIN_VERSION_base(4,8,0)+    null (WriterT t) = null t+    length (WriterT t) = length t+#endif++instance (Traversable f) => Traversable (WriterT w f) where+    traverse f = fmap WriterT . traverse f' . runWriterT where+       f' (a, b) = fmap (\ c -> (c, b)) (f a)+    {-# INLINE traverse #-}+ instance (Monoid w, Applicative m) => Applicative (WriterT w m) where     pure a  = WriterT $ pure (a, mempty)+    {-# INLINE pure #-}     f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v)       where k (a, w) (b, w') = (a b, w `mappend` w')+    {-# INLINE (<*>) #-}  instance (Monoid w, Alternative m) => Alternative (WriterT w m) where     empty   = WriterT empty+    {-# INLINE empty #-}     m <|> n = WriterT $ runWriterT m <|> runWriterT n+    {-# INLINE (<|>) #-}  instance (Monoid w, Monad m) => Monad (WriterT w m) where-    return a = WriterT $ return (a, mempty)+#if !(MIN_VERSION_base(4,8,0))+    return a = writer (a, mempty)+    {-# INLINE return #-}+#endif     m >>= k  = WriterT $ do         (a, w)  <- runWriterT m         (b, w') <- runWriterT (k a)         return (b, w `mappend` w')+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))     fail msg = WriterT $ fail msg+    {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where+    fail msg = WriterT $ Fail.fail msg+    {-# INLINE fail #-}+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where     mzero       = WriterT mzero+    {-# INLINE mzero #-}     m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n+    {-# INLINE mplus #-}  instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where     mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)+    {-# INLINE mfix #-}  instance (Monoid w) => MonadTrans (WriterT w) where     lift m = WriterT $ do         a <- m         return (a, mempty)+    {-# INLINE lift #-}  instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where     liftIO = lift . liftIO+    {-# INLINE liftIO #-} +#if MIN_VERSION_base(4,4,0)+instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where+    mzipWith f (WriterT x) (WriterT y) = WriterT $+        mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y+    {-# INLINE mzipWith #-}+#endif++#if MIN_VERSION_base(4,12,0)+instance Contravariant m => Contravariant (WriterT w m) where+    contramap f = mapWriterT $ contramap $ \ (a, w) -> (f a, w)+    {-# INLINE contramap #-}+#endif+ -- | @'tell' w@ is an action that produces the output @w@.-tell :: (Monoid w, Monad m) => w -> WriterT w m ()-tell w = WriterT $ return ((), w)+tell :: (Monad m) => w -> WriterT w m ()+tell w = writer ((), w)+{-# INLINE tell #-}  -- | @'listen' m@ is an action that executes the action @m@ and adds its -- output to the value of the computation. ----- * @'runWriterT' ('listen' m) = 'liftM' (\\(a, w) -> ((a, w), w)) ('runWriterT' m)@-listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w)+-- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@+listen :: (Monad m) => WriterT w m a -> WriterT w m (a, w) listen m = WriterT $ do     (a, w) <- runWriterT m     return ((a, w), w)+{-# INLINE listen #-}  -- | @'listens' f m@ is an action that executes the action @m@ and adds -- the result of applying @f@ to the output to the value of the computation. -- -- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ ----- * @'runWriterT' ('listens' f m) = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runWriterT' m)@-listens :: (Monoid w, Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b)-listens f m = do-    (a, w) <- listen m-    return (a, f w)+-- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@+listens :: (Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b)+listens f m = WriterT $ do+    (a, w) <- runWriterT m+    return ((a, f w), w)+{-# INLINE listens #-}  -- | @'pass' m@ is an action that executes the action @m@, which returns -- a value and a function, and returns the value, applying the function -- to the output. ----- * @'runWriterT' ('pass' m) = 'liftM' (\\((a, f), w) -> (a, f w)) ('runWriterT' m)@-pass :: (Monoid w, Monad m) => WriterT w m (a, w -> w) -> WriterT w m a+-- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@+pass :: (Monad m) => WriterT w m (a, w -> w) -> WriterT w m a pass m = WriterT $ do     ((a, f), w) <- runWriterT m     return (a, f w)+{-# INLINE pass #-}  -- | @'censor' f m@ is an action that executes the action @m@ and -- applies the function @f@ to its output, leaving the return value -- unchanged. ----- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@+-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ ----- * @'runWriterT' ('censor' f m) = 'liftM' (\\(a, w) -> (a, f w)) ('runWriterT' m)@-censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a-censor f m = pass $ do-    a <- m-    return (a, f)+-- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@+censor :: (Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a+censor f m = WriterT $ do+    (a, w) <- runWriterT m+    return (a, f w)+{-# INLINE censor #-}  -- | Lift a @callCC@ operation to the new monad.-liftCallCC :: (Monoid w) => ((((a,w) -> m (b,w)) -> m (a,w)) -> m (a,w)) ->-    ((a -> WriterT w m b) -> WriterT w m a) -> WriterT w m a+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @callCC@ discards any output from the body on entering+-- the saved continuation.+liftCallCC :: (Monoid w) => CallCC m (a,w) (b,w) -> CallCC (WriterT w m) a b liftCallCC callCC f = WriterT $-    callCC $ \c ->-    runWriterT (f (\a -> WriterT $ c (a, mempty)))+    callCC $ \ c ->+    runWriterT (f (\ a -> WriterT $ c (a, mempty)))+{-# INLINE liftCallCC #-} --- | Lift a @catchError@ operation to the new monad.-liftCatch :: (m (a,w) -> (e -> m (a,w)) -> m (a,w)) ->-    WriterT w m a -> (e -> WriterT w m a) -> WriterT w m a-liftCatch catchError m h =-    WriterT $ runWriterT m `catchError` \e -> runWriterT (h e)+-- | Lift a @catchE@ operation to the new monad.+-- The uniformity property (see "Control.Monad.Signatures") implies that+-- the lifted @catchE@ discards any output from the body on entering+-- the handler.+liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a+liftCatch catchE m h =+    WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e)+{-# INLINE liftCatch #-}
− Data/Functor/Compose.hs 
@@ -1,40 +0,0 @@--- |--- Module      :  Data.Functor.Compose--- Copyright   :  (c) Ross Paterson 2010--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  portable------ Composition of functors.--module Data.Functor.Compose (-    Compose(..),-   ) where--import Control.Applicative-import Data.Foldable (Foldable(foldMap))-import Data.Traversable (Traversable(traverse))---- | Right-to-left composition of functors.--- 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) }--instance (Functor f, Functor g) => Functor (Compose f g) where-    fmap f (Compose x) = Compose (fmap (fmap f) x)--instance (Foldable f, Foldable g) => Foldable (Compose f g) where-    foldMap f (Compose t) = foldMap (foldMap f) t--instance (Traversable f, Traversable g) => Traversable (Compose f g) where-    traverse f (Compose t) = Compose <$> traverse (traverse f) t--instance (Applicative f, Applicative g) => Applicative (Compose f g) where-    pure x = Compose (pure (pure x))-    Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)--instance (Alternative f, Applicative g) => Alternative (Compose f g) where-    empty = Compose empty-    Compose x <|> Compose y = Compose (x <|> y)
Data/Functor/Constant.hs view
@@ -1,35 +1,173 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+----------------------------------------------------------------------------- -- | -- Module      :  Data.Functor.Constant -- Copyright   :  (c) Ross Paterson 2010 -- License     :  BSD-style (see the file LICENSE) ----- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  portable -- -- The constant functor.+-----------------------------------------------------------------------------  module Data.Functor.Constant (     Constant(..),-   ) where+  ) where +import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif+ import Control.Applicative-import Data.Foldable (Foldable(foldMap))+import Data.Foldable+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse))+#endif+#if MIN_VERSION_base(4,8,0)+import Data.Bifunctor (Bifunctor(..))+#endif+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+#if MIN_VERSION_base(4,10,0)+import Data.Bifoldable (Bifoldable(..))+import Data.Bitraversable (Bitraversable(..))+#endif+import Prelude hiding (null, length)+#if __GLASGOW_HASKELL__ >= 800+import Data.Data+#endif+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif  -- | Constant functor. newtype Constant a b = Constant { getConstant :: a }+    deriving (Eq, Ord+#if __GLASGOW_HASKELL__ >= 800+        , Data+#endif+#if __GLASGOW_HASKELL__ >= 710+        , Generic, Generic1+#elif __GLASGOW_HASKELL__ >= 704+        , Generic+#endif+        ) +-- These instances would be equivalent to the derived instances of the+-- newtype if the field were removed.++instance (Read a) => Read (Constant a b) where+    readsPrec = readsData $+         readsUnaryWith readsPrec "Constant" Constant++instance (Show a) => Show (Constant a b) where+    showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x++-- Instances of lifted Prelude classes++instance Eq2 Constant where+    liftEq2 eq _ (Constant x) (Constant y) = eq x y+    {-# INLINE liftEq2 #-}++instance Ord2 Constant where+    liftCompare2 comp _ (Constant x) (Constant y) = comp x y+    {-# INLINE liftCompare2 #-}++instance Read2 Constant where+    liftReadsPrec2 rp _ _ _ = readsData $+         readsUnaryWith rp "Constant" Constant++instance Show2 Constant where+    liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x++instance (Eq a) => Eq1 (Constant a) where+    liftEq = liftEq2 (==)+    {-# INLINE liftEq #-}+instance (Ord a) => Ord1 (Constant a) where+    liftCompare = liftCompare2 compare+    {-# INLINE liftCompare #-}+instance (Read a) => Read1 (Constant a) where+    liftReadsPrec = liftReadsPrec2 readsPrec readList+    {-# INLINE liftReadsPrec #-}+instance (Show a) => Show1 (Constant a) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList+    {-# INLINE liftShowsPrec #-}+ instance Functor (Constant a) where-    fmap f (Constant x) = Constant x+    fmap _ (Constant x) = Constant x+    {-# INLINE fmap #-}  instance Foldable (Constant a) where-    foldMap f (Constant x) = mempty+    foldMap _ (Constant _) = mempty+    {-# INLINE foldMap #-}+#if MIN_VERSION_base(4,8,0)+    null (Constant _) = True+    length (Constant _) = 0+#endif  instance Traversable (Constant a) where-    traverse f (Constant x) = pure (Constant x)+    traverse _ (Constant x) = pure (Constant x)+    {-# INLINE traverse #-} +#if MIN_VERSION_base(4,9,0)+instance (Semigroup a) => Semigroup (Constant a b) where+    Constant x <> Constant y = Constant (x <> y)+    {-# INLINE (<>) #-}+#endif+ instance (Monoid a) => Applicative (Constant a) where     pure _ = Constant mempty+    {-# INLINE pure #-}     Constant x <*> Constant y = Constant (x `mappend` y)+    {-# INLINE (<*>) #-}++instance (Monoid a) => Monoid (Constant a b) where+    mempty = Constant mempty+    {-# INLINE mempty #-}+#if !MIN_VERSION_base(4,11,0)+    -- From base-4.11, Monoid(mappend) defaults to Semigroup((<>))+    Constant x `mappend` Constant y = Constant (x `mappend` y)+    {-# INLINE mappend #-}+#endif++#if MIN_VERSION_base(4,8,0)+instance Bifunctor Constant where+    first f (Constant x) = Constant (f x)+    {-# INLINE first #-}+    second _ (Constant x) = Constant x+    {-# INLINE second #-}+#endif++#if MIN_VERSION_base(4,10,0)+instance Bifoldable Constant where+    bifoldMap f _ (Constant a) = f a+    {-# INLINE bifoldMap #-}++instance Bitraversable Constant where+    bitraverse f _ (Constant a) = Constant <$> f a+    {-# INLINE bitraverse #-}+#endif++#if MIN_VERSION_base(4,12,0)+instance Contravariant (Constant a) where+    contramap _ (Constant a) = Constant a+    {-# INLINE contramap #-}+#endif
− Data/Functor/Identity.hs 
@@ -1,57 +0,0 @@--- |--- Module      :  Data.Functor.Identity--- Copyright   :  (c) Andy Gill 2001,---                (c) Oregon Graduate Institute of Science and Technology 2001--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  portable------ The identity functor and monad.------ This trivial type constructor serves two purposes:------ * It can be used with functions parameterized by a 'Functor' or 'Monad'.------ * It can be used as a base monad to which a series of monad---   transformers may be applied to construct a composite monad.---   Most monad transformer modules include the special case of---   applying the transformer to 'Identity'.  For example, @State s@---   is an abbreviation for @StateT s 'Identity'@.--module Data.Functor.Identity (-    Identity(..),-   ) where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Data.Foldable (Foldable(foldMap))-import Data.Traversable (Traversable(traverse))---- | Identity functor and monad.-newtype Identity a = Identity { runIdentity :: a }---- ------------------------------------------------------------------------------ Identity instances for Functor and Monad--instance Functor Identity where-    fmap f m = Identity (f (runIdentity m))--instance Foldable Identity where-    foldMap f (Identity x) = f x--instance Traversable Identity where-    traverse f (Identity x) = Identity <$> f x--instance Applicative Identity where-    pure a = Identity a-    Identity f <*> Identity x = Identity (f x)--instance Monad Identity where-    return a = Identity a-    m >>= k  = k (runIdentity m)--instance MonadFix Identity where-    mfix f = Identity (fix (runIdentity . f))
− Data/Functor/Product.hs 
@@ -1,39 +0,0 @@--- |--- Module      :  Data.Functor.Product--- Copyright   :  (c) Ross Paterson 2010--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  portable------ Products, lifted to functors.--module Data.Functor.Product (-    Product(..),-   ) where--import Control.Applicative-import Data.Foldable (Foldable(foldMap))-import Data.Monoid (mappend)-import Data.Traversable (Traversable(traverse))---- | Lifted product of functors.-data Product f g a = Pair (f a) (g a)--instance (Functor f, Functor g) => Functor (Product f g) where-    fmap f (Pair x y) = Pair (fmap f x) (fmap f y)--instance (Foldable f, Foldable g) => Foldable (Product f g) where-    foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y--instance (Traversable f, Traversable g) => Traversable (Product f g) where-    traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y--instance (Applicative f, Applicative g) => Applicative (Product f g) where-    pure x = Pair (pure x) (pure x)-    Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)--instance (Alternative f, Alternative g) => Alternative (Product f g) where-    empty = Pair empty empty-    Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)
+ Data/Functor/Reverse.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Reverse+-- Copyright   :  (c) Russell O'Connor 2009+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Making functors whose elements are notionally in the reverse order+-- from the original functor.+-----------------------------------------------------------------------------++module Data.Functor.Reverse (+    Reverse(..),+  ) where++import Control.Applicative.Backwards+#if MIN_VERSION_base(4,18,0)+import Data.Foldable1 (Foldable1(foldMap1))+#endif+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif++import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length)+import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Data.Foldable+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Traversable (Traversable(traverse))+#endif+import Data.Monoid+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | The same functor, but with 'Foldable' and 'Traversable' instances+-- that process the elements in the reverse order.+newtype Reverse f a = Reverse { getReverse :: f a }+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, Generic1)+#elif __GLASGOW_HASKELL__ >= 704+    deriving (Generic)+#endif++instance (Eq1 f) => Eq1 (Reverse f) where+    liftEq eq (Reverse x) (Reverse y) = liftEq eq x y+    {-# INLINE liftEq #-}++instance (Ord1 f) => Ord1 (Reverse f) where+    liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y+    {-# INLINE liftCompare #-}++instance (Read1 f) => Read1 (Reverse f) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse++instance (Show1 f) => Show1 (Reverse f) where+    liftShowsPrec sp sl d (Reverse x) =+        showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x++instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1+instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1++-- | Derived instance.+instance (Functor f) => Functor (Reverse f) where+    fmap f (Reverse a) = Reverse (fmap f a)+    {-# INLINE fmap #-}++-- | Derived instance.+instance (Applicative f) => Applicative (Reverse f) where+    pure a = Reverse (pure a)+    {-# INLINE pure #-}+    Reverse f <*> Reverse a = Reverse (f <*> a)+    {-# INLINE (<*>) #-}++-- | Derived instance.+instance (Alternative f) => Alternative (Reverse f) where+    empty = Reverse empty+    {-# INLINE empty #-}+    Reverse x <|> Reverse y = Reverse (x <|> y)+    {-# INLINE (<|>) #-}++-- | Derived instance.+instance (Monad m) => Monad (Reverse m) where+#if !(MIN_VERSION_base(4,8,0))+    return a = Reverse (return a)+    {-# INLINE return #-}+#endif+    m >>= f = Reverse (getReverse m >>= getReverse . f)+    {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+    fail msg = Reverse (fail msg)+    {-# INLINE fail #-}+#endif++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where+    fail msg = Reverse (Fail.fail msg)+    {-# INLINE fail #-}+#endif++-- | Derived instance.+instance (MonadPlus m) => MonadPlus (Reverse m) where+    mzero = Reverse mzero+    {-# INLINE mzero #-}+    Reverse x `mplus` Reverse y = Reverse (x `mplus` y)+    {-# INLINE mplus #-}++-- | Fold from right to left.+instance (Foldable f) => Foldable (Reverse f) where+    foldMap f (Reverse t) = getDual (foldMap (Dual . f) t)+    {-# INLINE foldMap #-}+    foldr f z (Reverse t) = foldl (flip f) z t+    {-# INLINE foldr #-}+    foldl f z (Reverse t) = foldr (flip f) z t+    {-# INLINE foldl #-}+    foldr1 f (Reverse t) = foldl1 (flip f) t+    {-# INLINE foldr1 #-}+    foldl1 f (Reverse t) = foldr1 (flip f) t+    {-# INLINE foldl1 #-}+#if MIN_VERSION_base(4,8,0)+    null (Reverse t) = null t+    length (Reverse t) = length t+#endif++#if MIN_VERSION_base(4,18,0)+-- | Fold from right to left.+instance (Foldable1 f) => Foldable1 (Reverse f) where+    foldMap1 f (Reverse t) = getDual (foldMap1 (Dual . f) t)+#endif++-- | Traverse from right to left.+instance (Traversable f) => Traversable (Reverse f) where+    traverse f (Reverse t) =+        fmap Reverse . forwards $ traverse (Backwards . f) t+    {-# INLINE traverse #-}++#if MIN_VERSION_base(4,12,0)+-- | Derived instance.+instance (Contravariant f) => Contravariant (Reverse f) where+    contramap f = Reverse . contramap f . getReverse+    {-# INLINE contramap #-}+#endif
+ changelog view
@@ -0,0 +1,174 @@+-*-change-log-*-++0.6.3.0 Ross Paterson <R.Paterson@city.ac.uk> Jan 2026+	* Add Control.Monad.Trans.Except.onE+	* Add strictToLazyState and lazyToStrictStateT++0.6.2.0 Ross Paterson <R.Paterson@city.ac.uk> Apr 2025+	* Redefine runAccumT, runExceptT and runSelectT as fields+	* Document strictness of some transformers++0.6.1.2 Ross Paterson <R.Paterson@city.ac.uk> Sep 2024+	* Portability fixes for MicroHs+	* Include image files in the bundle+	* Expand ExceptT documentation++0.6.1.1 Ross Paterson <R.Paterson@city.ac.uk> Aug 2023+	* Additions to documentation, especially of AccumT.++0.6.1.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2023+	* Add instances of Foldable1 (class added to base-4.18)+	* Add modifyM to StateT transformers++0.6.0.6 Ross Paterson <R.Paterson@city.ac.uk> Jan 2023+	* Fix for GHC 8.6++0.6.0.5 Ross Paterson <R.Paterson@city.ac.uk> Jan 2023+	* Revert to allowing MonadTrans constraint with GHC >= 8.6++0.6.0.4 Ross Paterson <R.Paterson@city.ac.uk> Feb 2022+	* Restrict deriving (Generic) to GHC >= 7.4++0.6.0.3 Ross Paterson <R.Paterson@city.ac.uk> Feb 2022+	* Restrict MonadTrans constraint to GHC >= 8.8++0.6.0.2 Ross Paterson <R.Paterson@city.ac.uk> Jul 2021+	* Further backward compatability fix++0.6.0.1 Ross Paterson <R.Paterson@city.ac.uk> Jul 2021+	* Backward compatability fixes++0.6.0.0 Ross Paterson <R.Paterson@city.ac.uk> Jul 2021+	* Added quantified constraint to MonadTrans (for GHC >= 8.6)+	* Added Generic and Data instances+	* Added handleE, tryE and finallyE to Control.Monad.Trans.Except+	* Added hoistMaybe to Control.Monad.Trans.Maybe+	* Added Generic and Data instances+	* Added pass-throughs to instances for Backwards+	* Made Lift's <*> lazier+	* Remove long-deprecated selectToCont+	* Remove long-deprecated Control.Monad.Trans.Error+	* Remove long-deprecated Control.Monad.Trans.List++0.5.6.2 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019+	* Further backward compatability fix++0.5.6.1 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019+	* Backward compatability fix for MonadFix ListT instance++0.5.6.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019+	* Generalized type of except+	* Added Control.Monad.Trans.Writer.CPS and Control.Monad.Trans.RWS.CPS+	* Added Contravariant instances+	* Added MonadFix instance for ListT++0.5.5.0 Ross Paterson <R.Paterson@city.ac.uk> Oct 2017+	* Added mapSelect and mapSelectT+	* Renamed selectToCont to selectToContT for consistency+	* Defined explicit method definitions to fix space leaks+	* Added missing Semigroup instance to `Constant` functor++0.5.4.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017+	* Migrate Bifoldable and Bitraversable instances for Constant++0.5.3.1 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017+	* Fixed for pre-AMP environments++0.5.3.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017+	* Added AccumT and SelectT monad transformers+	* Deprecated ListT+	* Added Monad (and related) instances for Reverse+	* Added elimLift and eitherToErrors+	* Added specialized definitions of several methods for efficiency+	* Removed specialized definition of sequenceA for Reverse+	* Backported Eq1/Ord1/Read1/Show1 instances for Proxy++0.5.2.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2016+	* Re-added orphan instances for Either to deprecated module+	* Added lots of INLINE pragmas++0.5.1.0 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016+	* Bump minor version number, required by added instances++0.5.0.2 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016+	* Backported extra instances for Identity++0.5.0.1 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016+	* Tightened GHC bounds for PolyKinds and DeriveDataTypeable++0.5.0.0 Ross Paterson <R.Paterson@city.ac.uk> Dec 2015+	* Control.Monad.IO.Class in base for GHC >= 8.0+	* Data.Functor.{Classes,Compose,Product,Sum} in base for GHC >= 8.0+	* Added PolyKinds for GHC >= 7.4+	* Added instances of base classes MonadZip and MonadFail+	* Changed liftings of Prelude classes to use explicit dictionaries++0.4.3.0 Ross Paterson <R.Paterson@city.ac.uk> Mar 2015+	* Added Eq1, Ord1, Show1 and Read1 instances for Const++0.4.2.0 Ross Paterson <ross@soi.city.ac.uk> Nov 2014+	* Dropped compatibility with base-1.x+	* Data.Functor.Identity in base for GHC >= 7.10+	* Added mapLift and runErrors to Control.Applicative.Lift+	* Added AutoDeriveTypeable for GHC >= 7.10+	* Expanded messages from mfix on ExceptT and MaybeT++0.4.1.0 Ross Paterson <ross@soi.city.ac.uk> May 2014+	* Reverted to record syntax for newtypes until next major release++0.4.0.0 Ross Paterson <ross@soi.city.ac.uk> May 2014+	* Added Sum type+	* Added modify', a strict version of modify, to the state monads+	* Added ExceptT and deprecated ErrorT+	* Added infixr 9 `Compose` to match (.)+	* Added Eq, Ord, Read and Show instances where possible+	* Replaced record syntax for newtypes with separate inverse functions+	* Added delimited continuation functions to ContT+	* Added instance Alternative IO to ErrorT+	* Handled disappearance of Control.Monad.Instances++0.3.0.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2012+	* Added type synonyms for signatures of complex operations+	* Generalized state, reader and writer constructor functions+	* Added Lift, Backwards/Reverse+	* Added MonadFix instances for IdentityT and MaybeT+	* Added Foldable and Traversable instances+	* Added Monad instances for Product++0.2.2.1 Ross Paterson <ross@soi.city.ac.uk> Oct 2013+	* Backport of fix for disappearance of Control.Monad.Instances++0.2.2.0 Ross Paterson <ross@soi.city.ac.uk> Sep 2010+	* Handled move of Either instances to base package++0.2.1.0 Ross Paterson <ross@soi.city.ac.uk> Apr 2010+	* Added Alternative instance for Compose+	* Added Data.Functor.Product++0.2.0.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2010+	* Added Constant and Compose+	* Renamed modules to avoid clash with mtl+	* Removed Monad constraint from Monad instance for ContT++0.1.4.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2009+	* Adjusted lifting of Identity and Maybe transformers++0.1.3.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2009+	* Added IdentityT transformer+	* Added Applicative and Alternative instances for (Either e)++0.1.1.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009+	* Made all Functor instances assume Functor++0.1.0.1 Ross Paterson <ross@soi.city.ac.uk> Jan 2009+	* Adjusted dependencies++0.1.0.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009+	* Two versions of lifting of callcc through StateT+	* Added Applicative instances++0.0.1.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009+	* Added constructors state, etc for simple monads++0.0.0.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009+	* Split Haskell 98 transformers from the mtl
+ images/bind-AccumT.svg view
@@ -0,0 +1,66 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg width="390" height="180"+ xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">++<defs>+  <marker id="arrow" viewBox="0 0 10 10" refX="5" refY="5"+        markerWidth="5" markerHeight="5"+        orient="auto-start-reverse">+      <path d="M 0 0 L 10 5 L 0 10 z" />+  </marker>+  <marker id="extra-arrow" viewBox="0 0 10 10" refX="5" refY="5"+        markerWidth="5" markerHeight="5"+        orient="auto-start-reverse">+      <path fill="#44f" d="M 0 0 L 10 5 L 0 10 z" />+  </marker>+  <style type="text/css">+    line.arrow {+        fill: none; stroke: black; stroke-width: 4;+        marker-end: url(#arrow);+    }+    circle.action {+        fill: #f8ddbb; stroke: black; stroke-width: 4;+    }+    text.action {+        fill: black; stroke: none;+        font-family: sans-serif; font-size: 35px;+        dominant-baseline: central; text-anchor: middle;+    }+    .extra {+        fill: none; stroke: #44f; stroke-width: 3;+        marker-end: url(#extra-arrow);+    }+    circle.mappend {+        fill: none; stroke: #44f; stroke-width: 3;+    }+    text.mappend {+        fill: #44f; stroke: none;+        font-family: sans-serif; font-size: 26px;+        dominant-baseline: central; text-anchor: middle;+    }+  </style>+</defs>+<g transform="scale(0.6) translate(50,50)">+  <path class="extra" d="M 0,0 L 80,0 A 20 20 0 0 1 100,20 L 100,52"/>+  <path class="extra" d="M 80,0 L 225,0"/>+  <circle class="mappend" cx="250" cy="0" r="20"/>+  <text class="mappend" x="250" y="0">&lt;&gt;</text>+  <path class="extra" d="M 270,0 L 380,0 A 20 20 0 0 1 400,20 L 400,52"/>+  <path class="extra" d="M 230,200 A 20 20 0 0 0 250,180 L 250,27"/>+  <path class="extra" d="M 100,140 L 100,180 A 20 20 0 0 0 120,200 L 373,200"/>+  <circle class="mappend" cx="400" cy="200" r="20"/>+  <text class="mappend" x="400" y="200">&lt;&gt;</text>+  <path class="extra" d="M 400,140 L 400,173"/>+  <path class="extra" d="M 420,200 L 550,200"/>+  <text class="mappend" x="15" y="-20">w</text>++  <line class="arrow" x1="140" y1="100" x2="350" y2="100"/>+  <line class="arrow" x1="440" y1="100" x2="550" y2="100"/>+  <circle class="action" cx="100" cy="100" r="40"/>+  <text class="action" x="100" y="100">m</text>+  <circle class="action" cx="400" cy="100" r="40"/>+  <text class="action" x="400" y="100">k</text>+</g>+</svg>
+ images/bind-ReaderT.svg view
@@ -0,0 +1,57 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg width="390" height="150"+ xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">++<defs>+  <marker id="arrow" viewBox="0 0 10 10" refX="5" refY="5"+        markerWidth="5" markerHeight="5"+        orient="auto-start-reverse">+      <path d="M 0 0 L 10 5 L 0 10 z" />+  </marker>+  <marker id="extra-arrow" viewBox="0 0 10 10" refX="5" refY="5"+        markerWidth="5" markerHeight="5"+        orient="auto-start-reverse">+      <path fill="#44f" d="M 0 0 L 10 5 L 0 10 z" />+  </marker>+  <style type="text/css">+    line.arrow {+        fill: none; stroke: black; stroke-width: 4;+        marker-end: url(#arrow);+    }+    circle.action {+        fill: #f8ddbb; stroke: black; stroke-width: 4;+    }+    text.action {+        fill: black; stroke: none;+        font-family: sans-serif; font-size: 35px;+        dominant-baseline: central; text-anchor: middle;+    }+    .extra {+        fill: none; stroke: #44f; stroke-width: 3;+        marker-end: url(#extra-arrow);+    }+    circle.mappend {+        fill: none; stroke: #44f; stroke-width: 3;+    }+    text.mappend {+        fill: #44f; stroke: none;+        font-family: sans-serif; font-size: 26px;+        dominant-baseline: central; text-anchor: middle;+    }+  </style>+</defs>+<g transform="scale(0.6) translate(50,50)">+  <path class="extra" d="M 0,0 L 80,0 A 20 20 0 0 1 100,20 L 100,52"/>+  <path class="extra" d="M 80,0 L 380,0 A 20 20 0 0 1 400,20 L 400,52"/>+  <text class="mappend" x="15" y="-20">r</text>++  <line class="arrow" x1="140" y1="100" x2="350" y2="100"/>+  <line class="arrow" x1="440" y1="100" x2="550" y2="100"/>+  <circle class="action" cx="100" cy="100" r="40"/>+  <text class="action" x="100" y="100">m</text>+  <circle class="action" cx="400" cy="100" r="40"/>+  <text class="action" x="400" y="100">k</text>+</g>+</svg>
+ images/bind-WriterT.svg view
@@ -0,0 +1,60 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg width="360" height="150"+ xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">++<defs>+  <marker id="arrow" viewBox="0 0 10 10" refX="5" refY="5"+        markerWidth="5" markerHeight="5"+        orient="auto-start-reverse">+      <path d="M 0 0 L 10 5 L 0 10 z" />+  </marker>+  <marker id="extra-arrow" viewBox="0 0 10 10" refX="5" refY="5"+        markerWidth="5" markerHeight="5"+        orient="auto-start-reverse">+      <path fill="#44f" d="M 0 0 L 10 5 L 0 10 z" />+  </marker>+  <style type="text/css">+    line.arrow {+        fill: none; stroke: black; stroke-width: 4;+        marker-end: url(#arrow);+    }+    circle.action {+        fill: #f8ddbb; stroke: black; stroke-width: 4;+    }+    text.action {+        fill: black; stroke: none;+        font-family: sans-serif; font-size: 35px;+        dominant-baseline: central; text-anchor: middle;+    }+    .extra {+        fill: none; stroke: #44f; stroke-width: 3;+        marker-end: url(#extra-arrow);+    }+    circle.mappend {+        fill: none; stroke: #44f; stroke-width: 3;+    }+    text.mappend {+        fill: #44f; stroke: none;+        font-family: sans-serif; font-size: 26px;+        dominant-baseline: central; text-anchor: middle;+    }+  </style>+</defs>+<g transform="scale(0.6)">+  <path class="extra" d="M 100,140 L 100,180 A 20 20 0 0 0 120,200 L 373,200"/>+  <circle class="mappend" cx="400" cy="200" r="20"/>+  <text class="mappend" x="400" y="200">&lt;&gt;</text>+  <path class="extra" d="M 400,140 L 400,173"/>+  <path class="extra" d="M 420,200 L 550,200"/>+  <text class="mappend" x="520" y="180">w</text>++  <line class="arrow" x1="140" y1="100" x2="350" y2="100"/>+  <line class="arrow" x1="440" y1="100" x2="550" y2="100"/>+  <circle class="action" cx="100" cy="100" r="40"/>+  <text class="action" x="100" y="100">m</text>+  <circle class="action" cx="400" cy="100" r="40"/>+  <text class="action" x="400" y="100">k</text>+</g>+</svg>
+ legacy/pre709/Data/Functor/Identity.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 700+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Trustworthy #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+#endif+#if MIN_VERSION_base(4,7,0)+-- We need to implement bitSize for the Bits instance, but it's deprecated.+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Identity+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The identity functor and monad.+--+-- This trivial type constructor serves two purposes:+--+-- * It can be used with functions parameterized by functor or monad classes.+--+-- * It can be used as a base monad to which a series of monad+--   transformers may be applied to construct a composite monad.+--   Most monad transformer modules include the special case of+--   applying the transformer to 'Identity'.  For example, @State s@+--   is an abbreviation for @StateT s 'Identity'@.+-----------------------------------------------------------------------------++module Data.Functor.Identity (+    Identity(..),+  ) where++import Data.Bits+import Control.Applicative+import Control.Arrow (Arrow((***)))+import Control.Monad.Fix+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith, munzip))+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (Monoid(mempty, mappend))+import Data.String (IsString(fromString))+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 700+import Data.Data+#endif+import Data.Ix (Ix(..))+import Foreign (Storable(..), castPtr)+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | Identity functor and monad. (a non-strict monad)+newtype Identity a = Identity { runIdentity :: a }+    deriving ( Eq, Ord+#if __GLASGOW_HASKELL__ >= 700+             , Data, Typeable+#endif+#if __GLASGOW_HASKELL__ >= 704+             , Generic+#endif+#if __GLASGOW_HASKELL__ >= 706+             , Generic1+#endif+             )++instance (Bits a) => Bits (Identity a) where+    Identity x .&. Identity y     = Identity (x .&. y)+    Identity x .|. Identity y     = Identity (x .|. y)+    xor (Identity x) (Identity y) = Identity (xor x y)+    complement   (Identity x)     = Identity (complement x)+    shift        (Identity x) i   = Identity (shift    x i)+    rotate       (Identity x) i   = Identity (rotate   x i)+    setBit       (Identity x) i   = Identity (setBit   x i)+    clearBit     (Identity x) i   = Identity (clearBit x i)+    shiftL       (Identity x) i   = Identity (shiftL   x i)+    shiftR       (Identity x) i   = Identity (shiftR   x i)+    rotateL      (Identity x) i   = Identity (rotateL  x i)+    rotateR      (Identity x) i   = Identity (rotateR  x i)+    testBit      (Identity x) i   = testBit x i+    bitSize      (Identity x)     = bitSize x+    isSigned     (Identity x)     = isSigned x+    bit i                         = Identity (bit i)+#if MIN_VERSION_base(4,5,0)+    unsafeShiftL (Identity x) i   = Identity (unsafeShiftL x i)+    unsafeShiftR (Identity x) i   = Identity (unsafeShiftR x i)+    popCount     (Identity x)     = popCount x+#endif+#if MIN_VERSION_base(4,7,0)+    zeroBits                      = Identity zeroBits+    bitSizeMaybe (Identity x)     = bitSizeMaybe x+#endif++instance (Bounded a) => Bounded (Identity a) where+    minBound = Identity minBound+    maxBound = Identity maxBound++instance (Enum a) => Enum (Identity a) where+    succ (Identity x)     = Identity (succ x)+    pred (Identity x)     = Identity (pred x)+    toEnum i              = Identity (toEnum i)+    fromEnum (Identity x) = fromEnum x+    enumFrom (Identity x) = map Identity (enumFrom x)+    enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y)+    enumFromTo   (Identity x) (Identity y) = map Identity (enumFromTo   x y)+    enumFromThenTo (Identity x) (Identity y) (Identity z) =+        map Identity (enumFromThenTo x y z)++#if MIN_VERSION_base(4,7,0)+instance (FiniteBits a) => FiniteBits (Identity a) where+    finiteBitSize (Identity x) = finiteBitSize x+#endif++instance (Floating a) => Floating (Identity a) where+    pi                                = Identity pi+    exp   (Identity x)                = Identity (exp x)+    log   (Identity x)                = Identity (log x)+    sqrt  (Identity x)                = Identity (sqrt x)+    sin   (Identity x)                = Identity (sin x)+    cos   (Identity x)                = Identity (cos x)+    tan   (Identity x)                = Identity (tan x)+    asin  (Identity x)                = Identity (asin x)+    acos  (Identity x)                = Identity (acos x)+    atan  (Identity x)                = Identity (atan x)+    sinh  (Identity x)                = Identity (sinh x)+    cosh  (Identity x)                = Identity (cosh x)+    tanh  (Identity x)                = Identity (tanh x)+    asinh (Identity x)                = Identity (asinh x)+    acosh (Identity x)                = Identity (acosh x)+    atanh (Identity x)                = Identity (atanh x)+    Identity x ** Identity y          = Identity (x ** y)+    logBase (Identity x) (Identity y) = Identity (logBase x y)++instance (Fractional a) => Fractional (Identity a) where+    Identity x / Identity y = Identity (x / y)+    recip (Identity x)      = Identity (recip x)+    fromRational r          = Identity (fromRational r)++instance (IsString a) => IsString (Identity a) where+    fromString s = Identity (fromString s)++instance (Ix a) => Ix (Identity a) where+    range     (Identity x, Identity y) = map Identity (range (x, y))+    index     (Identity x, Identity y) (Identity i) = index     (x, y) i+    inRange   (Identity x, Identity y) (Identity e) = inRange   (x, y) e+    rangeSize (Identity x, Identity y) = rangeSize (x, y)++instance (Integral a) => Integral (Identity a) where+    quot    (Identity x) (Identity y) = Identity (quot x y)+    rem     (Identity x) (Identity y) = Identity (rem  x y)+    div     (Identity x) (Identity y) = Identity (div  x y)+    mod     (Identity x) (Identity y) = Identity (mod  x y)+    quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y)+    divMod  (Identity x) (Identity y) = (Identity *** Identity) (divMod  x y)+    toInteger (Identity x)            = toInteger x++instance (Monoid a) => Monoid (Identity a) where+    mempty = Identity mempty+    mappend (Identity x) (Identity y) = Identity (mappend x y)++instance (Num a) => Num (Identity a) where+    Identity x + Identity y = Identity (x + y)+    Identity x - Identity y = Identity (x - y)+    Identity x * Identity y = Identity (x * y)+    negate (Identity x)     = Identity (negate x)+    abs    (Identity x)     = Identity (abs    x)+    signum (Identity x)     = Identity (signum x)+    fromInteger n           = Identity (fromInteger n)++instance (Real a) => Real (Identity a) where+    toRational (Identity x) = toRational x++instance (RealFloat a) => RealFloat (Identity a) where+    floatRadix     (Identity x)     = floatRadix     x+    floatDigits    (Identity x)     = floatDigits    x+    floatRange     (Identity x)     = floatRange     x+    decodeFloat    (Identity x)     = decodeFloat    x+    exponent       (Identity x)     = exponent       x+    isNaN          (Identity x)     = isNaN          x+    isInfinite     (Identity x)     = isInfinite     x+    isDenormalized (Identity x)     = isDenormalized x+    isNegativeZero (Identity x)     = isNegativeZero x+    isIEEE         (Identity x)     = isIEEE         x+    significand    (Identity x)     = significand (Identity x)+    scaleFloat s   (Identity x)     = Identity (scaleFloat s x)+    encodeFloat m n                 = Identity (encodeFloat m n)+    atan2 (Identity x) (Identity y) = Identity (atan2 x y)++instance (RealFrac a) => RealFrac (Identity a) where+    properFraction (Identity x) = (id *** Identity) (properFraction x)+    truncate       (Identity x) = truncate x+    round          (Identity x) = round    x+    ceiling        (Identity x) = ceiling  x+    floor          (Identity x) = floor    x++instance (Storable a) => Storable (Identity a) where+    sizeOf    (Identity x)       = sizeOf x+    alignment (Identity x)       = alignment x+    peekElemOff p i              = fmap Identity (peekElemOff (castPtr p) i)+    pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x+    peekByteOff p i              = fmap Identity (peekByteOff p i)+    pokeByteOff p i (Identity x) = pokeByteOff p i x+    peek p                       = fmap runIdentity (peek (castPtr p))+    poke p (Identity x)          = poke (castPtr p) x++-- These instances would be equivalent to the derived instances of the+-- newtype if the field were removed.++instance (Read a) => Read (Identity a) where+    readsPrec d = readParen (d > 10) $ \ r ->+        [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s]++instance (Show a) => Show (Identity a) where+    showsPrec d (Identity x) = showParen (d > 10) $+        showString "Identity " . showsPrec 11 x++-- ---------------------------------------------------------------------------+-- Identity instances for Functor and Monad++instance Functor Identity where+    fmap f m = Identity (f (runIdentity m))++instance Foldable Identity where+    foldMap f (Identity x) = f x++instance Traversable Identity where+    traverse f (Identity x) = Identity <$> f x++instance Applicative Identity where+    pure a = Identity a+    Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+    return a = Identity a+    m >>= k  = k (runIdentity m)++instance MonadFix Identity where+    mfix f = Identity (fix (runIdentity . f))++#if MIN_VERSION_base(4,4,0)+instance MonadZip Identity where+    mzipWith f (Identity x) (Identity y) = Identity (f x y)+    munzip (Identity (a, b)) = (Identity a, Identity b)+#endif
+ legacy/pre711/Control/Monad/IO/Class.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.IO.Class+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Class of monads based on @IO@.+-----------------------------------------------------------------------------++module Control.Monad.IO.Class (+    MonadIO(..)+  ) where++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++-- | Monads in which 'IO' computations may be embedded.+-- Any monad built by applying a sequence of monad transformers to the+-- 'IO' monad will be an instance of this class.+--+-- Instances should satisfy the following laws, which state that 'liftIO'+-- is a transformer of monads:+--+-- * @'liftIO' . 'return' = 'return'@+--+-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@++class (Monad m) => MonadIO m where+    -- | Lift a computation from the 'IO' monad.+    liftIO :: IO a -> m a++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable MonadIO+#endif++instance MonadIO IO where+    liftIO = id
+ legacy/pre711/Data/Functor/Classes.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Classes+-- Copyright   :  (c) Ross Paterson 2013+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to+-- unary and binary type constructors.+--+-- These classes are needed to express the constraints on arguments of+-- transformers in portable Haskell.  Thus for a new transformer @T@,+-- one might write instances like+--+-- > instance (Eq1 f) => Eq1 (T f) where ...+-- > instance (Ord1 f) => Ord1 (T f) where ...+-- > instance (Read1 f) => Read1 (T f) where ...+-- > instance (Show1 f) => Show1 (T f) where ...+--+-- If these instances can be defined, defining instances of the base+-- classes is mechanical:+--+-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1+-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1+-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1+-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1+--+-----------------------------------------------------------------------------++module Data.Functor.Classes (+    -- * Liftings of Prelude classes+    -- ** For unary constructors+    Eq1(..), eq1,+    Ord1(..), compare1,+    Read1(..), readsPrec1,+    Show1(..), showsPrec1,+    -- ** For binary constructors+    Eq2(..), eq2,+    Ord2(..), compare2,+    Read2(..), readsPrec2,+    Show2(..), showsPrec2,+    -- * Helper functions+    -- $example+    readsData,+    readsUnaryWith,+    readsBinaryWith,+    showsUnaryWith,+    showsBinaryWith,+    -- ** Obsolete helpers+    readsUnary,+    readsUnary1,+    readsBinary1,+    showsUnary,+    showsUnary1,+    showsBinary1,+  ) where++import Control.Applicative (Const(Const))+import Data.Functor.Identity (Identity(Identity))+import Data.Monoid (mappend)+#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy(Proxy))+#endif+#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+import Text.Show (showListWith)++-- | Lifting of the 'Eq' class to unary type constructors.+class Eq1 f where+    -- | Lift an equality test through the type constructor.+    --+    -- The function will usually be applied to an equality function,+    -- but the more general type ensures that the implementation uses+    -- it to compare elements of the first container with elements of+    -- the second.+    liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Eq1+#endif++-- | Lift the standard @('==')@ function through the type constructor.+eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool+eq1 = liftEq (==)++-- | Lifting of the 'Ord' class to unary type constructors.+class (Eq1 f) => Ord1 f where+    -- | Lift a 'compare' function through the type constructor.+    --+    -- The function will usually be applied to a comparison function,+    -- but the more general type ensures that the implementation uses+    -- it to compare elements of the first container with elements of+    -- the second.+    liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Ord1+#endif++-- | Lift the standard 'compare' function through the type constructor.+compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering+compare1 = liftCompare compare++-- | Lifting of the 'Read' class to unary type constructors.+class Read1 f where+    -- | 'readsPrec' function for an application of the type constructor+    -- based on 'readsPrec' and 'readList' functions for the argument type.+    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)++    -- | 'readList' function for an application of the type constructor+    -- based on 'readsPrec' and 'readList' functions for the argument type.+    -- The default implementation using standard list syntax is correct+    -- for most types.+    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]+    liftReadList rp rl = readListWith (liftReadsPrec rp rl 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Read1+#endif++-- | Read a list (using square brackets and commas), given a function+-- for reading elements.+readListWith :: ReadS a -> ReadS [a]+readListWith rp =+    readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])+  where+    readl s = [([],t) | ("]",t) <- lex s] +++        [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]+    readl' s = [([],t) | ("]",t) <- lex s] +++        [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]++-- | Lift the standard 'readsPrec' and 'readList' functions through the+-- type constructor.+readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)+readsPrec1 = liftReadsPrec readsPrec readList++-- | Lifting of the 'Show' class to unary type constructors.+class Show1 f where+    -- | 'showsPrec' function for an application of the type constructor+    -- based on 'showsPrec' and 'showList' functions for the argument type.+    liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+        Int -> f a -> ShowS++    -- | 'showList' function for an application of the type constructor+    -- based on 'showsPrec' and 'showList' functions for the argument type.+    -- The default implementation using standard list syntax is correct+    -- for most types.+    liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+        [f a] -> ShowS+    liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Show1+#endif++-- | Lift the standard 'showsPrec' and 'showList' functions through the+-- type constructor.+showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS+showsPrec1 = liftShowsPrec showsPrec showList++-- | Lifting of the 'Eq' class to binary type constructors.+class Eq2 f where+    -- | Lift equality tests through the type constructor.+    --+    -- The function will usually be applied to equality functions,+    -- but the more general type ensures that the implementation uses+    -- them to compare elements of the first container with elements of+    -- the second.+    liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Eq2+#endif++-- | Lift the standard @('==')@ function through the type constructor.+eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool+eq2 = liftEq2 (==) (==)++-- | Lifting of the 'Ord' class to binary type constructors.+class (Eq2 f) => Ord2 f where+    -- | Lift 'compare' functions through the type constructor.+    --+    -- The function will usually be applied to comparison functions,+    -- but the more general type ensures that the implementation uses+    -- them to compare elements of the first container with elements of+    -- the second.+    liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->+        f a c -> f b d -> Ordering++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Ord2+#endif++-- | Lift the standard 'compare' function through the type constructor.+compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering+compare2 = liftCompare2 compare compare++-- | Lifting of the 'Read' class to binary type constructors.+class Read2 f where+    -- | 'readsPrec' function for an application of the type constructor+    -- based on 'readsPrec' and 'readList' functions for the argument types.+    liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->+        (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)++    -- | 'readList' function for an application of the type constructor+    -- based on 'readsPrec' and 'readList' functions for the argument types.+    -- The default implementation using standard list syntax is correct+    -- for most types.+    liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->+        (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]+    liftReadList2 rp1 rl1 rp2 rl2 =+        readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Read2+#endif++-- | Lift the standard 'readsPrec' function through the type constructor.+readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)+readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList++-- | Lifting of the 'Show' class to binary type constructors.+class Show2 f where+    -- | 'showsPrec' function for an application of the type constructor+    -- based on 'showsPrec' and 'showList' functions for the argument types.+    liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+        (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS++    -- | 'showList' function for an application of the type constructor+    -- based on 'showsPrec' and 'showList' functions for the argument types.+    -- The default implementation using standard list syntax is correct+    -- for most types.+    liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+        (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS+    liftShowList2 sp1 sl1 sp2 sl2 =+        showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Show2+#endif++-- | Lift the standard 'showsPrec' function through the type constructor.+showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS+showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList++-- Instances for Prelude type constructors++instance Eq1 Maybe where+    liftEq _ Nothing Nothing = True+    liftEq _ Nothing (Just _) = False+    liftEq _ (Just _) Nothing = False+    liftEq eq (Just x) (Just y) = eq x y++instance Ord1 Maybe where+    liftCompare _ Nothing Nothing = EQ+    liftCompare _ Nothing (Just _) = LT+    liftCompare _ (Just _) Nothing = GT+    liftCompare comp (Just x) (Just y) = comp x y++instance Read1 Maybe where+    liftReadsPrec rp _ d =+         readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])+         `mappend`+         readsData (readsUnaryWith rp "Just" Just) d++instance Show1 Maybe where+    liftShowsPrec _ _ _ Nothing = showString "Nothing"+    liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x++instance Eq1 [] where+    liftEq _ [] [] = True+    liftEq _ [] (_:_) = False+    liftEq _ (_:_) [] = False+    liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys++instance Ord1 [] where+    liftCompare _ [] [] = EQ+    liftCompare _ [] (_:_) = LT+    liftCompare _ (_:_) [] = GT+    liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys++instance Read1 [] where+    liftReadsPrec _ rl _ = rl++instance Show1 [] where+    liftShowsPrec _ sl _ = sl++instance Eq2 (,) where+    liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2++instance Ord2 (,) where+    liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =+        comp1 x1 x2 `mappend` comp2 y1 y2++instance Read2 (,) where+    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->+        [((x,y), w) | ("(",s) <- lex r,+                      (x,t)   <- rp1 0 s,+                      (",",u) <- lex t,+                      (y,v)   <- rp2 0 u,+                      (")",w) <- lex v]++instance Show2 (,) where+    liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =+        showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'++instance (Eq a) => Eq1 ((,) a) where+    liftEq = liftEq2 (==)++instance (Ord a) => Ord1 ((,) a) where+    liftCompare = liftCompare2 compare++instance (Read a) => Read1 ((,) a) where+    liftReadsPrec = liftReadsPrec2 readsPrec readList++instance (Show a) => Show1 ((,) a) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Eq2 Either where+    liftEq2 e1 _ (Left x) (Left y) = e1 x y+    liftEq2 _ _ (Left _) (Right _) = False+    liftEq2 _ _ (Right _) (Left _) = False+    liftEq2 _ e2 (Right x) (Right y) = e2 x y++instance Ord2 Either where+    liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y+    liftCompare2 _ _ (Left _) (Right _) = LT+    liftCompare2 _ _ (Right _) (Left _) = GT+    liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y++instance Read2 Either where+    liftReadsPrec2 rp1 _ rp2 _ = readsData $+         readsUnaryWith rp1 "Left" Left `mappend`+         readsUnaryWith rp2 "Right" Right++instance Show2 Either where+    liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x+    liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x++instance (Eq a) => Eq1 (Either a) where+    liftEq = liftEq2 (==)++instance (Ord a) => Ord1 (Either a) where+    liftCompare = liftCompare2 compare++instance (Read a) => Read1 (Either a) where+    liftReadsPrec = liftReadsPrec2 readsPrec readList++instance (Show a) => Show1 (Either a) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++#if MIN_VERSION_base(4,7,0)+instance Eq1 Proxy where+    liftEq _ _ _ = True++instance Ord1 Proxy where+    liftCompare _ _ _ = EQ++instance Show1 Proxy where+    liftShowsPrec _ _ _ _ = showString "Proxy"++instance Read1 Proxy where+    liftReadsPrec _ _ d =+        readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])+#endif++-- Instances for other functors defined in the base package++instance Eq1 Identity where+    liftEq eq (Identity x) (Identity y) = eq x y++instance Ord1 Identity where+    liftCompare comp (Identity x) (Identity y) = comp x y++instance Read1 Identity where+    liftReadsPrec rp _ = readsData $+         readsUnaryWith rp "Identity" Identity++instance Show1 Identity where+    liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x++instance Eq2 Const where+    liftEq2 eq _ (Const x) (Const y) = eq x y++instance Ord2 Const where+    liftCompare2 comp _ (Const x) (Const y) = comp x y++instance Read2 Const where+    liftReadsPrec2 rp _ _ _ = readsData $+         readsUnaryWith rp "Const" Const++instance Show2 Const where+    liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x++instance (Eq a) => Eq1 (Const a) where+    liftEq = liftEq2 (==)+instance (Ord a) => Ord1 (Const a) where+    liftCompare = liftCompare2 compare+instance (Read a) => Read1 (Const a) where+    liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Show a) => Show1 (Const a) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++-- Building blocks++-- | @'readsData' p d@ is a parser for datatypes where each alternative+-- begins with a data constructor.  It parses the constructor and+-- passes it to @p@.  Parsers for various constructors can be constructed+-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with+-- @mappend@ from the @Monoid@ class.+readsData :: (String -> ReadS a) -> Int -> ReadS a+readsData reader d =+    readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]++-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor+-- and then parses its argument using @rp@.+readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t+readsUnaryWith rp name cons kw s =+    [(cons x,t) | kw == name, (x,t) <- rp 11 s]++-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary+-- data constructor and then parses its arguments using @rp1@ and @rp2@+-- respectively.+readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->+    String -> (a -> b -> t) -> String -> ReadS t+readsBinaryWith rp1 rp2 name cons kw s =+    [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]++-- | @'showsUnaryWith' sp n d x@ produces the string representation of a+-- unary data constructor with name @n@ and argument @x@, in precedence+-- context @d@.+showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS+showsUnaryWith sp name d x = showParen (d > 10) $+    showString name . showChar ' ' . sp 11 x++-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string+-- representation of a binary data constructor with name @n@ and arguments+-- @x@ and @y@, in precedence context @d@.+showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->+    String -> Int -> a -> b -> ShowS+showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $+    showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y++-- Obsolete building blocks++-- | @'readsUnary' n c n'@ matches the name of a unary data constructor+-- and then parses its argument using 'readsPrec'.+{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-}+readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t+readsUnary name cons kw s =+    [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]++-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor+-- and then parses its argument using 'readsPrec1'.+{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-}+readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t+readsUnary1 name cons kw s =+    [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]++-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor+-- and then parses its arguments using 'readsPrec1'.+{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-}+readsBinary1 :: (Read1 f, Read1 g, Read a) =>+    String -> (f a -> g a -> t) -> String -> ReadS t+readsBinary1 name cons kw s =+    [(cons x y,u) | kw == name,+        (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]++-- | @'showsUnary' n d x@ produces the string representation of a unary data+-- constructor with name @n@ and argument @x@, in precedence context @d@.+{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-}+showsUnary :: (Show a) => String -> Int -> a -> ShowS+showsUnary name d x = showParen (d > 10) $+    showString name . showChar ' ' . showsPrec 11 x++-- | @'showsUnary1' n d x@ produces the string representation of a unary data+-- constructor with name @n@ and argument @x@, in precedence context @d@.+{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-}+showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS+showsUnary1 name d x = showParen (d > 10) $+    showString name . showChar ' ' . showsPrec1 11 x++-- | @'showsBinary1' n d x y@ produces the string representation of a binary+-- data constructor with name @n@ and arguments @x@ and @y@, in precedence+-- context @d@.+{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-}+showsBinary1 :: (Show1 f, Show1 g, Show a) =>+    String -> Int -> f a -> g a -> ShowS+showsBinary1 name d x y = showParen (d > 10) $+    showString name . showChar ' ' . showsPrec1 11 x .+        showChar ' ' . showsPrec1 11 y++{- $example+These functions can be used to assemble 'Read' and 'Show' instances for+new algebraic types.  For example, given the definition++> data T f a = Zero a | One (f a) | Two a (f a)++a standard 'Read1' instance may be defined as++> instance (Read1 f) => Read1 (T f) where+>     liftReadsPrec rp rl = readsData $+>         readsUnaryWith rp "Zero" Zero `mappend`+>         readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend`+>         readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two++and the corresponding 'Show1' instance as++> instance (Show1 f) => Show1 (T f) where+>     liftShowsPrec sp _ d (Zero x) =+>         showsUnaryWith sp "Zero" d x+>     liftShowsPrec sp sl d (One x) =+>         showsUnaryWith (liftShowsPrec sp sl) "One" d x+>     liftShowsPrec sp sl d (Two x y) =+>         showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y++-}
+ legacy/pre711/Data/Functor/Compose.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Compose+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Composition of functors.+-----------------------------------------------------------------------------++module Data.Functor.Compose (+    Compose(..),+  ) where++import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif++import Control.Applicative+#if __GLASGOW_HASKELL__ >= 708+import Data.Data+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++infixr 9 `Compose`++-- | Right-to-left composition of functors.+-- 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) }++#if __GLASGOW_HASKELL__ >= 704+deriving instance Generic (Compose f g a)++instance Functor f => Generic1 (Compose f g) where+    type Rep1 (Compose f g) =+      D1 MDCompose+        (C1 MCCompose+          (S1 MSCompose (f :.: Rec1 g)))+    from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x))))+    to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x))++data MDCompose+data MCCompose+data MSCompose++instance Datatype MDCompose where+    datatypeName _ = "Compose"+    moduleName   _ = "Data.Functor.Compose"+# if __GLASGOW_HASKELL__ >= 708+    isNewtype    _ = True+# endif++instance Constructor MCCompose where+    conName     _ = "Compose"+    conIsRecord _ = True++instance Selector MSCompose where+    selName _ = "getCompose"+#endif++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Compose+deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a)+               => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *))+#endif++-- Instances of lifted Prelude classes++instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where+    liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y++instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where+    liftCompare comp (Compose x) (Compose y) =+        liftCompare (liftCompare comp) x y++instance (Read1 f, Read1 g) => Read1 (Compose f g) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++instance (Show1 f, Show1 g) => Show1 (Compose f g) where+    liftShowsPrec sp sl d (Compose x) =+        showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++-- Instances of Prelude classes++instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where+    (==) = eq1++instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where+    compare = compare1++instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where+    readsPrec = readsPrec1++instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where+    showsPrec = showsPrec1++-- Functor instances++instance (Functor f, Functor g) => Functor (Compose f g) where+    fmap f (Compose x) = Compose (fmap (fmap f) x)++instance (Foldable f, Foldable g) => Foldable (Compose f g) where+    foldMap f (Compose t) = foldMap (foldMap f) t++instance (Traversable f, Traversable g) => Traversable (Compose f g) where+    traverse f (Compose t) = Compose <$> traverse (traverse f) t++instance (Applicative f, Applicative g) => Applicative (Compose f g) where+    pure x = Compose (pure (pure x))+    Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)++instance (Alternative f, Applicative g) => Alternative (Compose f g) where+    empty = Compose empty+    Compose x <|> Compose y = Compose (x <|> y)++#if MIN_VERSION_base(4,12,0)+instance (Functor f, Contravariant g) => Contravariant (Compose f g) where+    contramap f (Compose fga) = Compose (fmap (contramap f) fga)+#endif
+ legacy/pre711/Data/Functor/Product.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Product+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Products, lifted to functors.+-----------------------------------------------------------------------------++module Data.Functor.Product (+    Product(..),+  ) where++import Control.Applicative+import Control.Monad (MonadPlus(..))+import Control.Monad.Fix (MonadFix(..))+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+#if __GLASGOW_HASKELL__ >= 708+import Data.Data+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif+import Data.Monoid (mappend)+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | Lifted product of functors.+data Product f g a = Pair (f a) (g a)++#if __GLASGOW_HASKELL__ >= 704+deriving instance Generic (Product f g a)++instance Generic1 (Product f g) where+    type Rep1 (Product f g) =+      D1 MDProduct+        (C1 MCPair+          (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g)))+    from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))+    to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)++data MDProduct+data MCPair++instance Datatype MDProduct where+    datatypeName _ = "Product"+    moduleName   _ = "Data.Functor.Product"++instance Constructor MCPair where+    conName _ = "Pair"+#endif++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Product+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+               => Data (Product (f :: * -> *) (g :: * -> *) (a :: *))+#endif++instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where+    liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2++instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where+    liftCompare comp (Pair x1 y1) (Pair x2 y2) =+        liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2++instance (Read1 f, Read1 g) => Read1 (Product f g) where+    liftReadsPrec rp rl = readsData $+        readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair++instance (Show1 f, Show1 g) => Show1 (Product f g) where+    liftShowsPrec sp sl d (Pair x y) =+        showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y++instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)+    where (==) = eq1+instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where+    compare = compare1+instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where+    readsPrec = readsPrec1+instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where+    showsPrec = showsPrec1++instance (Functor f, Functor g) => Functor (Product f g) where+    fmap f (Pair x y) = Pair (fmap f x) (fmap f y)++instance (Foldable f, Foldable g) => Foldable (Product f g) where+    foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y++instance (Traversable f, Traversable g) => Traversable (Product f g) where+    traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y++instance (Applicative f, Applicative g) => Applicative (Product f g) where+    pure x = Pair (pure x) (pure x)+    Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)++instance (Alternative f, Alternative g) => Alternative (Product f g) where+    empty = Pair empty empty+    Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)++instance (Monad f, Monad g) => Monad (Product f g) where+#if !(MIN_VERSION_base(4,8,0))+    return x = Pair (return x) (return x)+#endif+    Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)+      where+        fstP (Pair a _) = a+        sndP (Pair _ b) = b++instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where+    mzero = Pair mzero mzero+    Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)++instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where+    mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))+      where+        fstP (Pair a _) = a+        sndP (Pair _ b) = b++#if MIN_VERSION_base(4,4,0)+instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where+    mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)+#endif++#if MIN_VERSION_base(4,12,0)+instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where+    contramap f (Pair a b) = Pair (contramap f a) (contramap f b)+#endif
+ legacy/pre711/Data/Functor/Sum.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Sum+-- Copyright   :  (c) Ross Paterson 2014+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Sums, lifted to functors.+-----------------------------------------------------------------------------++module Data.Functor.Sum (+    Sum(..),+  ) where++import Control.Applicative+#if __GLASGOW_HASKELL__ >= 708+import Data.Data+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Functor.Classes+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif+import Data.Monoid (mappend)+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 704+import GHC.Generics+#endif++-- | Lifted sum of functors.+data Sum f g a = InL (f a) | InR (g a)++#if __GLASGOW_HASKELL__ >= 704+deriving instance Generic (Sum f g a)++instance Generic1 (Sum f g) where+    type Rep1 (Sum f g) =+      D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f))+            :+: C1 MCInR (S1 NoSelector (Rec1 g)))+    from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f))))+    from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g))))+    to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f)+    to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g)++data MDSum+data MCInL+data MCInR++instance Datatype MDSum where+    datatypeName _ = "Sum"+    moduleName   _ = "Data.Functor.Sum"++instance Constructor MCInL where+    conName _ = "InL"++instance Constructor MCInR where+    conName _ = "InR"+#endif++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Sum+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+               => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *))+#endif++instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where+    liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2+    liftEq _ (InL _) (InR _) = False+    liftEq _ (InR _) (InL _) = False+    liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2++instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where+    liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2+    liftCompare _ (InL _) (InR _) = LT+    liftCompare _ (InR _) (InL _) = GT+    liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2++instance (Read1 f, Read1 g) => Read1 (Sum f g) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend`+        readsUnaryWith (liftReadsPrec rp rl) "InR" InR++instance (Show1 f, Show1 g) => Show1 (Sum f g) where+    liftShowsPrec sp sl d (InL x) =+        showsUnaryWith (liftShowsPrec sp sl) "InL" d x+    liftShowsPrec sp sl d (InR y) =+        showsUnaryWith (liftShowsPrec sp sl) "InR" d y++instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where+    (==) = eq1+instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where+    compare = compare1+instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where+    readsPrec = readsPrec1+instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where+    showsPrec = showsPrec1++instance (Functor f, Functor g) => Functor (Sum f g) where+    fmap f (InL x) = InL (fmap f x)+    fmap f (InR y) = InR (fmap f y)++instance (Foldable f, Foldable g) => Foldable (Sum f g) where+    foldMap f (InL x) = foldMap f x+    foldMap f (InR y) = foldMap f y++instance (Traversable f, Traversable g) => Traversable (Sum f g) where+    traverse f (InL x) = InL <$> traverse f x+    traverse f (InR y) = InR <$> traverse f y++#if MIN_VERSION_base(4,12,0)+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)+#endif
transformers.cabal view
@@ -1,53 +1,93 @@ name:         transformers-version:      0.2.2.0+version:      0.6.3.0 license:      BSD3 license-file: LICENSE author:       Andy Gill, Ross Paterson-maintainer:   Ross Paterson <ross@soi.city.ac.uk>+maintainer:   Ross Paterson <R.Paterson@city.ac.uk>+bug-reports:  http://hub.darcs.net/ross/transformers/issues category:     Control synopsis:     Concrete functor and monad transformers description:-    Haskell 98 part of a monad transformer library, inspired by the paper-    \"Functional Programming with Overloading and Higher-Order Polymorphism\",-    by Mark P Jones, in /Advanced School of Functional Programming/, 1995+    A portable library of functor and monad transformers, inspired by+    the paper+    .+    * \"Functional Programming with Overloading and Higher-Order+    Polymorphism\", by Mark P Jones,+    in /Advanced School of Functional Programming/, 1995     (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>).     .-    This part contains the monad transformer class, the concrete monad-    transformers, operations and liftings.  It can be used on its own-    in Haskell 98 code, or with the monad classes in the @monads-fd@ or-    @monads-tf@ packages, which automatically lift operations introduced-    by monad transformers through other transformers.+    This package contains:+    .+    * the monad transformer class (in "Control.Monad.Trans.Class")+    .+    * concrete functor and monad transformers, each with associated+      operations and functions to lift operations associated with other+      transformers.+    .+    The package can be used on its own in portable Haskell code, in+    which case operations need to be manually lifted through transformer+    stacks (see "Control.Monad.Trans.Class" for some examples).+    Alternatively, it can be used with the non-portable monad classes in+    the @mtl@ or @monads-tf@ packages, which automatically lift operations+    introduced by monad transformers through other transformers. build-type: Simple-cabal-version: >= 1.5.5+extra-doc-files:+    changelog+    images/bind-AccumT.svg+    images/bind-ReaderT.svg+    images/bind-WriterT.svg+cabal-version: 1.18 -flag ApplicativeInBase-  description: Choose the newer base package, including Applicative and other-    Functor classes.+source-repository head+  type: darcs+  location: http://hub.darcs.net/ross/transformers  library-  if flag(ApplicativeInBase)-    build-depends: base >= 2 && < 6-  else-    build-depends: base >= 1.0 && < 2, special-functors >=1.0 && <1.1+  default-language: Haskell2010+  build-depends: base >= 2 && < 6+  hs-source-dirs: .+  if impl(ghc<7.9)+    -- Data.Functor.Identity was moved into base-4.8.0.0 (GHC 7.10)+    -- see also https://ghc.haskell.org/trac/ghc/ticket/9664+    -- NB: using impl(ghc>=7.9) instead of fragile Cabal flags+    hs-source-dirs: legacy/pre709+    exposed-modules: Data.Functor.Identity+  if impl(ghc<7.11)+    -- modules moved into base-4.9.0 (GHC 8.0)+    -- see https://ghc.haskell.org/trac/ghc/ticket/10773+    -- see https://ghc.haskell.org/trac/ghc/ticket/11135+    hs-source-dirs: legacy/pre711+    exposed-modules:+      Control.Monad.IO.Class+      Data.Functor.Classes+      Data.Functor.Compose+      Data.Functor.Product+      Data.Functor.Sum+  if impl(ghc>=7.2 && <7.5)+    -- Prior to GHC 7.5, GHC.Generics lived in ghc-prim+    build-depends: ghc-prim < 0.3   exposed-modules:-    Control.Monad.IO.Class+    Control.Applicative.Backwards+    Control.Applicative.Lift+    Control.Monad.Signatures+    Control.Monad.Trans.Accum     Control.Monad.Trans.Class     Control.Monad.Trans.Cont-    Control.Monad.Trans.Error+    Control.Monad.Trans.Except     Control.Monad.Trans.Identity-    Control.Monad.Trans.List     Control.Monad.Trans.Maybe     Control.Monad.Trans.Reader     Control.Monad.Trans.RWS+    Control.Monad.Trans.RWS.CPS     Control.Monad.Trans.RWS.Lazy     Control.Monad.Trans.RWS.Strict+    Control.Monad.Trans.Select     Control.Monad.Trans.State     Control.Monad.Trans.State.Lazy     Control.Monad.Trans.State.Strict     Control.Monad.Trans.Writer+    Control.Monad.Trans.Writer.CPS     Control.Monad.Trans.Writer.Lazy     Control.Monad.Trans.Writer.Strict-    Data.Functor.Compose     Data.Functor.Constant-    Data.Functor.Identity-    Data.Functor.Product+    Data.Functor.Reverse