Control/Monad/X/WriterT.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 (multi-param classes, functional dependencies)
  11 --
  12 -- The implementation of the writer transformer.
  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.X.WriterT (
  22         WriterT,
  23         runWriter,
  24         runWriterT,
  25         execWriterT,
  26         mapWriterT,
  27         module T,
  28         module Monoid,
  29   ) where
  30
  31 import Prelude(Functor(..),Monad(..),fst,snd,(.))
  32 import Control.Monad(liftM,MonadPlus(..))
  33
  34 import Data.Monoid as Monoid (Monoid(..))
  35
  36 import Control.Monad.X.Trans as T
  37 import Control.Monad.X.Utils
  38 import Control.Monad.X.Types(WriterT(..))
  39
  40
  41 instance (Monoid w) => MonadTrans (WriterT w) where
  42   lift m        = W (liftM (\a -> (a,mempty)) m)
  43
  44 instance (Monoid w, HasBaseMonad m n) => HasBaseMonad (WriterT w m) n where
  45   inBase        = inBase'
  46
  47 instance (Monoid w, Monad m) => Functor (WriterT w m) where
  48   fmap          = liftM
  49
  50 instance (Monoid w, Monad m) => Monad (WriterT w m) where
  51   return        = return'
  52   m >>= f       = W (do (a, w)  <- unW m
  53                         (b, w') <- unW (f a)
  54                         return (b, w `mappend` w'))
  55   fail          = fail'
  56
  57
  58 runWriter       :: WriterT w m a -> m (a,w)
  59 runWriter       = unW
  60
  61 runWriterT      :: WriterT w m a -> m (a,w)
  62 runWriterT      = unW
  63
  64 execWriterT     :: Monad m => WriterT w m a -> m w
  65 execWriterT m   = liftM snd (unW m)
  66
  67 mapWriterT      :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
  68 mapWriterT f m  = W (f (unW m))
  69
  70
  71 instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
  72   ask           = ask'
  73   local         = local' mapWriterT
  74
  75 -- different from before, listen produces no output
  76 instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
  77   tell w        = W (return ((), w))
  78   listen        = mapWriterT (liftM (\(a,w) -> ((a,w),mempty)))
  79
  80 instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
  81   get           = get'
  82   put           = put'
  83
  84 instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where
  85   throwError    = throwError'
  86   catchError    = catchError1' W unW
  87
  88 instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
  89   mzero         = mzero'
  90   mplus         = mplus1' W unW
  91
  92 -- 'findAll' does not produce output
  93 -- if interested in the output use 'listen' before calling 'findAll'.
  94 instance (Monoid w, MonadNondet m) => MonadNondet (WriterT w m) where
  95   findAll       = mapWriterT (liftM (\xs -> (fmap fst xs, mempty)) . findAll)
  96   commit        = mapWriterT commit
  97
  98 instance (Monoid w, MonadResume m) => MonadResume (WriterT w m) where
  99   delay         = mapWriterT delay
 100   force         = mapWriterT force
 101
 102 -- jumping undoes the output
 103 instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where
 104   callCC        = callCC1' W unW (\a -> (a,mempty))
 105
 106