1 -----------------------------------------------------------------------------
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)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable ( requires mulit-parameter type classes,
11 -- requires functional dependencies )
13 -- $Id: RWS.hs,v 1.2 2002/04/24 16:31:38 simonmar Exp $
15 -- Declaration of the MonadRWS class.
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 -----------------------------------------------------------------------------
24 module Control.Monad.RWS (
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,
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
56 newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
58 instance Functor (RWS r w s) where
59 fmap f m = RWS $ \r s -> let
60 (a, s', w) = runRWS m r s
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')
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)
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
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
82 pass m = RWS $ \r s -> let
83 ((a, f), s', w) = runRWS m r s
86 instance (Monoid w) => MonadState s (RWS r w s) where
87 get = RWS $ \_ s -> (s, s, mempty)
88 put s = RWS $ \_ _ -> ((), s, mempty)
91 evalRWS :: RWS r w s a -> r -> s -> (a, w)
93 (a, _, w) = runRWS m r s
96 execRWS :: RWS r w s a -> r -> s -> (s, w)
98 (_, s', w) = runRWS m r s
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)
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)
108 newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
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
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
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
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
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
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
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)
147 instance (Monoid w) => MonadTrans (RWST r w s) where
148 lift m = RWST $ \_ s -> do
150 return (a, s, mempty)
152 instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
153 liftIO = lift . liftIO
156 evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
158 (a, _, w) <- runRWST m r s
161 execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
163 (_, s', w) <- runRWST m r s
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)
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)