7f7f98bb4ba30693fb6d6f83cd6bd2b5299c8663
[packages/random.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 ( mulit-param classes, functional dependencies )
11 --
12 -- Declaration of the MonadRWS class.
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.RWS (
22 RWS(..),
23 runRWS,
24 evalRWS,
25 execRWS,
26 mapRWS,
27 withRWS,
28 RWST(..),
29 runRWST,
30 evalRWST,
31 execRWST,
32 mapRWST,
33 withRWST,
34 module Control.Monad,
35 module Control.Monad.Fix,
36 module Control.Monad.Trans,
37 module Control.Monad.Reader,
38 module Control.Monad.Writer,
39 module Control.Monad.State,
40 ) where
41
42 import Prelude
43
44 import Control.Monad
45 import Control.Monad.Monoid
46 import Control.Monad.Fix
47 import Control.Monad.Trans
48 import Control.Monad.Reader
49 import Control.Monad.Writer
50 import Control.Monad.State
51
52
53 newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
54
55 instance Functor (RWS r w s) where
56 fmap f m = RWS $ \r s -> let
57 (a, s', w) = runRWS m r s
58 in (f a, s', w)
59
60 instance (Monoid w) => Monad (RWS r w s) where
61 return a = RWS $ \_ s -> (a, s, mempty)
62 m >>= k = RWS $ \r s -> let
63 (a, s', w) = runRWS m r s
64 (b, s'', w') = runRWS (k a) r s'
65 in (b, s'', w `mappend` w')
66
67 instance (Monoid w) => MonadFix (RWS r w s) where
68 mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
69
70 instance (Monoid w) => MonadReader r (RWS r w s) where
71 ask = RWS $ \r s -> (r, s, mempty)
72 local f m = RWS $ \r s -> runRWS m (f r) s
73
74 instance (Monoid w) => MonadWriter w (RWS r w s) where
75 tell w = RWS $ \_ s -> ((), s, w)
76 listen m = RWS $ \r s -> let
77 (a, s', w) = runRWS m r s
78 in ((a, w), s', w)
79 pass m = RWS $ \r s -> let
80 ((a, f), s', w) = runRWS m r s
81 in (a, s', f w)
82
83 instance (Monoid w) => MonadState s (RWS r w s) where
84 get = RWS $ \_ s -> (s, s, mempty)
85 put s = RWS $ \_ _ -> ((), s, mempty)
86
87
88 evalRWS :: RWS r w s a -> r -> s -> (a, w)
89 evalRWS m r s = let
90 (a, _, w) = runRWS m r s
91 in (a, w)
92
93 execRWS :: RWS r w s a -> r -> s -> (s, w)
94 execRWS m r s = let
95 (_, s', w) = runRWS m r s
96 in (s', w)
97
98 mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
99 mapRWS f m = RWS $ \r s -> f (runRWS m r s)
100
101 withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
102 withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
103
104
105 newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
106
107 instance (Monad m) => Functor (RWST r w s m) where
108 fmap f m = RWST $ \r s -> do
109 (a, s', w) <- runRWST m r s
110 return (f a, s', w)
111
112 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
113 return a = RWST $ \_ s -> return (a, s, mempty)
114 m >>= k = RWST $ \r s -> do
115 (a, s', w) <- runRWST m r s
116 (b, s'',w') <- runRWST (k a) r s'
117 return (b, s'', w `mappend` w')
118 fail msg = RWST $ \_ _ -> fail msg
119
120 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
121 mzero = RWST $ \_ _ -> mzero
122 m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
123
124 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
125 mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
126
127 instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
128 ask = RWST $ \r s -> return (r, s, mempty)
129 local f m = RWST $ \r s -> runRWST m (f r) s
130
131 instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
132 tell w = RWST $ \_ s -> return ((),s,w)
133 listen m = RWST $ \r s -> do
134 (a, s', w) <- runRWST m r s
135 return ((a, w), s', w)
136 pass m = RWST $ \r s -> do
137 ((a, f), s', w) <- runRWST m r s
138 return (a, s', f w)
139
140 instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
141 get = RWST $ \_ s -> return (s, s, mempty)
142 put s = RWST $ \_ _ -> return ((), s, mempty)
143
144 instance (Monoid w) => MonadTrans (RWST r w s) where
145 lift m = RWST $ \_ s -> do
146 a <- m
147 return (a, s, mempty)
148
149 instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
150 liftIO = lift . liftIO
151
152
153 evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
154 evalRWST m r s = do
155 (a, _, w) <- runRWST m r s
156 return (a, w)
157
158 execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
159 execRWST m r s = do
160 (_, s', w) <- runRWST m r s
161 return (s', w)
162
163 mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
164 mapRWST f m = RWST $ \r s -> f (runRWST m r s)
165
166 withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
167 withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)