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         runWriter,
  27         execWriter,
  28         mapWriter,
  29         WriterT(..),
  30         runWriterT,
  31         execWriterT,
  32         mapWriterT,
  33         module Control.Monad,
  34         module Control.Monad.Monoid,
  35         module Control.Monad.Fix,
  36         module Control.Monad.Trans,
  37   ) where
  38
  39 import Prelude
  40
  41 import Control.Monad
  42 import Control.Monad.Monoid
  43 import Control.Monad.Fix
  44 import Control.Monad.Trans
  45 import Control.Monad.Reader
  46
  47 -- ---------------------------------------------------------------------------
  48 -- MonadWriter class
  49 --
  50 -- tell is like tell on the MUD's it shouts to monad
  51 -- what you want to be heard. The monad carries this 'packet'
  52 -- upwards, merging it if needed (hence the Monoid requirement)}
  53 --
  54 -- listen listens to a monad acting, and returns what the monad "said".
  55 --
  56 -- pass lets you provide a writer transformer which changes internals of
  57 -- the written object.
  58
  59 class (Monoid w, Monad m) => MonadWriter w m | m -> w where
  60         tell   :: w -> m ()
  61         listen :: m a -> m (a, w)
  62         pass   :: m (a, w -> w) -> m a
  63
  64 listens :: (MonadWriter w m) => (w -> w) -> m a -> m (a, w)
  65 listens f m = do
  66         (a, w) <- listen m
  67         return (a, f w)
  68
  69 censor :: (MonadWriter w m) => (w -> w) -> m a -> m a
  70 censor f m = pass $ do
  71         a <- m
  72         return (a, f)
  73
  74 -- ---------------------------------------------------------------------------
  75 -- Our parameterizable writer monad
  76
  77 newtype Writer w a = Writer { runWriter :: (a, w) }
  78
  79
  80 instance Functor (Writer w) where
  81         fmap f m = Writer $ let (a, w) = runWriter m in (f a, w)
  82
  83 instance (Monoid w) => Monad (Writer w) where
  84         return a = Writer (a, mempty)
  85         m >>= k  = Writer $ let
  86                 (a, w)  = runWriter m
  87                 (b, w') = runWriter (k a)
  88                 in (b, w `mappend` w')
  89
  90 instance (Monoid w) => MonadFix (Writer w) where
  91         mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w)
  92
  93 instance (Monoid w) => MonadWriter w (Writer w) where
  94         tell   w = Writer ((), w)
  95         listen m = Writer $ let (a, w) = runWriter m in ((a, w), w)
  96         pass   m = Writer $ let ((a, f), w) = runWriter m in (a, f w)
  97
  98
  99 execWriter :: Writer w a -> w
 100 execWriter m = snd (runWriter m)
 101
 102 mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
 103 mapWriter f m = Writer $ f (runWriter m)
 104
 105 -- ---------------------------------------------------------------------------
 106 -- Our parameterizable writer monad, with an inner monad
 107
 108 newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
 109
 110
 111 instance (Monad m) => Functor (WriterT w m) where
 112         fmap f m = WriterT $ do
 113                 (a, w) <- runWriterT m
 114                 return (f a, w)
 115
 116 instance (Monoid w, Monad m) => Monad (WriterT w m) where
 117         return a = WriterT $ return (a, mempty)
 118         m >>= k  = WriterT $ do
 119                 (a, w)  <- runWriterT m
 120                 (b, w') <- runWriterT (k a)
 121                 return (b, w `mappend` w')
 122         fail msg = WriterT $ fail msg
 123
 124 instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
 125         mzero       = WriterT mzero
 126         m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n
 127
 128 instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
 129         mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)
 130
 131 instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
 132         tell   w = WriterT $ return ((), w)
 133         listen m = WriterT $ do
 134                 (a, w) <- runWriterT m
 135                 return ((a, w), w)
 136         pass   m = WriterT $ do
 137                 ((a, f), w) <- runWriterT m
 138                 return (a, f w)
 139
 140 instance (Monoid w) => MonadTrans (WriterT w) where
 141         lift m = WriterT $ do
 142                 a <- m
 143                 return (a, mempty)
 144
 145 instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
 146         liftIO = lift . liftIO
 147
 148 instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
 149         ask       = lift ask
 150         local f m = WriterT $ local f (runWriterT m)
 151
 152
 153 execWriterT :: Monad m => WriterT w m a -> m w
 154 execWriterT m = do
 155         (_, w) <- runWriterT m
 156         return w
 157
 158 mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
 159 mapWriterT f m = WriterT $ f (runWriterT m)
 160
 161 -- ---------------------------------------------------------------------------
 162 -- MonadWriter instances for other monad transformers
 163
 164 instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where
 165         tell     = lift . tell
 166         listen m = ReaderT $ \w -> listen (runReaderT m w)
 167         pass   m = ReaderT $ \w -> pass   (runReaderT m w)