diff --git a/Control/Applicative/Backwards.hs b/Control/Applicative/Backwards.hs new file mode 100644 --- /dev/null +++ b/Control/Applicative/Backwards.hs @@ -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 diff --git a/Control/Applicative/Lift.hs b/Control/Applicative/Lift.hs new file mode 100644 --- /dev/null +++ b/Control/Applicative/Lift.hs @@ -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 diff --git a/Control/Monad/IO/Class.hs b/Control/Monad/IO/Class.hs deleted file mode 100644 --- a/Control/Monad/IO/Class.hs +++ /dev/null @@ -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 diff --git a/Control/Monad/Signatures.hs b/Control/Monad/Signatures.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Signatures.hs @@ -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 diff --git a/Control/Monad/Trans/Accum.hs b/Control/Monad/Trans/Accum.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Accum.hs @@ -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@: +-- +-- <> +-- +-- 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@: +-- +-- <> +-- +-- 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 #-} diff --git a/Control/Monad/Trans/Class.hs b/Control/Monad/Trans/Class.hs --- a/Control/Monad/Trans/Class.hs +++ b/Control/Monad/Trans/Class.hs @@ -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 +-- () +-- 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 +(). + +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/ +(). + +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) + -} diff --git a/Control/Monad/Trans/Cont.hs b/Control/Monad/Trans/Cont.hs --- a/Control/Monad/Trans/Cont.hs +++ b/Control/Monad/Trans/Cont.hs @@ -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\" (). +-- ----------------------------------------------------------------------------- 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 #-} diff --git a/Control/Monad/Trans/Error.hs b/Control/Monad/Trans/Error.hs deleted file mode 100644 --- a/Control/Monad/Trans/Error.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Error --- Copyright : (c) Michael Weber 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 -#if !(MIN_VERSION_base(4,6,0)) -import Control.Monad.Instances () -- deprecated from base-4.6 -#endif -import System.IO.Error - -instance MonadPlus IO where - mzero = ioError (userError "mzero") - m `mplus` n = m `catchIOError` \_ -> n - -#if !(MIN_VERSION_base(4,4,0)) --- exported by System.IO.Error from base-4.4 -catchIOError :: IO a -> (IOError -> IO a) -> IO a -catchIOError = catch -#endif - --- | 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))) - --} diff --git a/Control/Monad/Trans/Except.hs b/Control/Monad/Trans/Except.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Except.hs @@ -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 #-} diff --git a/Control/Monad/Trans/Identity.hs b/Control/Monad/Trans/Identity.hs --- a/Control/Monad/Trans/Identity.hs +++ b/Control/Monad/Trans/Identity.hs @@ -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 #-} diff --git a/Control/Monad/Trans/List.hs b/Control/Monad/Trans/List.hs deleted file mode 100644 --- a/Control/Monad/Trans/List.hs +++ /dev/null @@ -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) diff --git a/Control/Monad/Trans/Maybe.hs b/Control/Monad/Trans/Maybe.hs --- a/Control/Monad/Trans/Maybe.hs +++ b/Control/Monad/Trans/Maybe.hs @@ -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 #-} diff --git a/Control/Monad/Trans/RWS.hs b/Control/Monad/Trans/RWS.hs --- a/Control/Monad/Trans/RWS.hs +++ b/Control/Monad/Trans/RWS.hs @@ -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 ( diff --git a/Control/Monad/Trans/RWS/CPS.hs b/Control/Monad/Trans/RWS/CPS.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/RWS/CPS.hs @@ -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 #-} diff --git a/Control/Monad/Trans/RWS/Lazy.hs b/Control/Monad/Trans/RWS/Lazy.hs --- a/Control/Monad/Trans/RWS/Lazy.hs +++ b/Control/Monad/Trans/RWS/Lazy.hs @@ -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 #-} diff --git a/Control/Monad/Trans/RWS/Strict.hs b/Control/Monad/Trans/RWS/Strict.hs --- a/Control/Monad/Trans/RWS/Strict.hs +++ b/Control/Monad/Trans/RWS/Strict.hs @@ -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 #-} diff --git a/Control/Monad/Trans/Reader.hs b/Control/Monad/Trans/Reader.hs --- a/Control/Monad/Trans/Reader.hs +++ b/Control/Monad/Trans/Reader.hs @@ -1,4 +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 @@ -6,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 -- @@ -38,133 +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 #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: +-- +-- <> +-- 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: +-- +-- <> +-- +-- +-- @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 #-} diff --git a/Control/Monad/Trans/Select.hs b/Control/Monad/Trans/Select.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Select.hs @@ -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. +-- +-- +-- * Jules Hedges. "Monad transformers for backtracking search". +-- In /Proceedings of MSFP 2014/. +----------------------------------------------------------------------------- + +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 #-} diff --git a/Control/Monad/Trans/State.hs b/Control/Monad/Trans/State.hs --- a/Control/Monad/Trans/State.hs +++ b/Control/Monad/Trans/State.hs @@ -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: -- diff --git a/Control/Monad/Trans/State/Lazy.hs b/Control/Monad/Trans/State/Lazy.hs --- a/Control/Monad/Trans/State/Lazy.hs +++ b/Control/Monad/Trans/State/Lazy.hs @@ -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 (), November 1998: +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (), 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) -} diff --git a/Control/Monad/Trans/State/Strict.hs b/Control/Monad/Trans/State/Strict.hs --- a/Control/Monad/Trans/State/Strict.hs +++ b/Control/Monad/Trans/State/Strict.hs @@ -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 (), November 1998: +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (), 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) -} diff --git a/Control/Monad/Trans/Writer.hs b/Control/Monad/Trans/Writer.hs --- a/Control/Monad/Trans/Writer.hs +++ b/Control/Monad/Trans/Writer.hs @@ -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 ( diff --git a/Control/Monad/Trans/Writer/CPS.hs b/Control/Monad/Trans/Writer/CPS.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Writer/CPS.hs @@ -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 @<>@): +-- +-- <> +-- +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 @<>@): +-- +-- <> +-- +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 #-} diff --git a/Control/Monad/Trans/Writer/Lazy.hs b/Control/Monad/Trans/Writer/Lazy.hs --- a/Control/Monad/Trans/Writer/Lazy.hs +++ b/Control/Monad/Trans/Writer/Lazy.hs @@ -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 @<>@): +-- +-- <> +-- 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 @<>@): +-- +-- <> +-- 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 #-} diff --git a/Control/Monad/Trans/Writer/Strict.hs b/Control/Monad/Trans/Writer/Strict.hs --- a/Control/Monad/Trans/Writer/Strict.hs +++ b/Control/Monad/Trans/Writer/Strict.hs @@ -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 @<>@): +-- +-- <> +-- 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 @<>@): +-- +-- <> +-- 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 #-} diff --git a/Data/Functor/Compose.hs b/Data/Functor/Compose.hs deleted file mode 100644 --- a/Data/Functor/Compose.hs +++ /dev/null @@ -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) diff --git a/Data/Functor/Constant.hs b/Data/Functor/Constant.hs --- a/Data/Functor/Constant.hs +++ b/Data/Functor/Constant.hs @@ -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 diff --git a/Data/Functor/Identity.hs b/Data/Functor/Identity.hs deleted file mode 100644 --- a/Data/Functor/Identity.hs +++ /dev/null @@ -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)) diff --git a/Data/Functor/Product.hs b/Data/Functor/Product.hs deleted file mode 100644 --- a/Data/Functor/Product.hs +++ /dev/null @@ -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) diff --git a/Data/Functor/Reverse.hs b/Data/Functor/Reverse.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Reverse.hs @@ -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 diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,174 @@ +-*-change-log-*- + +0.6.3.0 Ross Paterson Jan 2026 + * Add Control.Monad.Trans.Except.onE + * Add strictToLazyState and lazyToStrictStateT + +0.6.2.0 Ross Paterson Apr 2025 + * Redefine runAccumT, runExceptT and runSelectT as fields + * Document strictness of some transformers + +0.6.1.2 Ross Paterson Sep 2024 + * Portability fixes for MicroHs + * Include image files in the bundle + * Expand ExceptT documentation + +0.6.1.1 Ross Paterson Aug 2023 + * Additions to documentation, especially of AccumT. + +0.6.1.0 Ross Paterson Feb 2023 + * Add instances of Foldable1 (class added to base-4.18) + * Add modifyM to StateT transformers + +0.6.0.6 Ross Paterson Jan 2023 + * Fix for GHC 8.6 + +0.6.0.5 Ross Paterson Jan 2023 + * Revert to allowing MonadTrans constraint with GHC >= 8.6 + +0.6.0.4 Ross Paterson Feb 2022 + * Restrict deriving (Generic) to GHC >= 7.4 + +0.6.0.3 Ross Paterson Feb 2022 + * Restrict MonadTrans constraint to GHC >= 8.8 + +0.6.0.2 Ross Paterson Jul 2021 + * Further backward compatability fix + +0.6.0.1 Ross Paterson Jul 2021 + * Backward compatability fixes + +0.6.0.0 Ross Paterson 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 Feb 2019 + * Further backward compatability fix + +0.5.6.1 Ross Paterson Feb 2019 + * Backward compatability fix for MonadFix ListT instance + +0.5.6.0 Ross Paterson 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 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 Feb 2017 + * Migrate Bifoldable and Bitraversable instances for Constant + +0.5.3.1 Ross Paterson Feb 2017 + * Fixed for pre-AMP environments + +0.5.3.0 Ross Paterson 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 Feb 2016 + * Re-added orphan instances for Either to deprecated module + * Added lots of INLINE pragmas + +0.5.1.0 Ross Paterson Jan 2016 + * Bump minor version number, required by added instances + +0.5.0.2 Ross Paterson Jan 2016 + * Backported extra instances for Identity + +0.5.0.1 Ross Paterson Jan 2016 + * Tightened GHC bounds for PolyKinds and DeriveDataTypeable + +0.5.0.0 Ross Paterson 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 Mar 2015 + * Added Eq1, Ord1, Show1 and Read1 instances for Const + +0.4.2.0 Ross Paterson 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 May 2014 + * Reverted to record syntax for newtypes until next major release + +0.4.0.0 Ross Paterson 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 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 Oct 2013 + * Backport of fix for disappearance of Control.Monad.Instances + +0.2.2.0 Ross Paterson Sep 2010 + * Handled move of Either instances to base package + +0.2.1.0 Ross Paterson Apr 2010 + * Added Alternative instance for Compose + * Added Data.Functor.Product + +0.2.0.0 Ross Paterson 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 Mar 2009 + * Adjusted lifting of Identity and Maybe transformers + +0.1.3.0 Ross Paterson Mar 2009 + * Added IdentityT transformer + * Added Applicative and Alternative instances for (Either e) + +0.1.1.0 Ross Paterson Jan 2009 + * Made all Functor instances assume Functor + +0.1.0.1 Ross Paterson Jan 2009 + * Adjusted dependencies + +0.1.0.0 Ross Paterson Jan 2009 + * Two versions of lifting of callcc through StateT + * Added Applicative instances + +0.0.1.0 Ross Paterson Jan 2009 + * Added constructors state, etc for simple monads + +0.0.0.0 Ross Paterson Jan 2009 + * Split Haskell 98 transformers from the mtl diff --git a/images/bind-AccumT.svg b/images/bind-AccumT.svg new file mode 100644 --- /dev/null +++ b/images/bind-AccumT.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + <> + + + + + <> + + + w + + + + + m + + k + + diff --git a/images/bind-ReaderT.svg b/images/bind-ReaderT.svg new file mode 100644 --- /dev/null +++ b/images/bind-ReaderT.svg @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + + + + r + + + + + m + + k + + diff --git a/images/bind-WriterT.svg b/images/bind-WriterT.svg new file mode 100644 --- /dev/null +++ b/images/bind-WriterT.svg @@ -0,0 +1,60 @@ + + + + + + + + + + + + + + + + + <> + + + w + + + + + m + + k + + diff --git a/legacy/pre709/Data/Functor/Identity.hs b/legacy/pre709/Data/Functor/Identity.hs new file mode 100644 --- /dev/null +++ b/legacy/pre709/Data/Functor/Identity.hs @@ -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 diff --git a/legacy/pre711/Control/Monad/IO/Class.hs b/legacy/pre711/Control/Monad/IO/Class.hs new file mode 100644 --- /dev/null +++ b/legacy/pre711/Control/Monad/IO/Class.hs @@ -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 diff --git a/legacy/pre711/Data/Functor/Classes.hs b/legacy/pre711/Data/Functor/Classes.hs new file mode 100644 --- /dev/null +++ b/legacy/pre711/Data/Functor/Classes.hs @@ -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 + +-} diff --git a/legacy/pre711/Data/Functor/Compose.hs b/legacy/pre711/Data/Functor/Compose.hs new file mode 100644 --- /dev/null +++ b/legacy/pre711/Data/Functor/Compose.hs @@ -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 diff --git a/legacy/pre711/Data/Functor/Product.hs b/legacy/pre711/Data/Functor/Product.hs new file mode 100644 --- /dev/null +++ b/legacy/pre711/Data/Functor/Product.hs @@ -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 diff --git a/legacy/pre711/Data/Functor/Sum.hs b/legacy/pre711/Data/Functor/Sum.hs new file mode 100644 --- /dev/null +++ b/legacy/pre711/Data/Functor/Sum.hs @@ -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 diff --git a/transformers.cabal b/transformers.cabal --- a/transformers.cabal +++ b/transformers.cabal @@ -1,53 +1,93 @@ name: transformers -version: 0.2.2.1 +version: 0.6.3.0 license: BSD3 license-file: LICENSE author: Andy Gill, Ross Paterson -maintainer: Ross Paterson +maintainer: Ross Paterson +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 (). . - 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