{-# 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 :: forall (m :: * -> *) w a. Monad m => (w -> (a, w)) -> AccumT w m a
accum w -> (a, w)
f = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w -> (a, w) -> m (a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (w -> (a, w)
f w
w)
{-# INLINE accum #-}

-- | Unwrap an accumulation computation as a (result, output) pair.
-- (The inverse of 'accum'.)
runAccum :: Accum w a -> w -> (a, w)
runAccum :: forall w a. Accum w a -> w -> (a, w)
runAccum Accum w a
m = Identity (a, w) -> (a, w)
forall a. Identity a -> a
runIdentity (Identity (a, w) -> (a, w))
-> (w -> Identity (a, w)) -> w -> (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Accum w a -> w -> Identity (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT Accum w a
m
{-# INLINE runAccum #-}

-- | Extract the output from an accumulation computation.
--
-- * @'execAccum' m w = 'snd' ('runAccum' m w)@
execAccum :: Accum w a -> w -> w
execAccum :: forall w a. Accum w a -> w -> w
execAccum Accum w a
m w
w = (a, w) -> w
forall a b. (a, b) -> b
snd (Accum w a -> w -> (a, w)
forall w a. Accum w a -> w -> (a, w)
runAccum Accum w a
m w
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 :: forall w a. Monoid w => Accum w a -> w -> a
evalAccum Accum w a
m w
w = (a, w) -> a
forall a b. (a, b) -> a
fst (Accum w a -> w -> (a, w)
forall w a. Accum w a -> w -> (a, w)
runAccum Accum w a
m w
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 :: forall a w b. ((a, w) -> (b, w)) -> Accum w a -> Accum w b
mapAccum (a, w) -> (b, w)
f = (Identity (a, w) -> Identity (b, w))
-> AccumT w Identity a -> AccumT w Identity b
forall (m :: * -> *) a w (n :: * -> *) b.
(m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b
mapAccumT ((b, w) -> Identity (b, w)
forall a. a -> Identity a
Identity ((b, w) -> Identity (b, w))
-> (Identity (a, w) -> (b, w))
-> Identity (a, w)
-> Identity (b, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> (b, w)
f ((a, w) -> (b, w))
-> (Identity (a, w) -> (a, w)) -> Identity (a, w) -> (b, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (a, w) -> (a, w)
forall a. Identity a -> a
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 :: forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT (AccumT w -> m (a, w)
f) = w -> m (a, w)
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 :: forall (m :: * -> *) w a. Monad m => AccumT w m a -> w -> m w
execAccumT AccumT w m a
m w
w = do
    ~(a
_, w
w') <- AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
m w
w
    w -> m w
forall (m :: * -> *) a. Monad m => a -> m a
return w
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 :: forall (m :: * -> *) w a.
(Monad m, Monoid w) =>
AccumT w m a -> w -> m a
evalAccumT AccumT w m a
m w
w = do
    ~(a
a, w
_) <- AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
m w
w
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: forall (m :: * -> *) a w (n :: * -> *) b.
(m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b
mapAccumT m (a, w) -> n (b, w)
f AccumT w m a
m = (w -> n (b, w)) -> AccumT w n b
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT (m (a, w) -> n (b, w)
f (m (a, w) -> n (b, w)) -> (w -> m (a, w)) -> w -> n (b, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
m)
{-# INLINE mapAccumT #-}

instance (Functor m) => Functor (AccumT w m) where
    fmap :: forall a b. (a -> b) -> AccumT w m a -> AccumT w m b
fmap a -> b
f = (m (a, w) -> m (b, w)) -> AccumT w m a -> AccumT w m b
forall (m :: * -> *) a w (n :: * -> *) b.
(m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b
mapAccumT ((m (a, w) -> m (b, w)) -> AccumT w m a -> AccumT w m b)
-> (m (a, w) -> m (b, w)) -> AccumT w m a -> AccumT w m b
forall a b. (a -> b) -> a -> b
$ ((a, w) -> (b, w)) -> m (a, w) -> m (b, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, w) -> (b, w)) -> m (a, w) -> m (b, w))
-> ((a, w) -> (b, w)) -> m (a, w) -> m (b, w)
forall a b. (a -> b) -> a -> b
$ \ ~(a
a, w
w) -> (a -> b
f a
a, w
w)
    {-# INLINE fmap #-}

instance (Monoid w, Functor m, Monad m) => Applicative (AccumT w m) where
    pure :: forall a. a -> AccumT w m a
pure a
a  = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ m (a, w) -> w -> m (a, w)
forall a b. a -> b -> a
const (m (a, w) -> w -> m (a, w)) -> m (a, w) -> w -> m (a, w)
forall a b. (a -> b) -> a -> b
$ (a, w) -> m (a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, w
forall a. Monoid a => a
mempty)
    {-# INLINE pure #-}
    AccumT w m (a -> b)
mf <*> :: forall a b. AccumT w m (a -> b) -> AccumT w m a -> AccumT w m b
<*> AccumT w m a
mv = (w -> m (b, w)) -> AccumT w m b
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (b, w)) -> AccumT w m b)
-> (w -> m (b, w)) -> AccumT w m b
forall a b. (a -> b) -> a -> b
$ \ w
w -> do
      ~(a -> b
f, w
w')  <- AccumT w m (a -> b) -> w -> m (a -> b, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m (a -> b)
mf w
w
      ~(a
v, w
w'') <- AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
mv (w
w w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w')
      (b, w) -> m (b, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
v, w
w' w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w'')
    {-# INLINE (<*>) #-}

instance (Monoid w, Functor m, MonadPlus m) => Alternative (AccumT w m) where
    empty :: forall a. AccumT w m a
empty   = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ m (a, w) -> w -> m (a, w)
forall a b. a -> b -> a
const m (a, w)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    {-# INLINE empty #-}
    AccumT w m a
m <|> :: forall a. AccumT w m a -> AccumT w m a -> AccumT w m a
<|> AccumT w m a
n = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w -> AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
m w
w m (a, w) -> m (a, w) -> m (a, w)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
n w
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
    AccumT w m a
m >>= :: forall a b. AccumT w m a -> (a -> AccumT w m b) -> AccumT w m b
>>= a -> AccumT w m b
k  = (w -> m (b, w)) -> AccumT w m b
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (b, w)) -> AccumT w m b)
-> (w -> m (b, w)) -> AccumT w m b
forall a b. (a -> b) -> a -> b
$ \ w
w -> do
        ~(a
a, w
w')  <- AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
m w
w
        ~(b
b, w
w'') <- AccumT w m b -> w -> m (b, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT (a -> AccumT w m b
k a
a) (w
w w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w')
        (b, w) -> m (b, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, w
w' w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
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 :: forall a. String -> AccumT w m a
fail String
msg = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ m (a, w) -> w -> m (a, w)
forall a b. a -> b -> a
const (String -> m (a, w)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg)
    {-# INLINE fail #-}
#endif

instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where
    mzero :: forall a. AccumT w m a
mzero       = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ m (a, w) -> w -> m (a, w)
forall a b. a -> b -> a
const m (a, w)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    {-# INLINE mzero #-}
    AccumT w m a
m mplus :: forall a. AccumT w m a -> AccumT w m a -> AccumT w m a
`mplus` AccumT w m a
n = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w -> AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
m w
w m (a, w) -> m (a, w) -> m (a, w)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
n w
w
    {-# INLINE mplus #-}

instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where
    mfix :: forall a. (a -> AccumT w m a) -> AccumT w m a
mfix a -> AccumT w m a
m = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w -> ((a, w) -> m (a, w)) -> m (a, w)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (((a, w) -> m (a, w)) -> m (a, w))
-> ((a, w) -> m (a, w)) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ \ ~(a
a, w
_) -> AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT (a -> AccumT w m a
m a
a) w
w
    {-# INLINE mfix #-}

instance (Monoid w) => MonadTrans (AccumT w) where
    lift :: forall (m :: * -> *) a. Monad m => m a -> AccumT w m a
lift m a
m = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ m (a, w) -> w -> m (a, w)
forall a b. a -> b -> a
const (m (a, w) -> w -> m (a, w)) -> m (a, w) -> w -> m (a, w)
forall a b. (a -> b) -> a -> b
$ do
        a
a <- m a
m
        (a, w) -> m (a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, w
forall a. Monoid a => a
mempty)
    {-# INLINE lift #-}

instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where
    liftIO :: forall a. IO a -> AccumT w m a
liftIO = m a -> AccumT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> AccumT w m a) -> (IO a -> m a) -> IO a -> AccumT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    {-# INLINE liftIO #-}

-- | @'look'@ is an action that fetches all the previously accumulated output.
look :: (Monoid w, Monad m) => AccumT w m w
look :: forall w (m :: * -> *). (Monoid w, Monad m) => AccumT w m w
look = (w -> m (w, w)) -> AccumT w m w
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (w, w)) -> AccumT w m w)
-> (w -> m (w, w)) -> AccumT w m w
forall a b. (a -> b) -> a -> b
$ \ w
w -> (w, w) -> m (w, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (w
w, w
forall a. Monoid a => a
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 :: forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(w -> a) -> AccumT w m a
looks w -> a
f = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w -> (a, w) -> m (a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (w -> a
f w
w, w
forall a. Monoid a => a
mempty)

-- | @'add' w@ is an action that produces the output @w@.
add :: (Monad m) => w -> AccumT w m ()
add :: forall (m :: * -> *) w. Monad m => w -> AccumT w m ()
add w
w = (w -> ((), w)) -> AccumT w m ()
forall (m :: * -> *) w a. Monad m => (w -> (a, w)) -> AccumT w m a
accum ((w -> ((), w)) -> AccumT w m ())
-> (w -> ((), w)) -> AccumT w m ()
forall a b. (a -> b) -> a -> b
$ ((), w) -> w -> ((), w)
forall a b. a -> b -> a
const ((), w
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 :: forall (m :: * -> *) a w b.
CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b
liftCallCC CallCC m (a, w) (b, w)
callCC (a -> AccumT w m b) -> AccumT w m a
f = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w ->
    CallCC m (a, w) (b, w)
callCC CallCC m (a, w) (b, w) -> CallCC m (a, w) (b, w)
forall a b. (a -> b) -> a -> b
$ \ (a, w) -> m (b, w)
c ->
    AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT ((a -> AccumT w m b) -> AccumT w m a
f (\ a
a -> (w -> m (b, w)) -> AccumT w m b
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (b, w)) -> AccumT w m b)
-> (w -> m (b, w)) -> AccumT w m b
forall a b. (a -> b) -> a -> b
$ \ w
_ -> (a, w) -> m (b, w)
c (a
a, w
w))) 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' :: forall (m :: * -> *) a w b.
CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b
liftCallCC' CallCC m (a, w) (b, w)
callCC (a -> AccumT w m b) -> AccumT w m a
f = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
s ->
    CallCC m (a, w) (b, w)
callCC CallCC m (a, w) (b, w) -> CallCC m (a, w) (b, w)
forall a b. (a -> b) -> a -> b
$ \ (a, w) -> m (b, w)
c ->
    AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT ((a -> AccumT w m b) -> AccumT w m a
f (\ a
a -> (w -> m (b, w)) -> AccumT w m b
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (b, w)) -> AccumT w m b)
-> (w -> m (b, w)) -> AccumT w m b
forall a b. (a -> b) -> a -> b
$ \ w
s' -> (a, w) -> m (b, w)
c (a
a, w
s'))) w
s
{-# INLINE liftCallCC' #-}

-- | Lift a @catchE@ operation to the new monad.
liftCatch :: Catch e m (a, w) -> Catch e (AccumT w m) a
liftCatch :: forall e (m :: * -> *) a w.
Catch e m (a, w) -> Catch e (AccumT w m) a
liftCatch Catch e m (a, w)
catchE AccumT w m a
m e -> AccumT w m a
h =
    (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w -> AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w m a
m w
w Catch e m (a, w)
`catchE` \ e
e -> AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT (e -> AccumT w m a
h e
e) w
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 :: forall (m :: * -> *) w a s.
Monad m =>
Listen w m (a, s) -> Listen w (AccumT s m) a
liftListen Listen w m (a, s)
listen AccumT s m a
m = (s -> m ((a, w), s)) -> AccumT s m (a, w)
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((s -> m ((a, w), s)) -> AccumT s m (a, w))
-> (s -> m ((a, w), s)) -> AccumT s m (a, w)
forall a b. (a -> b) -> a -> b
$ \ s
s -> do
    ~((a
a, s
s'), w
w) <- Listen w m (a, s)
listen (AccumT s m a -> s -> m (a, s)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT s m a
m s
s)
    ((a, w), s) -> m ((a, w), s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a, w
w), s
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 :: forall (m :: * -> *) w a s.
Monad m =>
Pass w m (a, s) -> Pass w (AccumT s m) a
liftPass Pass w m (a, s)
pass AccumT s m (a, w -> w)
m = (s -> m (a, s)) -> AccumT s m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((s -> m (a, s)) -> AccumT s m a)
-> (s -> m (a, s)) -> AccumT s m a
forall a b. (a -> b) -> a -> b
$ \ s
s -> Pass w m (a, s)
pass Pass w m (a, s) -> Pass w m (a, s)
forall a b. (a -> b) -> a -> b
$ do
    ~((a
a, w -> w
f), s
s') <- AccumT s m (a, w -> w) -> s -> m ((a, w -> w), s)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT s m (a, w -> w)
m s
s
    ((a, s), w -> w) -> m ((a, s), w -> w)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a, s
s'), w -> w
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 :: forall (m :: * -> *) w a.
(Functor m, Monoid w) =>
ReaderT w m a -> AccumT w m a
readerToAccumT (ReaderT w -> m a
f) = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ \ w
w -> (a -> (a, w)) -> m a -> m (a, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ a
a -> (a
a, w
forall a. Monoid a => a
mempty)) (w -> m a
f w
w)
{-# INLINE readerToAccumT #-}

-- | Convert a writer computation into an accumulation computation.
writerToAccumT :: WriterT w m a -> AccumT w m a
writerToAccumT :: forall w (m :: * -> *) a. WriterT w m a -> AccumT w m a
writerToAccumT (WriterT m (a, w)
m) = (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (w -> m (a, w)) -> AccumT w m a
forall a b. (a -> b) -> a -> b
$ m (a, w) -> w -> m (a, w)
forall a b. a -> b -> a
const (m (a, w) -> w -> m (a, w)) -> m (a, w) -> w -> m (a, w)
forall a b. (a -> b) -> a -> b
$ m (a, w)
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 :: forall (m :: * -> *) s a.
(Functor m, Monoid s) =>
AccumT s m a -> StateT s m a
accumToStateT (AccumT s -> m (a, s)
f) =
    (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \ s
w -> ((a, s) -> (a, s)) -> m (a, s) -> m (a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ ~(a
a, s
w') -> (a
a, s
w s -> s -> s
forall a. Monoid a => a -> a -> a
`mappend` s
w')) (s -> m (a, s)
f s
w)
{-# INLINE accumToStateT #-}