{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE AutoDeriveTypeable #-}
#endif
module Control.Monad.Trans.Writer.CPS (
Writer,
writer,
runWriter,
execWriter,
mapWriter,
WriterT,
writerT,
runWriterT,
execWriterT,
mapWriterT,
tell,
listen,
listens,
pass,
censor,
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
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)
{-# INLINE writer #-}
runWriter :: (Monoid w) => Writer w a -> (a, w)
runWriter = runIdentity . runWriterT
{-# INLINE runWriter #-}
execWriter :: (Monoid w) => Writer w a -> w
execWriter = runIdentity . execWriterT
{-# INLINE execWriter #-}
mapWriter :: (Monoid w, Monoid w') =>
((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter f = mapWriterT (Identity . f . runIdentity)
{-# INLINE mapWriter #-}
newtype WriterT w m a = WriterT { unWriterT :: w -> m (a, w) }
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 #-}
runWriterT :: (Monoid w) => WriterT w m a -> m (a, w)
runWriterT m = unWriterT m mempty
{-# INLINE runWriterT #-}
execWriterT :: (Monad m, Monoid w) => WriterT w m a -> m w
execWriterT m = do
(_, w) <- runWriterT m
return w
{-# INLINE execWriterT #-}
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 :: (Monoid w, Monad m) => w -> WriterT w m ()
tell w = writer ((), w)
{-# INLINE tell #-}
listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w)
listen = listens id
{-# INLINE listen #-}
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 :: (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 :: (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 #-}
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 #-}
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 #-}