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