#if __GLASGOW_HASKELL__ >= 702
#endif
#if __GLASGOW_HASKELL__ >= 710
#endif
module Control.Monad.Trans.Accum (
Accum,
accum,
runAccum,
execAccum,
evalAccum,
mapAccum,
AccumT(AccumT),
runAccumT,
execAccumT,
evalAccumT,
mapAccumT,
look,
looks,
add,
liftCallCC,
liftCallCC',
liftCatch,
liftListen,
liftPass,
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
type Accum w = AccumT w Identity
accum :: (Monad m) => (w -> (a, w)) -> AccumT w m a
accum f = AccumT $ \ w -> return (f w)
runAccum :: Accum w a -> w -> (a, w)
runAccum m = runIdentity . runAccumT m
execAccum :: Accum w a -> w -> w
execAccum m w = snd (runAccum m w)
evalAccum :: (Monoid w) => Accum w a -> w -> a
evalAccum m w = fst (runAccum m w)
mapAccum :: ((a, w) -> (b, w)) -> Accum w a -> Accum w b
mapAccum f = mapAccumT (Identity . f . runIdentity)
newtype AccumT w m a = AccumT (w -> m (a, w))
runAccumT :: AccumT w m a -> w -> m (a, w)
runAccumT (AccumT f) = f
execAccumT :: (Monad m) => AccumT w m a -> w -> m w
execAccumT m w = do
~(_, w') <- runAccumT m w
return w'
evalAccumT :: (Monad m, Monoid w) => AccumT w m a -> w -> m a
evalAccumT m w = do
~(a, _) <- runAccumT m w
return a
mapAccumT :: (m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b
mapAccumT f m = AccumT (f . runAccumT m)
instance (Functor m) => Functor (AccumT w m) where
fmap f = mapAccumT $ fmap $ \ ~(a, w) -> (f a, w)
instance (Monoid w, Functor m, Monad m) => Applicative (AccumT w m) where
pure a = AccumT $ const $ return (a, mempty)
mf <*> mv = AccumT $ \ w -> do
~(f, w') <- runAccumT mf w
~(v, w'') <- runAccumT mv (w `mappend` w')
return (f v, w' `mappend` w'')
instance (Monoid w, Functor m, MonadPlus m) => Alternative (AccumT w m) where
empty = AccumT $ const mzero
m <|> n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w
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)
#endif
m >>= k = AccumT $ \ w -> do
~(a, w') <- runAccumT m w
~(b, w'') <- runAccumT (k a) (w `mappend` w')
return (b, w' `mappend` w'')
fail msg = AccumT $ const (fail msg)
#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)
#endif
instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where
mzero = AccumT $ const mzero
m `mplus` n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w
instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where
mfix m = AccumT $ \ w -> mfix $ \ ~(a, _) -> runAccumT (m a) w
instance (Monoid w) => MonadTrans (AccumT w) where
lift m = AccumT $ const $ do
a <- m
return (a, mempty)
instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where
liftIO = lift . liftIO
look :: (Monoid w, Monad m) => AccumT w m w
look = AccumT $ \ w -> return (w, mempty)
looks :: (Monoid w, Monad m) => (w -> a) -> AccumT w m a
looks f = AccumT $ \ w -> return (f w, mempty)
add :: (Monad m) => w -> AccumT w m ()
add w = accum $ const ((), w)
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
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
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
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')
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)
readerToAccumT :: (Functor m, Monoid w) => ReaderT w m a -> AccumT w m a
readerToAccumT (ReaderT f) = AccumT $ \ w -> fmap (\ a -> (a, mempty)) (f w)
writerToAccumT :: WriterT w m a -> AccumT w m a
writerToAccumT (WriterT m) = AccumT $ const $ m
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)