Control/Monad/Writer.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Monad.Writer
   4 -- Copyright   :  (c) Andy Gill 2001,
   5 --                (c) Oregon Graduate Institute of Science and Technology, 2001
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  non-portable ( mulit-param classes, functional dependencies )
  11 --
  12 -- The MonadWriter class.
  13 --
  14 --        Inspired by the paper
  15 --        /Functional Programming with Overloading and
  16 --            Higher-Order Polymorphism/,
  17 --          Mark P Jones (<http://www.cse.ogi.edu/~mpj/>)
  18 --                Advanced School of Functional Programming, 1995.
  19 -----------------------------------------------------------------------------
  20
  21 module Control.Monad.Writer (
  22         MonadWriter(..),
  23         listens,
  24         censor,
  25         Writer(..),
  26         execWriter,
  27         mapWriter,
  28         WriterT(..),
  29         execWriterT,
  30         mapWriterT,
  31         module Control.Monad,
  32         module Control.Monad.Fix,
  33         module Control.Monad.Trans,
  34         module Data.Monoid,
  35   ) where
  36
  37 import Prelude
  38
  39 import Control.Monad
  40 import Control.Monad.Fix
  41 import Control.Monad.Trans
  42 import Control.Monad.Reader
  43 import Data.Monoid
  44
  45 -- ---------------------------------------------------------------------------
  46 -- MonadWriter class
  47 --
  48 -- tell is like tell on the MUD's it shouts to monad
  49 -- what you want to be heard. The monad carries this 'packet'
  50 -- upwards, merging it if needed (hence the Monoid requirement)}
  51 --
  52 -- listen listens to a monad acting, and returns what the monad "said".
  53 --
  54 -- pass lets you provide a writer transformer which changes internals of
  55 -- the written object.
  56
  57 class (Monoid w, Monad m) => MonadWriter w m | m -> w where
  58         tell   :: w -> m ()
  59         listen :: m a -> m (a, w)
  60         pass   :: m (a, w -> w) -> m a
  61
  62 listens :: (MonadWriter w m) => (w -> w) -> m a -> m (a, w)
  63 listens f m = do
  64         (a, w) <- listen m
  65         return (a, f w)
  66
  67 censor :: (MonadWriter w m) => (w -> w) -> m a -> m a
  68 censor f m = pass $ do
  69         a <- m
  70         return (a, f)
  71
  72 -- ---------------------------------------------------------------------------
  73 -- Our parameterizable writer monad
  74
  75 newtype Writer w a = Writer { runWriter :: (a, w) }
  76
  77
  78 instance Functor (Writer w) where
  79         fmap f m = Writer $ let (a, w) = runWriter m in (f a, w)
  80
  81 instance (Monoid w) => Monad (Writer w) where
  82         return a = Writer (a, mempty)
  83         m >>= k  = Writer $ let
  84                 (a, w)  = runWriter m
  85                 (b, w') = runWriter (k a)
  86                 in (b, w `mappend` w')
  87
  88 instance (Monoid w) => MonadFix (Writer w) where
  89         mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w)
  90
  91 instance (Monoid w) => MonadWriter w (Writer w) where
  92         tell   w = Writer ((), w)
  93         listen m = Writer $ let (a, w) = runWriter m in ((a, w), w)
  94         pass   m = Writer $ let ((a, f), w) = runWriter m in (a, f w)
  95
  96
  97 execWriter :: Writer w a -> w
  98 execWriter m = snd (runWriter m)
  99
 100 mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
 101 mapWriter f m = Writer $ f (runWriter m)
 102
 103 -- ---------------------------------------------------------------------------
 104 -- Our parameterizable writer monad, with an inner monad
 105
 106 newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
 107
 108
 109 instance (Monad m) => Functor (WriterT w m) where
 110         fmap f m = WriterT $ do
 111                 (a, w) <- runWriterT m
 112                 return (f a, w)
 113
 114 instance (Monoid w, Monad m) => Monad (WriterT w m) where
 115         return a = WriterT $ return (a, mempty)
 116         m >>= k  = WriterT $ do
 117                 (a, w)  <- runWriterT m
 118                 (b, w') <- runWriterT (k a)
 119                 return (b, w `mappend` w')
 120         fail msg = WriterT $ fail msg
 121
 122 instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
 123         mzero       = WriterT mzero
 124         m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n
 125
 126 instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
 127         mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)
 128
 129 instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
 130         tell   w = WriterT $ return ((), w)
 131         listen m = WriterT $ do
 132                 (a, w) <- runWriterT m
 133                 return ((a, w), w)
 134         pass   m = WriterT $ do
 135                 ((a, f), w) <- runWriterT m
 136                 return (a, f w)
 137
 138 instance (Monoid w) => MonadTrans (WriterT w) where
 139         lift m = WriterT $ do
 140                 a <- m
 141                 return (a, mempty)
 142
 143 instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
 144         liftIO = lift . liftIO
 145
 146 instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
 147         ask       = lift ask
 148         local f m = WriterT $ local f (runWriterT m)
 149
 150
 151 execWriterT :: Monad m => WriterT w m a -> m w
 152 execWriterT m = do
 153         (_, w) <- runWriterT m
 154         return w
 155
 156 mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
 157 mapWriterT f m = WriterT $ f (runWriterT m)
 158
 159 -- ---------------------------------------------------------------------------
 160 -- MonadWriter instances for other monad transformers
 161
 162 instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where
 163         tell     = lift . tell
 164         listen m = ReaderT $ \w -> listen (runReaderT m w)
 165         pass   m = ReaderT $ \w -> pass   (runReaderT m w)