[project @ 2003-06-04 14:52:09 by ralf]
[packages/old-time.git] / 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