#if __GLASGOW_HASKELL__ >= 702
#endif
#if __GLASGOW_HASKELL__ >= 710
#endif
module Control.Monad.Trans.Writer.CPS (
Writer,
writer,
runWriter,
execWriter,
mapWriter,
WriterT,
runWriterT,
execWriterT,
mapWriterT,
tell,
listen,
listens,
pass,
censor
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Functor.Identity
import Data.Monoid
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
type Writer w = WriterT w Identity
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)
runWriter :: Monoid w => Writer w a -> (a, w)
runWriter = runIdentity . runWriterT
execWriter :: Monoid w => Writer w a -> w
execWriter = runIdentity . execWriterT
mapWriter :: (Monoid w, Monoid w') => ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter f = mapWriterT (Identity . f . runIdentity)
newtype WriterT w m a = WriterT { unWriterT :: w -> m (a, w) }
runWriterT :: Monoid w => WriterT w m a -> m (a, w)
runWriterT m = unWriterT m mempty
execWriterT :: (Monad m, Monoid w) => WriterT w m a -> m w
execWriterT m = do
(_, w) <- runWriterT m
return w
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)
instance Functor m => Functor (WriterT w m) where
fmap f m = WriterT $ \w -> (\(a, w) -> (f a, w)) <$> unWriterT m w
instance (Functor m, Monad m) => Applicative (WriterT w m) where
pure a = WriterT $ \w -> return (a, w)
WriterT mf <*> WriterT mx = WriterT $ \w -> do
(f, w') <- mf w
(x, w'') <- mx w'
return (f x, w'')
instance (Functor m, MonadPlus m) => Alternative (WriterT w m) where
empty = WriterT $ const mzero
WriterT m <|> WriterT n = WriterT $ \w -> m w `mplus` n w
instance Monad m => Monad (WriterT w m) where
#if !(MIN_VERSION_base(4,8,0))
return a = WriterT $ \w -> return (a, w)
#endif
m >>= k = WriterT $ \w -> do
(a, w') <- unWriterT m w
unWriterT (k a) w'
fail msg = WriterT $ \_ -> fail msg
#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail m => Fail.MonadFail (WriterT w m) where
fail msg = WriterT $ \_ -> Fail.fail msg
#endif
instance (Functor m, MonadPlus m) => MonadPlus (WriterT w m) where
mzero = empty
mplus = (<|>)
instance MonadFix m => MonadFix (WriterT w m) where
mfix f = WriterT $ \w -> mfix $ \ ~(a, _) -> unWriterT (f a) w
instance MonadTrans (WriterT w) where
lift m = WriterT $ \w -> do
a <- m
return (a, w)
instance MonadIO m => MonadIO (WriterT w m) where
liftIO = lift . liftIO
tell :: (Monoid w, Monad m) => w -> WriterT w m ()
tell w = writer ((), w)
listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w)
listen = listens id
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)
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)
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)