a2f84dcc15e146ade70a03e0d55602af78d544a9
[packages/transformers.git] / Control / Monad / Trans / State / Lazy.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__ >= 702
3 {-# LANGUAGE Safe #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 710
6 {-# LANGUAGE AutoDeriveTypeable #-}
7 #endif
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Control.Monad.Trans.State.Lazy
11 -- Copyright : (c) Andy Gill 2001,
12 -- (c) Oregon Graduate Institute of Science and Technology, 2001
13 -- License : BSD-style (see the file LICENSE)
14 --
15 -- Maintainer : R.Paterson@city.ac.uk
16 -- Stability : experimental
17 -- Portability : portable
18 --
19 -- Lazy state monads, passing an updatable state through a computation.
20 -- See below for examples.
21 --
22 -- Some computations may not require the full power of state transformers:
23 --
24 -- * For a read-only state, see "Control.Monad.Trans.Reader".
25 --
26 -- * To accumulate a value without using it on the way, see
27 -- "Control.Monad.Trans.Writer".
28 --
29 -- In this version, sequencing of computations is lazy, so that for
30 -- example the following produces a usable result:
31 --
32 -- > evalState (sequence $ repeat $ do { n <- get; put (n*2); return n }) 1
33 --
34 -- For a strict version with the same interface, see
35 -- "Control.Monad.Trans.State.Strict".
36 -----------------------------------------------------------------------------
37
38 module Control.Monad.Trans.State.Lazy (
39 -- * The State monad
40 State,
41 state,
42 runState,
43 evalState,
44 execState,
45 mapState,
46 withState,
47 -- * The StateT monad transformer
48 StateT(..),
49 evalStateT,
50 execStateT,
51 mapStateT,
52 withStateT,
53 -- * State operations
54 get,
55 put,
56 modify,
57 modify',
58 gets,
59 -- * Lifting other operations
60 liftCallCC,
61 liftCallCC',
62 liftCatch,
63 liftListen,
64 liftPass,
65 -- * Examples
66 -- ** State monads
67 -- $examples
68
69 -- ** Counting
70 -- $counting
71
72 -- ** Labelling trees
73 -- $labelling
74 ) where
75
76 import Control.Monad.IO.Class
77 import Control.Monad.Signatures
78 import Control.Monad.Trans.Class
79 import Data.Functor.Identity
80
81 import Control.Applicative
82 import Control.Monad
83 #if MIN_VERSION_base(4,9,0)
84 import qualified Control.Monad.Fail as Fail
85 #endif
86 import Control.Monad.Fix
87
88 -- ---------------------------------------------------------------------------
89 -- | A state monad parameterized by the type @s@ of the state to carry.
90 --
91 -- The 'return' function leaves the state unchanged, while @>>=@ uses
92 -- the final state of the first computation as the initial state of
93 -- the second.
94 type State s = StateT s Identity
95
96 -- | Construct a state monad computation from a function.
97 -- (The inverse of 'runState'.)
98 state :: (Monad m)
99 => (s -> (a, s)) -- ^pure state transformer
100 -> StateT s m a -- ^equivalent state-passing computation
101 state f = StateT (return . f)
102 {-# INLINE state #-}
103
104 -- | Unwrap a state monad computation as a function.
105 -- (The inverse of 'state'.)
106 runState :: State s a -- ^state-passing computation to execute
107 -> s -- ^initial state
108 -> (a, s) -- ^return value and final state
109 runState m = runIdentity . runStateT m
110 {-# INLINE runState #-}
111
112 -- | Evaluate a state computation with the given initial state
113 -- and return the final value, discarding the final state.
114 --
115 -- * @'evalState' m s = 'fst' ('runState' m s)@
116 evalState :: State s a -- ^state-passing computation to execute
117 -> s -- ^initial value
118 -> a -- ^return value of the state computation
119 evalState m s = fst (runState m s)
120 {-# INLINE evalState #-}
121
122 -- | Evaluate a state computation with the given initial state
123 -- and return the final state, discarding the final value.
124 --
125 -- * @'execState' m s = 'snd' ('runState' m s)@
126 execState :: State s a -- ^state-passing computation to execute
127 -> s -- ^initial value
128 -> s -- ^final state
129 execState m s = snd (runState m s)
130 {-# INLINE execState #-}
131
132 -- | Map both the return value and final state of a computation using
133 -- the given function.
134 --
135 -- * @'runState' ('mapState' f m) = f . 'runState' m@
136 mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
137 mapState f = mapStateT (Identity . f . runIdentity)
138 {-# INLINE mapState #-}
139
140 -- | @'withState' f m@ executes action @m@ on a state modified by
141 -- applying @f@.
142 --
143 -- * @'withState' f m = 'modify' f >> m@
144 withState :: (s -> s) -> State s a -> State s a
145 withState = withStateT
146 {-# INLINE withState #-}
147
148 -- ---------------------------------------------------------------------------
149 -- | A state transformer monad parameterized by:
150 --
151 -- * @s@ - The state.
152 --
153 -- * @m@ - The inner monad.
154 --
155 -- The 'return' function leaves the state unchanged, while @>>=@ uses
156 -- the final state of the first computation as the initial state of
157 -- the second.
158 newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
159
160 -- | Evaluate a state computation with the given initial state
161 -- and return the final value, discarding the final state.
162 --
163 -- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@
164 evalStateT :: (Monad m) => StateT s m a -> s -> m a
165 evalStateT m s = do
166 ~(a, _) <- runStateT m s
167 return a
168 {-# INLINE evalStateT #-}
169
170 -- | Evaluate a state computation with the given initial state
171 -- and return the final state, discarding the final value.
172 --
173 -- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@
174 execStateT :: (Monad m) => StateT s m a -> s -> m s
175 execStateT m s = do
176 ~(_, s') <- runStateT m s
177 return s'
178 {-# INLINE execStateT #-}
179
180 -- | Map both the return value and final state of a computation using
181 -- the given function.
182 --
183 -- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@
184 mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
185 mapStateT f m = StateT $ f . runStateT m
186 {-# INLINE mapStateT #-}
187
188 -- | @'withStateT' f m@ executes action @m@ on a state modified by
189 -- applying @f@.
190 --
191 -- * @'withStateT' f m = 'modify' f >> m@
192 withStateT :: (s -> s) -> StateT s m a -> StateT s m a
193 withStateT f m = StateT $ runStateT m . f
194 {-# INLINE withStateT #-}
195
196 instance (Functor m) => Functor (StateT s m) where
197 fmap f m = StateT $ \ s ->
198 fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s
199 {-# INLINE fmap #-}
200
201 instance (Functor m, Monad m) => Applicative (StateT s m) where
202 pure a = StateT $ \ s -> return (a, s)
203 {-# INLINE pure #-}
204 StateT mf <*> StateT mx = StateT $ \ s -> do
205 ~(f, s') <- mf s
206 ~(x, s'') <- mx s'
207 return (f x, s'')
208 {-# INLINE (<*>) #-}
209
210 instance (Functor m, MonadPlus m) => Alternative (StateT s m) where
211 empty = StateT $ \ _ -> mzero
212 {-# INLINE empty #-}
213 StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s
214 {-# INLINE (<|>) #-}
215
216 instance (Monad m) => Monad (StateT s m) where
217 #if !(MIN_VERSION_base(4,8,0))
218 return a = StateT $ \ s -> return (a, s)
219 {-# INLINE return #-}
220 #endif
221 m >>= k = StateT $ \ s -> do
222 ~(a, s') <- runStateT m s
223 runStateT (k a) s'
224 {-# INLINE (>>=) #-}
225 fail str = StateT $ \ _ -> fail str
226 {-# INLINE fail #-}
227
228 #if MIN_VERSION_base(4,9,0)
229 instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where
230 fail str = StateT $ \ _ -> Fail.fail str
231 {-# INLINE fail #-}
232 #endif
233
234 instance (MonadPlus m) => MonadPlus (StateT s m) where
235 mzero = StateT $ \ _ -> mzero
236 {-# INLINE mzero #-}
237 StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s
238 {-# INLINE mplus #-}
239
240 instance (MonadFix m) => MonadFix (StateT s m) where
241 mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s
242 {-# INLINE mfix #-}
243
244 instance MonadTrans (StateT s) where
245 lift m = StateT $ \ s -> do
246 a <- m
247 return (a, s)
248 {-# INLINE lift #-}
249
250 instance (MonadIO m) => MonadIO (StateT s m) where
251 liftIO = lift . liftIO
252 {-# INLINE liftIO #-}
253
254 -- | Fetch the current value of the state within the monad.
255 get :: (Monad m) => StateT s m s
256 get = state $ \ s -> (s, s)
257 {-# INLINE get #-}
258
259 -- | @'put' s@ sets the state within the monad to @s@.
260 put :: (Monad m) => s -> StateT s m ()
261 put s = state $ \ _ -> ((), s)
262 {-# INLINE put #-}
263
264 -- | @'modify' f@ is an action that updates the state to the result of
265 -- applying @f@ to the current state.
266 --
267 -- * @'modify' f = 'get' >>= ('put' . f)@
268 modify :: (Monad m) => (s -> s) -> StateT s m ()
269 modify f = state $ \ s -> ((), f s)
270 {-# INLINE modify #-}
271
272 -- | A variant of 'modify' in which the computation is strict in the
273 -- new state.
274 --
275 -- * @'modify'' f = 'get' >>= (('$!') 'put' . f)@
276 modify' :: (Monad m) => (s -> s) -> StateT s m ()
277 modify' f = do
278 s <- get
279 put $! f s
280 {-# INLINE modify' #-}
281
282 -- | Get a specific component of the state, using a projection function
283 -- supplied.
284 --
285 -- * @'gets' f = 'liftM' f 'get'@
286 gets :: (Monad m) => (s -> a) -> StateT s m a
287 gets f = state $ \ s -> (f s, s)
288 {-# INLINE gets #-}
289
290 -- | Uniform lifting of a @callCC@ operation to the new monad.
291 -- This version rolls back to the original state on entering the
292 -- continuation.
293 liftCallCC :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b
294 liftCallCC callCC f = StateT $ \ s ->
295 callCC $ \ c ->
296 runStateT (f (\ a -> StateT $ \ _ -> c (a, s))) s
297 {-# INLINE liftCallCC #-}
298
299 -- | In-situ lifting of a @callCC@ operation to the new monad.
300 -- This version uses the current state on entering the continuation.
301 -- It does not satisfy the uniformity property (see "Control.Monad.Signatures").
302 liftCallCC' :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b
303 liftCallCC' callCC f = StateT $ \ s ->
304 callCC $ \ c ->
305 runStateT (f (\ a -> StateT $ \ s' -> c (a, s'))) s
306 {-# INLINE liftCallCC' #-}
307
308 -- | Lift a @catchE@ operation to the new monad.
309 liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a
310 liftCatch catchE m h =
311 StateT $ \ s -> runStateT m s `catchE` \ e -> runStateT (h e) s
312 {-# INLINE liftCatch #-}
313
314 -- | Lift a @listen@ operation to the new monad.
315 liftListen :: (Monad m) => Listen w m (a,s) -> Listen w (StateT s m) a
316 liftListen listen m = StateT $ \ s -> do
317 ~((a, s'), w) <- listen (runStateT m s)
318 return ((a, w), s')
319 {-# INLINE liftListen #-}
320
321 -- | Lift a @pass@ operation to the new monad.
322 liftPass :: (Monad m) => Pass w m (a,s) -> Pass w (StateT s m) a
323 liftPass pass m = StateT $ \ s -> pass $ do
324 ~((a, f), s') <- runStateT m s
325 return ((a, s'), f)
326 {-# INLINE liftPass #-}
327
328 {- $examples
329
330 Parser from ParseLib with Hugs:
331
332 > type Parser a = StateT String [] a
333 > ==> StateT (String -> [(a,String)])
334
335 For example, item can be written as:
336
337 > item = do (x:xs) <- get
338 > put xs
339 > return x
340 >
341 > type BoringState s a = StateT s Identity a
342 > ==> StateT (s -> Identity (a,s))
343 >
344 > type StateWithIO s a = StateT s IO a
345 > ==> StateT (s -> IO (a,s))
346 >
347 > type StateWithErr s a = StateT s Maybe a
348 > ==> StateT (s -> Maybe (a,s))
349
350 -}
351
352 {- $counting
353
354 A function to increment a counter.
355 Taken from the paper \"Generalising Monads to Arrows\",
356 John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998:
357
358 > tick :: State Int Int
359 > tick = do n <- get
360 > put (n+1)
361 > return n
362
363 Add one to the given number using the state monad:
364
365 > plusOne :: Int -> Int
366 > plusOne n = execState tick n
367
368 A contrived addition example. Works only with positive numbers:
369
370 > plus :: Int -> Int -> Int
371 > plus n x = execState (sequence $ replicate n tick) x
372
373 -}
374
375 {- $labelling
376
377 An example from /The Craft of Functional Programming/, Simon
378 Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),
379 Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a
380 tree of integers in which the original elements are replaced by
381 natural numbers, starting from 0. The same element has to be
382 replaced by the same number at every occurrence, and when we meet
383 an as-yet-unvisited element we have to find a \'new\' number to match
384 it with:\"
385
386 > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)
387 > type Table a = [a]
388
389 > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)
390 > numberTree Nil = return Nil
391 > numberTree (Node x t1 t2) = do
392 > num <- numberNode x
393 > nt1 <- numberTree t1
394 > nt2 <- numberTree t2
395 > return (Node num nt1 nt2)
396 > where
397 > numberNode :: Eq a => a -> State (Table a) Int
398 > numberNode x = do
399 > table <- get
400 > case elemIndex x table of
401 > Nothing -> do
402 > put (table ++ [x])
403 > return (length table)
404 > Just i -> return i
405
406 numTree applies numberTree with an initial state:
407
408 > numTree :: (Eq a) => Tree a -> Tree Int
409 > numTree t = evalState (numberTree t) []
410
411 > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil
412 > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil
413
414 -}