diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/transformers/Control/Monad')
22 files changed, 5571 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs new file mode 100644 index 0000000000..ce128ee182 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs @@ -0,0 +1,56 @@ +{-# 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 +-- +-- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@ +-- +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 +-- +-- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@ +-- +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 +-- +-- * @'lift' . liftListen = liftListen . '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 +-- +-- * @'lift' . liftPass = liftPass . 'lift'@ +-- +type Pass w m a = m (a, w -> w) -> m a diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs new file mode 100644 index 0000000000..0a85c43f62 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# 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. +-- +-- This monad transformer provides append-only accumulation +-- during the computation. For more general access, 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(AccumT), + runAccumT, + 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 + +-- --------------------------------------------------------------------------- +-- | An accumulation 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'. +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. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +-- +-- This monad transformer is similar to both state and writer monad transformers. +-- Thus it can be seen as +-- +-- * a restricted append-only version of a state monad transformer or +-- +-- * a writer monad transformer with the extra ability to read all previous output. +newtype AccumT w m a = AccumT (w -> m (a, w)) + +-- | Unwrap an accumulation computation. +runAccumT :: AccumT w m a -> w -> m (a, w) +runAccumT (AccumT f) = f +{-# INLINE runAccumT #-} + +-- | 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. +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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs new file mode 100644 index 0000000000..b92bc0e8b0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.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 +-- +-- The class of monad transformers. +-- +-- 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 'Data.Functor.Identity.Identity', @[]@ or 'IO', and +-- applies a sequence of monad transformers. +----------------------------------------------------------------------------- + +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 monad transformation: +-- +-- * @'lift' . 'return' = 'return'@ +-- +-- * @'lift' (m >>= f) = 'lift' m >>= ('lift' . f)@ + +class MonadTrans t where + -- | Lift a computation from the argument monad to the constructed monad. + lift :: (Monad m) => m a -> t m a + +{- $conventions +Most monad transformer modules 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'@. + +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 the next +major release they will 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 is strict in its first +argument. The base monads 'Maybe', @[]@ and 'IO' are strict: + +>>> undefined >> return 2 :: Maybe Integer +*** Exception: Prelude.undefined + +However the monad 'Data.Functor.Identity.Identity' is not: + +>>> runIdentity (undefined >> return 2) +2 + +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 + +The first example is a parser monad in the style of + +* \"Monadic parsing in Haskell\", by Graham Hutton and Erik Meijer, +/Journal of Functional Programming/ 8(4):437-444, July 1998 +(<http://www.cs.nott.ac.uk/~pszgmh/bib.html#pearl>). + +We can define such a parser monad by adding a state (the 'String' remaining +to be parsed) to the @[]@ monad, which provides non-determinism: + +> import Control.Monad.Trans.State +> +> 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: + +> runParser :: Parser a -> String -> [a] +> runParser p s = [x | (x, "") <- runStateT p s] + +Finally, we need a primitive parser that matches a single character, +from which arbitrarily complex parsers may be constructed: + +> item :: Parser Char +> item = do +> c:cs <- get +> put cs +> return c + +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 '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 +'Control.Monad.Trans.Writer.Lazy.WriterT' transformer: + +> import Control.Monad.Trans.Class +> import Control.Monad.Trans.State +> import Control.Monad.Trans.Writer +> import Data.Monoid +> +> type Parser = WriterT (Sum Int) (StateT String []) + +The function that applies a parser must now unwrap each of the monad +transformers in turn: + +> runParser :: Parser a -> String -> [(a, Int)] +> runParser p s = [(x, n) | ((x, Sum n), "") <- runStateT (runWriterT p) s] + +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 +> c:cs <- lift get +> lift (put cs) +> return c + +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 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: + +> tick :: Parser () +> tick = tell (Sum 1) + +Then the parser will keep track of how many @tick@s it executes. +-} + +{- $example3 + +This example is a cut-down version of the one in + +* \"Monad Transformers and Modular Interpreters\", +by Sheng Liang, Paul Hudak and Mark Jones in /POPL'95/ +(<http://web.cecs.pdx.edu/~mpj/pubs/modinterp.html>). + +Suppose we want to define an interpreter that can do I\/O and has +exceptions, an environment and a modifiable store. We can define +a monad that supports all these things as a stack of monad transformers: + +> import Control.Monad.Trans.Class +> import Control.Monad.Trans.State +> import qualified Control.Monad.Trans.Reader as R +> import qualified Control.Monad.Trans.Except as E +> import Control.Monad.IO.Class +> +> type InterpM = StateT Store (R.ReaderT Env (E.ExceptT Err IO)) + +for suitable types @Store@, @Env@ and @Err@. + +Now we would like to be able to use the operations associated with each +of those monad transformers on @InterpM@ actions. Since the uppermost +monad transformer of @InterpM@ is 'Control.Monad.Trans.State.Lazy.StateT', +it already has the state operations @get@ and @set@. + +The first of the 'Control.Monad.Trans.Reader.ReaderT' operations, +'Control.Monad.Trans.Reader.ask', is a simple action, so we can lift it +through 'Control.Monad.Trans.State.Lazy.StateT' to @InterpM@ using 'lift': + +> ask :: InterpM Env +> ask = lift R.ask + +The other 'Control.Monad.Trans.Reader.ReaderT' operation, +'Control.Monad.Trans.Reader.local', has a suitable type for lifting +using 'Control.Monad.Trans.State.Lazy.mapStateT': + +> local :: (Env -> Env) -> InterpM a -> InterpM a +> local f = mapStateT (R.local f) + +We also wish to lift the operations of 'Control.Monad.Trans.Except.ExceptT' +through both 'Control.Monad.Trans.Reader.ReaderT' and +'Control.Monad.Trans.State.Lazy.StateT'. For the operation +'Control.Monad.Trans.Except.throwE', we know @throwE e@ is a simple +action, so we can lift it through the two monad transformers to @InterpM@ +with two 'lift's: + +> throwE :: Err -> InterpM a +> throwE e = lift (lift (E.throwE e)) + +The 'Control.Monad.Trans.Except.catchE' operation has a more +complex type, so we need to use the special-purpose lifting function +@liftCatch@ provided by most monad transformers. Here we use +the 'Control.Monad.Trans.Reader.ReaderT' version followed by the +'Control.Monad.Trans.State.Lazy.StateT' version: + +> catchE :: InterpM a -> (Err -> InterpM a) -> InterpM a +> catchE = liftCatch (R.liftCatch E.catchE) + +We could lift 'IO' actions to @InterpM@ using three 'lift's, but @InterpM@ +is automatically an instance of 'Control.Monad.IO.Class.MonadIO', +so we can use 'Control.Monad.IO.Class.liftIO' instead: + +> putStr :: String -> InterpM () +> putStr s = liftIO (Prelude.putStr s) + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs new file mode 100644 index 0000000000..ce2005d4b2 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Cont +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Continuation monads. +-- +-- Delimited continuation operators are taken from Kenichi Asai and Oleg +-- Kiselyov's tutorial at CW 2011, \"Introduction to programming with +-- shift and reset\" (<http://okmij.org/ftp/continuations/#tutorial>). +-- +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Cont ( + -- * The Cont monad + 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 + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif + +{- | +Continuation monad. +@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. + +The @>>=@ operator adds the bound function into the continuation chain. +-} +type Cont r = ContT r Identity + +-- | Construct a continuation-passing computation from a function. +-- (The inverse of 'runCont') +cont :: ((a -> r) -> r) -> Cont r a +cont f = ContT (\ c -> Identity (f (runIdentity . c))) +{-# INLINE cont #-} + +-- | 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 #-} + +-- | @'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. +newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r } + +-- | 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) + {-# INLINE fmap #-} + +instance Applicative (ContT r m) where + 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 +#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.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. +-- +-- The standard idiom used with @callCC@ is to provide a lambda-expression +-- to name the continuation. Then calling the named continuation anywhere +-- 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 (\ 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) -> + (r' -> r') -> ContT r m a -> ContT r m a +liftLocal ask local f m = ContT $ \ c -> do + r <- ask + local f (runContT m (local (const r) . c)) +{-# INLINE liftLocal #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs new file mode 100644 index 0000000000..6eda4b3e01 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +#if !(MIN_VERSION_base(4,9,0)) +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Error +-- Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001, +-- (c) Jeff Newbern 2003-2006, +-- (c) Andriy Palamarchuk 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@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. +-- +-- /Note:/ This module will be removed in a future release. +-- Instead, use "Control.Monad.Trans.Except", which does not restrict +-- the exception type, and also includes a base exception monad. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Error + {-# DEPRECATED "Use Control.Monad.Trans.Except instead" #-} ( + -- * 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.Signatures +import Control.Monad.Trans.Class +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +import Control.Exception (IOException) +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 +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid (mempty) +import Data.Traversable (Traversable(traverse)) +import System.IO.Error + +#if !(MIN_VERSION_base(4,9,0)) +-- These instances are in base-4.9.0 + +instance MonadPlus IO where + mzero = ioError (userError "mzero") + m `mplus` n = m `catchIOError` \ _ -> n + +instance Alternative IO where + empty = mzero + (<|>) = mplus + +# 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 +#endif + +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 + +#if !(MIN_VERSION_base(4,3,0)) +-- 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 */ + +-- | 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 + +-- | 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) } + +instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where + liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y + +instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where + liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y + +instance (Read e, Read1 m) => Read1 (ErrorT e m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show e, Show1 m) => Show1 (ErrorT e m) where + liftShowsPrec sp sl d (ErrorT m) = + showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1 +instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1 +instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where + readsPrec = readsPrec1 +instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where + showsPrec = showsPrec1 + +-- | 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 (Foldable f) => Foldable (ErrorT e f) where + foldMap f (ErrorT a) = foldMap (either (const mempty) f) a + +instance (Traversable f) => Traversable (ErrorT e f) where + traverse f (ErrorT a) = + ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a + +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 +#if !(MIN_VERSION_base(4,8,0)) + return a = ErrorT $ return (Right a) +#endif + m >>= k = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> runErrorT (k r) +#if !(MIN_VERSION_base(4,13,0)) + fail msg = ErrorT $ return (Left (strMsg msg)) +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where + fail msg = ErrorT $ return (Left (strMsg msg)) +#endif + +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 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 + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (ErrorT e m) where + contramap f = ErrorT . contramap (fmap f) . runErrorT +#endif + +-- | Signal an error value @e@. +-- +-- * @'runErrorT' ('throwError' e) = 'return' ('Left' e)@ +-- +-- * @'throwError' e >>= m = 'throwError' e@ +throwError :: (Monad m) => e -> ErrorT e m a +throwError l = ErrorT $ return (Left l) + +-- | Handle an error. +-- +-- * @'catchError' h ('lift' m) = 'lift' m@ +-- +-- * @'catchError' h ('throwError' e) = h e@ +catchError :: (Monad m) => + 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 :: CallCC m (Either e a) (Either e b) -> CallCC (ErrorT e m) a b +liftCallCC callCC f = ErrorT $ + callCC $ \ c -> + runErrorT (f (\ a -> ErrorT $ c (Right a))) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ErrorT e m) a +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) => Pass w m (Either e a) -> Pass 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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs new file mode 100644 index 0000000000..477b9dd482 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# 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 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(ExceptT), + runExceptT, + mapExceptT, + withExceptT, + -- * Exception operations + throwE, + catchE, + -- * 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 +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid +import Data.Traversable (Traversable(traverse)) + +-- | The parameterizable exception monad. +-- +-- Computations are either exceptions or normal values. +-- +-- 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 monad parameterized over two things: +-- +-- * e - The exception type. +-- +-- * m - The inner 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 (m (Either e a)) + +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 + +-- | The inverse of 'ExceptT'. +runExceptT :: ExceptT e m a -> m (Either e a) +runExceptT (ExceptT m) = m +{-# INLINE runExceptT #-} + +-- | 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 #-} + +-- | 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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs new file mode 100644 index 0000000000..2a0db5e5a1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Identity +-- Copyright : (c) 2007 Magnus Therning +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity monad transformer. +-- +-- This is useful for functions parameterized by a monad transformer. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Identity ( + -- * The identity monad transformer + IdentityT(..), + mapIdentityT, + -- * Lifting other operations + liftCatch, + liftCallCC, + ) where + +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Signatures +import Control.Monad.Trans.Class (MonadTrans(lift)) +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 +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) + +-- | The trivial monad transformer, which maps a monad to an equivalent monad. +newtype IdentityT f a = IdentityT { runIdentityT :: f a } + +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 + +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 :: CallCC m a b -> CallCC (IdentityT m) a b +liftCallCC callCC f = + IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c)) +{-# INLINE liftCallCC #-} + +-- | 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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs new file mode 100644 index 0000000000..0bdbcc732e --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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 : R.Paterson@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 + {-# DEPRECATED "This transformer is invalid on most monads" #-} ( + -- * The ListT monad transformer + ListT(..), + mapListT, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) 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 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 +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) + +-- | 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] } + +instance (Eq1 m) => Eq1 (ListT m) where + liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y + {-# INLINE liftEq #-} + +instance (Ord1 m) => Ord1 (ListT m) where + liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y + {-# INLINE liftCompare #-} + +instance (Read1 m) => Read1 (ListT m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show1 m) => Show1 (ListT m) where + liftShowsPrec sp sl d (ListT m) = + showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1 +instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1 +instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1 +instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 + +-- | 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) +{-# INLINE mapListT #-} + +instance (Functor m) => Functor (ListT m) where + fmap f = mapListT $ fmap $ map f + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (ListT f) where + foldMap f (ListT a) = foldMap (foldMap f) a + {-# INLINE foldMap #-} + +instance (Traversable f) => Traversable (ListT f) where + traverse f (ListT a) = ListT <$> traverse (traverse f) a + {-# INLINE traverse #-} + +instance (Applicative m) => Applicative (ListT m) where + pure a = ListT $ pure [a] + {-# INLINE pure #-} + f <*> v = ListT $ (<*>) <$> runListT f <*> runListT v + {-# INLINE (<*>) #-} + +instance (Applicative m) => Alternative (ListT m) where + empty = ListT $ pure [] + {-# INLINE empty #-} + m <|> n = ListT $ (++) <$> runListT m <*> runListT n + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (ListT m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = ListT $ return [a] + {-# INLINE return #-} +#endif + m >>= k = ListT $ do + a <- runListT m + b <- mapM (runListT . k) a + return (concat b) + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail _ = ListT $ return [] + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monad m) => Fail.MonadFail (ListT m) where + fail _ = ListT $ return [] + {-# INLINE fail #-} +#endif + +instance (Monad m) => MonadPlus (ListT m) where + mzero = ListT $ return [] + {-# INLINE mzero #-} + m `mplus` n = ListT $ do + a <- runListT m + b <- runListT n + return (a ++ b) + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (ListT m) where + mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of + [] -> return [] + x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f))) + {-# INLINE mfix #-} + +instance MonadTrans ListT where + lift m = ListT $ do + a <- m + return [a] + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (ListT m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip m) => MonadZip (ListT m) where + mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b + {-# INLINE mzipWith #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (ListT m) where + contramap f = ListT . contramap (fmap f) . runListT + {-# INLINE contramap #-} +#endif + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m [a] [b] -> CallCC (ListT m) a b +liftCallCC callCC f = ListT $ + callCC $ \ c -> + runListT (f (\ a -> ListT $ c [a])) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m [a] -> Catch e (ListT m) a +liftCatch catchE m h = ListT $ runListT m + `catchE` \ e -> runListT (h e) +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs new file mode 100644 index 0000000000..f02b225444 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Maybe +-- Copyright : (c) 2007 Yitzak Gale, Eric Kidd +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The 'MaybeT' monad transformer extends a monad with the ability to exit +-- the computation without returning a value. +-- +-- 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 exception values, see +-- "Control.Monad.Trans.Except". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Maybe ( + -- * The MaybeT monad transformer + MaybeT(..), + mapMaybeT, + -- * Monad transformations + maybeToExceptT, + exceptToMaybeT, + -- * Lifting other operations + liftCallCC, + liftCatch, + liftListen, + liftPass, + ) 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) +#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 (Foldable(foldMap)) +import Data.Maybe (fromMaybe) +import Data.Traversable (Traversable(traverse)) + +-- | The parameterizable maybe monad, obtained by composing an arbitrary +-- monad with the 'Maybe' monad. +-- +-- Computations are actions that may produce a value or exit. +-- +-- 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) } + +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 '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 = 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 = 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 +#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 :: 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 @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) => 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) => 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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs new file mode 100644 index 0000000000..b4cc6adaad --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS +-- 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 +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and '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 ( + module Control.Monad.Trans.RWS.Lazy + ) where + +import Control.Monad.Trans.RWS.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs new file mode 100644 index 0000000000..8a565e1652 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# 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 'ReaderT', 'WriterT' and '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 + +-- | 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) } + +-- | 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. +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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs new file mode 100644 index 0000000000..8f98b2c5e0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS.Lazy +-- 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 +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and '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 ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + 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.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Data.Monoid + +-- | 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 :: (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 #-} + +-- | 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 #-} + +-- | 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) } + +-- | 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 #-} + +-- | 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) +{-# 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) +{-# INLINE withRWST #-} + +instance (Functor m) => Functor (RWST r w s m) where + 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 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 = 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 +#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') + {-# 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 + {-# 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 + {-# INLINE mfix #-} + +instance (Monoid w) => MonadTrans (RWST r w s) where + 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) +{-# 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 -> 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 = 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 :: (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. +-- +-- * @'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)@ +-- +-- * @'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. +-- +-- * @'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)@ +-- +-- * @'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) +{-# 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) +{-# 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 = 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 = 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) => + 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) => + 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 @catchE@ operation to the new monad. +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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs new file mode 100644 index 0000000000..557dd2028d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS.Strict +-- 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 +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and '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 ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + 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.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Data.Monoid + +-- | 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 :: (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 #-} + +-- | 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 #-} + +-- | 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) } + +-- | 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 #-} + +-- | 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) +{-# 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) +{-# INLINE withRWST #-} + +instance (Functor m) => Functor (RWST r w s m) where + 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 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 = 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 +#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') + {-# 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 + {-# 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 + {-# INLINE mfix #-} + +instance (Monoid w) => MonadTrans (RWST r w s) where + 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) +{-# 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 -> 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 = 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 :: (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. +-- +-- * @'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)@ +-- +-- * @'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. +-- +-- * @'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)@ +-- +-- * @'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) +{-# 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) +{-# 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 = 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 = 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) => + 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) => + 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 @catchE@ operation to the new monad. +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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs new file mode 100644 index 0000000000..25e3ad27c3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Reader +-- 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 +-- +-- Declaration of the 'ReaderT' monad transformer, which adds a static +-- environment to a given monad. +-- +-- If the computation is to modify the stored information, use +-- "Control.Monad.Trans.State" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Reader ( + -- * The Reader monad + Reader, + reader, + runReader, + mapReader, + withReader, + -- * The ReaderT monad transformer + ReaderT(..), + mapReaderT, + withReaderT, + -- * Reader operations + ask, + local, + asks, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) 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) +import Data.Functor(Functor(..)) +#endif + +-- | The parameterizable reader monad. +-- +-- Computations are functions of a shared environment. +-- +-- The 'return' function ignores the environment, while @>>=@ passes +-- the inherited environment to both subcomputations. +type Reader r = ReaderT r Identity + +-- | 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. +-- (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 { runReaderT :: r -> m a } + +-- | 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'). +-- +-- * @'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'). +-- +-- * @'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 = ReaderT (return . f) +{-# INLINE asks #-} + +-- | Lift a @callCC@ operation to the new monad. +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 @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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs new file mode 100644 index 0000000000..22fdf8fd8a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Select +-- Copyright : (c) Ross Paterson 2017 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Selection monad transformer, modelling search algorithms. +-- +-- * Martin Escardo and Paulo Oliva. +-- "Selection functions, bar recursion and backward induction", +-- /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168. +-- <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf> +-- +-- * Jules Hedges. "Monad transformers for backtracking search". +-- In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058> +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Select ( + -- * The Select monad + Select, + select, + runSelect, + mapSelect, + -- * The SelectT monad transformer + SelectT(SelectT), + runSelectT, + mapSelectT, + -- * Monad transformation + selectToContT, + selectToCont, + ) 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 + +-- | Selection monad. +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. +newtype SelectT r m a = SelectT ((a -> m r) -> m a) + +-- | Runs a @SelectT@ computation with a function for evaluating answers +-- to select a particular answer. (The inverse of 'select'.) +runSelectT :: SelectT r m a -> (a -> m r) -> m a +runSelectT (SelectT g) = g +{-# INLINE runSelectT #-} + +-- | 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 selectToCont #-} + +-- | Deprecated name for 'selectToContT'. +{-# DEPRECATED selectToCont "Use selectToContT instead" #-} +selectToCont :: (Monad m) => SelectT r m a -> ContT r m a +selectToCont = selectToContT diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs new file mode 100644 index 0000000000..36de964ea1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State +-- 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 +-- +-- State monads, passing an updatable state through a computation. +-- +-- 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". +-- +-- This version is lazy; for a strict version, see +-- "Control.Monad.Trans.State.Strict", which has the same interface. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.State ( + module Control.Monad.Trans.State.Lazy + ) where + +import Control.Monad.Trans.State.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs new file mode 100644 index 0000000000..d7cdde5444 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State.Lazy +-- 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 +-- +-- Lazy state monads, passing an updatable state through a computation. +-- See below for examples. +-- +-- 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 ( + -- * The State monad + State, + state, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + -- * State operations + get, + put, + modify, + modify', + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + liftListen, + liftPass, + -- * Examples + -- ** State monads + -- $examples + + -- ** Counting + -- $counting + + -- ** Labelling trees + -- $labelling + ) 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 + +-- --------------------------------------------------------------------------- +-- | A state monad parameterized by the type @s@ of the state to carry. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +type State s = StateT s Identity + +-- | Construct a state monad computation from a function. +-- (The inverse of 'runState'.) +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'.) +runState :: State s a -- ^state-passing computation to execute + -> 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. +-- +-- * @'evalState' m s = 'fst' ('runState' m s)@ +evalState :: State s a -- ^state-passing computation to execute + -> 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. +-- +-- * @'execState' m s = 'snd' ('runState' m s)@ +execState :: State s a -- ^state-passing computation to execute + -> 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. +-- +-- * @'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@. +-- +-- * @'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: +-- +-- * @s@ - The state. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- 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) } + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ +evalStateT :: (Monad m) => StateT s m a -> s -> m a +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. +-- +-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ +execStateT :: (Monad m) => StateT s m a -> s -> m s +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. +-- +-- * @'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@. +-- +-- * @'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 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 = StateT $ \ _ -> mzero + {-# INLINE empty #-} + StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (StateT s m) where +#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' + {-# 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 + {-# 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 + {-# INLINE mfix #-} + +instance MonadTrans (StateT s) where + 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 = 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 = 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 = 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 +{-# INLINE modify' #-} + +-- | 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 = 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 :: 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 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 @catchE@ operation to the new monad. +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) => 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) => 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 + +Parser from ParseLib with Hugs: + +> type Parser a = StateT String [] a +> ==> StateT (String -> [(a,String)]) + +For example, item can be written as: + +> item = do (x:xs) <- get +> put xs +> return x +> +> type BoringState s a = StateT s Identity a +> ==> StateT (s -> Identity (a,s)) +> +> type StateWithIO s a = StateT s IO a +> ==> StateT (s -> IO (a,s)) +> +> type StateWithErr s a = StateT s Maybe a +> ==> StateT (s -> Maybe (a,s)) + +-} + +{- $counting + +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998: + +> tick :: State Int Int +> tick = do n <- get +> put (n+1) +> return n + +Add one to the given number using the state monad: + +> plusOne :: Int -> Int +> plusOne n = execState tick n + +A contrived addition example. Works only with positive numbers: + +> plus :: Int -> Int -> Int +> plus n x = execState (sequence $ replicate n tick) x + +-} + +{- $labelling + +An example from /The Craft of Functional Programming/, Simon +Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>), +Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +tree of integers in which the original elements are replaced by +natural numbers, starting from 0. The same element has to be +replaced by the same number at every occurrence, and when we meet +an as-yet-unvisited element we have to find a \'new\' number to match +it with:\" + +> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +> type Table a = [a] + +> 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 +> numberNode :: Eq a => a -> State (Table a) Int +> 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: + +> numTree :: (Eq a) => Tree a -> Tree Int +> numTree t = evalState (numberTree t) [] + +> 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 + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs new file mode 100644 index 0000000000..d0fb58edb4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State.Strict +-- 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 +-- +-- Strict state monads, passing an updatable state through a computation. +-- See below for examples. +-- +-- 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 ( + -- * The State monad + State, + state, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + -- * State operations + get, + put, + modify, + modify', + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + liftListen, + liftPass, + -- * Examples + -- ** State monads + -- $examples + + -- ** Counting + -- $counting + + -- ** Labelling trees + -- $labelling + ) 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 + +-- --------------------------------------------------------------------------- +-- | A state monad parameterized by the type @s@ of the state to carry. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +type State s = StateT s Identity + +-- | Construct a state monad computation from a function. +-- (The inverse of 'runState'.) +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'.) +runState :: State s a -- ^state-passing computation to execute + -> 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. +-- +-- * @'evalState' m s = 'fst' ('runState' m s)@ +evalState :: State s a -- ^state-passing computation to execute + -> 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. +-- +-- * @'execState' m s = 'snd' ('runState' m s)@ +execState :: State s a -- ^state-passing computation to execute + -> 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. +-- +-- * @'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@. +-- +-- * @'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: +-- +-- * @s@ - The state. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- 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) } + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ +evalStateT :: (Monad m) => StateT s m a -> s -> m a +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. +-- +-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ +execStateT :: (Monad m) => StateT s m a -> s -> m s +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. +-- +-- * @'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@. +-- +-- * @'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 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 = StateT $ \ _ -> mzero + {-# INLINE empty #-} + StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (StateT s m) where +#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' + {-# 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 + {-# 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 + {-# INLINE mfix #-} + +instance MonadTrans (StateT s) where + 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 = 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 = 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 = 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 +{-# INLINE modify' #-} + +-- | 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 = 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 :: 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 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 @catchE@ operation to the new monad. +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) => 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) => 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 + +Parser from ParseLib with Hugs: + +> type Parser a = StateT String [] a +> ==> StateT (String -> [(a,String)]) + +For example, item can be written as: + +> item = do (x:xs) <- get +> put xs +> return x +> +> type BoringState s a = StateT s Identity a +> ==> StateT (s -> Identity (a,s)) +> +> type StateWithIO s a = StateT s IO a +> ==> StateT (s -> IO (a,s)) +> +> type StateWithErr s a = StateT s Maybe a +> ==> StateT (s -> Maybe (a,s)) + +-} + +{- $counting + +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998: + +> tick :: State Int Int +> tick = do n <- get +> put (n+1) +> return n + +Add one to the given number using the state monad: + +> plusOne :: Int -> Int +> plusOne n = execState tick n + +A contrived addition example. Works only with positive numbers: + +> plus :: Int -> Int -> Int +> plus n x = execState (sequence $ replicate n tick) x + +-} + +{- $labelling + +An example from /The Craft of Functional Programming/, Simon +Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>), +Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +tree of integers in which the original elements are replaced by +natural numbers, starting from 0. The same element has to be +replaced by the same number at every occurrence, and when we meet +an as-yet-unvisited element we have to find a \'new\' number to match +it with:\" + +> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +> type Table a = [a] + +> 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 +> numberNode :: Eq a => a -> State (Table a) Int +> 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: + +> numTree :: (Eq a) => Tree a -> Tree Int +> numTree t = evalState (numberTree t) [] + +> 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 + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs new file mode 100644 index 0000000000..f45f4d2768 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer +-- 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 +-- +-- The WriterT monad transformer. +-- 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 ( + module Control.Monad.Trans.Writer.Lazy + ) where + +import Control.Monad.Trans.Writer.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs new file mode 100644 index 0000000000..28951016cf --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# 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 + +-- --------------------------------------------------------------------------- +-- | 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'. +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 '>>=' +-- combines the outputs of the subcomputations using 'mappend'. + +newtype WriterT w m a = WriterT { unWriterT :: w -> m (a, w) } + +-- | 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. +-- This version rolls back to the original state on entering the +-- 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. +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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs new file mode 100644 index 0000000000..d12b0e7d58 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer.Lazy +-- 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 +-- +-- The lazy '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 lazily; for a constant-space version +-- with almost the same interface, see "Control.Monad.Trans.Writer.CPS". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer.Lazy ( + -- * The Writer monad + Writer, + writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + -- * Writer operations + tell, + listen, + listens, + pass, + censor, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +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 +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (null, length) + +-- --------------------------------------------------------------------------- +-- | 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'. +type Writer w = WriterT w Identity + +-- | Construct a writer computation from a (result, output) pair. +-- (The inverse of 'runWriter'.) +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)@ +mapWriter :: ((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 @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + +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 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 :: (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 +#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 :: (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 :: (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 :: (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 :: (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)@ +-- +-- * @'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) => 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))) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +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/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs new file mode 100644 index 0000000000..f39862c020 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer.Strict +-- 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 +-- +-- 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; 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 ( + -- * The Writer monad + Writer, + writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + -- * Writer operations + tell, + listen, + listens, + pass, + censor, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +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 +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (null, length) + +-- --------------------------------------------------------------------------- +-- | 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'. +type Writer w = WriterT w Identity + +-- | Construct a writer computation from a (result, output) pair. +-- (The inverse of 'runWriter'.) +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)@ +mapWriter :: ((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 @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + +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 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 :: (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 +#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 :: (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 :: (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 :: (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 :: (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)@ +-- +-- * @'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) => 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))) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +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 #-} |