[project @ 2002-04-24 16:31:37 by simonmar]
[packages/base.git] / Control / Monad / RWS.hs
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : Control.Monad.RWS
4 -- Copyright : (c) Andy Gill 2001,
5 -- (c) Oregon Graduate Institute of Science and Technology, 2001
6 -- License : BSD-style (see the file libraries/core/LICENSE)
7 --
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable ( requires mulit-parameter type classes,
11 -- requires functional dependencies )
12 --
13 -- $Id: RWS.hs,v 1.2 2002/04/24 16:31:38 simonmar Exp $
14 --
15 -- Declaration of the MonadRWS class.
16 --
17 -- Inspired by the paper
18 -- \em{Functional Programming with Overloading and
19 -- Higher-Order Polymorphism},
20 -- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
21 -- Advanced School of Functional Programming, 1995.}
22 -----------------------------------------------------------------------------
23
24 module Control.Monad.RWS (
25 RWS(..),
26 runRWS,
27 evalRWS,
28 execRWS,
29 mapRWS,
30 withRWS,
31 RWST(..),
32 runRWST,
33 evalRWST,
34 execRWST,
35 mapRWST,
36 withRWST,
37 module Control.Monad,
38 module Control.Monad.Fix,
39 module Control.Monad.Trans,
40 module Control.Monad.Reader,
41 module Control.Monad.Writer,
42 module Control.Monad.State,
43 ) where
44
45 import Prelude
46
47 import Control.Monad
48 import Control.Monad.Monoid
49 import Control.Monad.Fix
50 import Control.Monad.Trans
51 import Control.Monad.Reader
52 import Control.Monad.Writer
53 import Control.Monad.State
54
55
56 newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
57
58 instance Functor (RWS r w s) where
59 fmap f m = RWS $ \r s -> let
60 (a, s', w) = runRWS m r s
61 in (f a, s', w)
62
63 instance (Monoid w) => Monad (RWS r w s) where
64 return a = RWS $ \_ s -> (a, s, mempty)
65 m >>= k = RWS $ \r s -> let
66 (a, s', w) = runRWS m r s
67 (b, s'', w') = runRWS (k a) r s'
68 in (b, s'', w `mappend` w')
69
70 instance (Monoid w) => MonadFix (RWS r w s) where
71 mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
72
73 instance (Monoid w) => MonadReader r (RWS r w s) where
74 ask = RWS $ \r s -> (r, s, mempty)
75 local f m = RWS $ \r s -> runRWS m (f r) s
76
77 instance (Monoid w) => MonadWriter w (RWS r w s) where
78 tell w = RWS $ \_ s -> ((), s, w)
79 listen m = RWS $ \r s -> let
80 (a, s', w) = runRWS m r s
81 in ((a, w), s', w)
82 pass m = RWS $ \r s -> let
83 ((a, f), s', w) = runRWS m r s
84 in (a, s', f w)
85
86 instance (Monoid w) => MonadState s (RWS r w s) where
87 get = RWS $ \_ s -> (s, s, mempty)
88 put s = RWS $ \_ _ -> ((), s, mempty)
89
90
91 evalRWS :: RWS r w s a -> r -> s -> (a, w)
92 evalRWS m r s = let
93 (a, _, w) = runRWS m r s
94 in (a, w)
95
96 execRWS :: RWS r w s a -> r -> s -> (s, w)
97 execRWS m r s = let
98 (_, s', w) = runRWS m r s
99 in (s', w)
100
101 mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
102 mapRWS f m = RWS $ \r s -> f (runRWS m r s)
103
104 withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
105 withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
106
107
108 newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
109
110 instance (Monad m) => Functor (RWST r w s m) where
111 fmap f m = RWST $ \r s -> do
112 (a, s', w) <- runRWST m r s
113 return (f a, s', w)
114
115 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
116 return a = RWST $ \_ s -> return (a, s, mempty)
117 m >>= k = RWST $ \r s -> do
118 (a, s', w) <- runRWST m r s
119 (b, s'',w') <- runRWST (k a) r s'
120 return (b, s'', w `mappend` w')
121 fail msg = RWST $ \_ _ -> fail msg
122
123 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
124 mzero = RWST $ \_ _ -> mzero
125 m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
126
127 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
128 mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
129
130 instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
131 ask = RWST $ \r s -> return (r, s, mempty)
132 local f m = RWST $ \r s -> runRWST m (f r) s
133
134 instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
135 tell w = RWST $ \_ s -> return ((),s,w)
136 listen m = RWST $ \r s -> do
137 (a, s', w) <- runRWST m r s
138 return ((a, w), s', w)
139 pass m = RWST $ \r s -> do
140 ((a, f), s', w) <- runRWST m r s
141 return (a, s', f w)
142
143 instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
144 get = RWST $ \_ s -> return (s, s, mempty)
145 put s = RWST $ \_ _ -> return ((), s, mempty)
146
147 instance (Monoid w) => MonadTrans (RWST r w s) where
148 lift m = RWST $ \_ s -> do
149 a <- m
150 return (a, s, mempty)
151
152 instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
153 liftIO = lift . liftIO
154
155
156 evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
157 evalRWST m r s = do
158 (a, _, w) <- runRWST m r s
159 return (a, w)
160
161 execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
162 execRWST m r s = do
163 (_, s', w) <- runRWST m r s
164 return (s', w)
165
166 mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
167 mapRWST f m = RWST $ \r s -> f (runRWST m r s)
168
169 withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
170 withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)