1 files changed, 292 insertions, 0 deletions
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 #-}