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/base/LICENSE)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable ( mulit-param classes, functional dependencies )
12 -- Declaration of the MonadRWS class.
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 -----------------------------------------------------------------------------
21 module Control.Monad.RWS (
33 module Control.Monad.Fix,
34 module Control.Monad.Trans,
35 module Control.Monad.Reader,
36 module Control.Monad.Writer,
37 module Control.Monad.State,
43 import Control.Monad.Monoid
44 import Control.Monad.Fix
45 import Control.Monad.Trans
46 import Control.Monad.Reader
47 import Control.Monad.Writer
48 import Control.Monad.State
51 newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
53 instance Functor (RWS r w s) where
54 fmap f m = RWS $ \r s -> let
55 (a, s', w) = runRWS m r s
58 instance (Monoid w) => Monad (RWS r w s) where
59 return a = RWS $ \_ s -> (a, s, mempty)
60 m >>= k = RWS $ \r s -> let
61 (a, s', w) = runRWS m r s
62 (b, s'', w') = runRWS (k a) r s'
63 in (b, s'', w `mappend` w')
65 instance (Monoid w) => MonadFix (RWS r w s) where
66 mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
68 instance (Monoid w) => MonadReader r (RWS r w s) where
69 ask = RWS $ \r s -> (r, s, mempty)
70 local f m = RWS $ \r s -> runRWS m (f r) s
72 instance (Monoid w) => MonadWriter w (RWS r w s) where
73 tell w = RWS $ \_ s -> ((), s, w)
74 listen m = RWS $ \r s -> let
75 (a, s', w) = runRWS m r s
77 pass m = RWS $ \r s -> let
78 ((a, f), s', w) = runRWS m r s
81 instance (Monoid w) => MonadState s (RWS r w s) where
82 get = RWS $ \_ s -> (s, s, mempty)
83 put s = RWS $ \_ _ -> ((), s, mempty)
86 evalRWS :: RWS r w s a -> r -> s -> (a, w)
88 (a, _, w) = runRWS m r s
91 execRWS :: RWS r w s a -> r -> s -> (s, w)
93 (_, s', w) = runRWS m r s
96 mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
97 mapRWS f m = RWS $ \r s -> f (runRWS m r s)
99 withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
100 withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
103 newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
105 instance (Monad m) => Functor (RWST r w s m) where
106 fmap f m = RWST $ \r s -> do
107 (a, s', w) <- runRWST m r s
110 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
111 return a = RWST $ \_ s -> return (a, s, mempty)
112 m >>= k = RWST $ \r s -> do
113 (a, s', w) <- runRWST m r s
114 (b, s'',w') <- runRWST (k a) r s'
115 return (b, s'', w `mappend` w')
116 fail msg = RWST $ \_ _ -> fail msg
118 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
119 mzero = RWST $ \_ _ -> mzero
120 m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
122 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
123 mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
125 instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
126 ask = RWST $ \r s -> return (r, s, mempty)
127 local f m = RWST $ \r s -> runRWST m (f r) s
129 instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
130 tell w = RWST $ \_ s -> return ((),s,w)
131 listen m = RWST $ \r s -> do
132 (a, s', w) <- runRWST m r s
133 return ((a, w), s', w)
134 pass m = RWST $ \r s -> do
135 ((a, f), s', w) <- runRWST m r s
138 instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
139 get = RWST $ \_ s -> return (s, s, mempty)
140 put s = RWST $ \_ _ -> return ((), s, mempty)
142 instance (Monoid w) => MonadTrans (RWST r w s) where
143 lift m = RWST $ \_ s -> do
145 return (a, s, mempty)
147 instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
148 liftIO = lift . liftIO
151 evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
153 (a, _, w) <- runRWST m r s
156 execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
158 (_, s', w) <- runRWST m r s
161 mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
162 mapRWST f m = RWST $ \r s -> f (runRWST m r s)
164 withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
165 withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)