module DeepControl.Monad.Writer (
MonadWriter(..),
listens, censor,
Writer(..), execWriter, mapWriter,
WriterT(..), execWriterT, mapWriterT, liftCatch,
WriterT2(..), execWriterT2, mapWriterT2,
WriterT3(..), execWriterT3, mapWriterT3,
) where
import DeepControl.Applicative
import DeepControl.Monad
import DeepControl.MonadTrans
import Control.Monad.Writer (MonadWriter(..))
import Control.Monad.Signatures
import Data.Monoid
listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b)
listens f m = do
(a, w) <- listen m
return (a, f w)
censor :: MonadWriter w m => (w -> w) -> m a -> m a
censor f m = pass $ do
a <- m
return (a, f)
newtype Writer w a = Writer { runWriter :: (a, w) }
instance Functor (Writer w) where
fmap f v = Writer $ (\(a, w) -> (f a, w)) $ (runWriter v)
instance (Monoid w) => Applicative (Writer w) where
pure a = Writer $ (a, mempty)
(<*>) = \(Writer (f, w)) (Writer (a, w')) ->
Writer (f a, w <> w')
instance (Monoid w) => Monad (Writer w) where
return = pure
mv >>= f =
mv >- \(Writer (a, w)) ->
(\(Writer (b, w')) -> Writer (b, w <> w')) $ f a
instance (Monoid w) => Monad2 (Writer w) where
mmv >>== f =
mmv >>= \(Writer (a, w)) ->
(\(Writer (b, w')) -> Writer (b, w <> w')) |$> f a
instance (Monoid w) => Monad3 (Writer w) where
mmv >>>== f =
mmv >>== \(Writer (a, w)) ->
(\(Writer (b, w')) -> Writer (b, w <> w')) |$>> f a
instance (Monoid w) => Monad4 (Writer w) where
mmv >>>>== f =
mmv >>>== \(Writer (a, w)) ->
(\(Writer (b, w')) -> Writer (b, w <> w')) |$>>> f a
instance (Monoid w) => Monad5 (Writer w) where
mmv >>>>>== f =
mmv >>>>== \(Writer (a, w)) ->
(\(Writer (b, w')) -> Writer (b, w <> w')) |$>>>> f a
instance (Monoid w) => MonadWriter w (Writer w) where
writer = Writer
tell w = writer ((), w)
listen m = Writer $
runWriter m >- \(a, w) ->
((a, w), w)
pass m = Writer $
runWriter m >- \((a, f), w) ->
(a, f w)
execWriter :: Writer w a -> w
execWriter m =
runWriter m >- \(_, w) ->
w
mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter f m = Writer $ f (runWriter m)
newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
instance (Monad m) => Functor (WriterT w m) where
fmap f v = WriterT $ (\(a, w) -> (f a, w)) |$> (runWriterT v)
instance (Monoid w, Monad m) => Applicative (WriterT w m) where
pure a = WriterT $ (*:) (a, mempty)
(<*>) = ap
instance (Monoid w, Monad m) => Monad (WriterT w m) where
return = pure
(WriterT v) >>= f = WriterT $
v >>= \(a, w) ->
runWriterT (f a) >>= \(a', w') ->
(*:) (a', w <> w')
instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
writer = WriterT . (*:)
tell w = writer $ ((), w)
listen m = WriterT $
runWriterT m >>= \(a, w) ->
(*:) ((a, w), w)
pass m = WriterT $
runWriterT m >>= \((a, f), w) ->
(*:) (a, f w)
instance (Monoid w) => MonadTrans (WriterT w) where
trans m = WriterT $
m >>= \a ->
(*:) (a, mempty)
instance (Monoid w, MonadIO m, Monad m) => MonadIO (WriterT w m) where
liftIO = trans . liftIO
execWriterT :: (Monad m) => WriterT w m a -> m w
execWriterT m =
runWriterT m >>= \(_, w) ->
(*:) w
mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT f m = WriterT $ f (runWriterT m)
liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a
liftCatch catchE m h =
WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e)
newtype WriterT2 w m1 m2 a = WriterT2 { runWriterT2 :: m1 (m2 (a, w)) }
instance (Monad m1, Monad2 m2) => Functor (WriterT2 w m1 m2) where
fmap f v = WriterT2 $ (\(a, w) -> (f a, w)) |$>> (runWriterT2 v)
instance (Monoid w, Monad m1, Monad2 m2) => Applicative (WriterT2 w m1 m2) where
pure a = WriterT2 $ (**:) (a, mempty)
(<*>) = ap
instance (Monoid w, Monad m1, Monad2 m2) => Monad (WriterT2 w m1 m2) where
return = pure
(WriterT2 v) >>= f = WriterT2 $
v >>== \(a, w) ->
runWriterT2 (f a) >>== \(a', w') ->
(**:) (a', w <> w')
instance (Monoid w, Monad m1, Monad2 m2) => MonadWriter w (WriterT2 w m1 m2) where
writer = WriterT2 . (**:)
tell w = writer $ ((), w)
listen m = WriterT2 $
runWriterT2 m >>== \(a, w) ->
(**:) ((a, w), w)
pass m = WriterT2 $
runWriterT2 m >>== \((a, f), w) ->
(**:) (a, f w)
instance (Monoid w) => MonadTrans2 (WriterT2 w) where
trans2 m = WriterT2 $
m >>== \a ->
(**:) (a, mempty)
instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (WriterT2 w m1 m2) where
liftIO = trans2 . (-*) . liftIO
execWriterT2 :: (Monad m1, Monad2 m2) => WriterT2 w m1 m2 a -> m1 (m2 w)
execWriterT2 m =
runWriterT2 m >>== \(_, w) ->
(**:) w
mapWriterT2 :: (m1 (m2 (a, w)) -> n1 (n2 (b, w'))) -> WriterT2 w m1 m2 a -> WriterT2 w' n1 n2 b
mapWriterT2 f m = WriterT2 $ f (runWriterT2 m)
newtype WriterT3 w m1 m2 m3 a = WriterT3 { runWriterT3 :: m1 (m2 (m3 (a, w))) }
instance (Monad m1, Monad2 m2, Monad3 m3) => Functor (WriterT3 w m1 m2 m3) where
fmap f v = WriterT3 $ (\(a, w) -> (f a, w)) |$>>> (runWriterT3 v)
instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Applicative (WriterT3 w m1 m2 m3) where
pure a = WriterT3 $ (***:) (a, mempty)
(<*>) = ap
instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Monad (WriterT3 w m1 m2 m3) where
return = pure
(WriterT3 v) >>= f = WriterT3 $
v >>>== \(a, w) ->
runWriterT3 (f a) >>>== \(a', w') ->
(***:) (a', w <> w')
instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadWriter w (WriterT3 w m1 m2 m3) where
writer = WriterT3 . (***:)
tell w = writer $ ((), w)
listen m = WriterT3 $
runWriterT3 m >>>== \(a, w) ->
(***:) ((a, w), w)
pass m = WriterT3 $
runWriterT3 m >>>== \((a, f), w) ->
(***:) (a, f w)
instance (Monoid w) => MonadTrans3 (WriterT3 w) where
trans3 m = WriterT3 $
m >>>== \a ->
(***:) (a, mempty)
instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (WriterT3 w m1 m2 m3) where
liftIO = trans3 . (-**) . liftIO
execWriterT3 :: (Monad m1, Monad2 m2, Monad3 m3) => WriterT3 w m1 m2 m3 a -> m1 (m2 (m3 w))
execWriterT3 m =
runWriterT3 m >>>== \(_, w) ->
(***:) w
mapWriterT3 :: (m1 (m2 (m3 (a, w))) -> n1 (n2 (n3 (b, w')))) -> WriterT3 w m1 m2 m3 a -> WriterT3 w' n1 n2 n3 b
mapWriterT3 f m = WriterT3 $ f (runWriterT3 m)