1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

module Control.Monad.Trans.Writer where

import Data.Functor.Identity     ( Identity (..), runIdentity )
import Control.Monad.IO.Class    ( MonadIO (..) )
import Control.Monad.Trans.Class ( MonadTrans (..) )

newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }

instance Functor m => Functor (WriterT w m) where
  fmap f m = WriterT $ fmap (\(x, w) -> (f x, w)) (runWriterT m)

instance (Applicative m, Monoid w) => Applicative (WriterT w m) where
  pure x = WriterT $ pure (x, mempty)
  mf <*> m = WriterT $ (\(f, w1) (x, w2) -> (f x, w1 `mappend` w2)) <$> runWriterT mf <*> runWriterT m

instance (Monad m, Monoid w) => Monad (WriterT w m) where
  return = pure
  m >>= f = WriterT $ do (x, w1) <- runWriterT m
                         (y, w2) <- runWriterT (f x)
                         return (y, w1 `mappend` w2)

instance (Alternative m, Monoid w) => Alternative (WriterT w m) where
  empty = WriterT empty
  x <|> y = WriterT $ runWriterT x <|> runWriterT y

instance Monoid w => MonadTrans (WriterT w) where
  lift m = WriterT $ (\x -> (x, mempty)) <$> m

instance (MonadFail m, Monoid w) => MonadFail (WriterT w m) where
  fail msg = lift (fail msg)

instance (MonadIO m, Monoid w) => MonadIO (WriterT w m) where
  liftIO = lift . liftIO

-- | Constructs a writer computation.
writer :: Monad m => (a, w) -> WriterT w m a
writer = WriterT . return

-- | Appends the given value.
tell :: Monad m => w -> WriterT w m ()
tell w = writer ((), w)

-- | Performs a computation and yields its output as part of the value.
listen :: Monad m => WriterT w m a -> WriterT w m (a, w)
listen m = WriterT $ (\(x, w) -> ((x, w), w)) <$> runWriterT m

-- | Extracts the output of a writer compuation.
execWriterT :: Monad m => WriterT w m a -> m w
execWriterT m = snd <$> runWriterT m

type Writer w = WriterT w Identity

-- | Runs a writer compuation.
runWriter :: Writer w a -> (a, w)
runWriter = runIdentity . runWriterT

-- | Extracts the output of a writer compuation.
execWriter :: Writer w a -> w
execWriter = snd . runWriter