← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/mtl/Control/Monad/State/Strict.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/mtl/Control/Monad/State/Strict.hs
 
1
{-# LANGUAGE UndecidableInstances #-}
 
2
-- Search for UndecidableInstances to see why this is needed
 
3
 
 
4
-----------------------------------------------------------------------------
 
5
-- |
 
6
-- Module      :  Control.Monad.State.Strict
 
7
-- Copyright   :  (c) Andy Gill 2001,
 
8
--           (c) Oregon Graduate Institute of Science and Technology, 2001
 
9
-- License     :  BSD-style (see the file libraries/base/LICENSE)
 
10
--
 
11
-- Maintainer  :  libraries@haskell.org
 
12
-- Stability   :  experimental
 
13
-- Portability :  non-portable (multi-param classes, functional dependencies)
 
14
--
 
15
-- Strict state monads.
 
16
--
 
17
--      This module is inspired by the paper
 
18
--      /Functional Programming with Overloading and
 
19
--          Higher-Order Polymorphism/,
 
20
--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
 
21
--          Advanced School of Functional Programming, 1995.
 
22
--
 
23
-- See below for examples.
 
24
 
 
25
-----------------------------------------------------------------------------
 
26
 
 
27
module Control.Monad.State.Strict (
 
28
    module Control.Monad.State.Class,
 
29
    -- * The State Monad
 
30
    State(..),
 
31
    evalState,
 
32
    execState,
 
33
    mapState,
 
34
    withState,
 
35
    -- * The StateT Monad
 
36
    StateT(..),
 
37
    evalStateT,
 
38
    execStateT,
 
39
    mapStateT,
 
40
    withStateT,
 
41
    module Control.Monad,
 
42
    module Control.Monad.Fix,
 
43
    module Control.Monad.Trans,
 
44
    -- * Examples
 
45
    -- $examples
 
46
  ) where
 
47
 
 
48
import Control.Monad
 
49
import Control.Monad.Cont.Class
 
50
import Control.Monad.Error.Class
 
51
import Control.Monad.Fix
 
52
import Control.Monad.Reader.Class
 
53
import Control.Monad.State.Class
 
54
import Control.Monad.Trans
 
55
import Control.Monad.Writer.Class
 
56
 
 
57
-- ---------------------------------------------------------------------------
 
58
-- | A parameterizable state monad where /s/ is the type of the state
 
59
-- to carry and /a/ is the type of the /return value/.
 
60
 
 
61
newtype State s a = State { runState :: s -> (a, s) }
 
62
 
 
63
-- |Evaluate this state monad with the given initial state,throwing
 
64
-- away the final state.  Very much like @fst@ composed with
 
65
-- @runstate@.
 
66
 
 
67
evalState :: State s a -- ^The state to evaluate
 
68
          -> s         -- ^An initial value
 
69
          -> a         -- ^The return value of the state application
 
70
evalState m s = fst (runState m s)
 
71
 
 
72
-- |Execute this state and return the new state, throwing away the
 
73
-- return value.  Very much like @snd@ composed with
 
74
-- @runstate@.
 
75
 
 
76
execState :: State s a -- ^The state to evaluate
 
77
          -> s         -- ^An initial value
 
78
          -> s         -- ^The new state
 
79
execState m s = snd (runState m s)
 
80
 
 
81
-- |Map a stateful computation from one (return value, state) pair to
 
82
-- another.  For instance, to convert numberTree from a function that
 
83
-- returns a tree to a function that returns the sum of the numbered
 
84
-- tree (see the Examples section for numberTree and sumTree) you may
 
85
-- write:
 
86
--
 
87
-- > sumNumberedTree :: (Eq a) => Tree a -> State (Table a) Int
 
88
-- > sumNumberedTree = mapState (\ (t, tab) -> (sumTree t, tab))  . numberTree
 
89
 
 
90
mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
 
91
mapState f m = State $ f . runState m
 
92
 
 
93
-- |Apply this function to this state and return the resulting state.
 
94
withState :: (s -> s) -> State s a -> State s a
 
95
withState f m = State $ runState m . f
 
96
 
 
97
 
 
98
instance Functor (State s) where
 
99
    fmap f m = State $ \s -> case runState m s of
 
100
                                 (a, s') -> (f a, s')
 
101
 
 
102
instance Monad (State s) where
 
103
    return a = State $ \s -> (a, s)
 
104
    m >>= k  = State $ \s -> case runState m s of
 
105
                                 (a, s') -> runState (k a) s'
 
106
 
 
107
instance MonadFix (State s) where
 
108
    mfix f = State $ \s -> let (a, s') = runState (f a) s in (a, s')
 
109
 
 
110
instance MonadState s (State s) where
 
111
    get   = State $ \s -> (s, s)
 
112
    put s = State $ \_ -> ((), s)
 
113
 
 
114
-- ---------------------------------------------------------------------------
 
115
-- | A parameterizable state monad for encapsulating an inner
 
116
-- monad.
 
117
--
 
118
-- The StateT Monad structure is parameterized over two things:
 
119
--
 
120
--   * s - The state.
 
121
--
 
122
--   * m - The inner monad.
 
123
--
 
124
-- Here are some examples of use:
 
125
--
 
126
-- (Parser from ParseLib with Hugs)
 
127
--
 
128
-- >  type Parser a = StateT String [] a
 
129
-- >     ==> StateT (String -> [(a,String)])
 
130
--
 
131
-- For example, item can be written as:
 
132
--
 
133
-- >   item = do (x:xs) <- get
 
134
-- >          put xs
 
135
-- >          return x
 
136
-- >
 
137
-- >   type BoringState s a = StateT s Indentity a
 
138
-- >        ==> StateT (s -> Identity (a,s))
 
139
-- >
 
140
-- >   type StateWithIO s a = StateT s IO a
 
141
-- >        ==> StateT (s -> IO (a,s))
 
142
-- >
 
143
-- >   type StateWithErr s a = StateT s Maybe a
 
144
-- >        ==> StateT (s -> Maybe (a,s))
 
145
 
 
146
newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
 
147
 
 
148
-- |Similar to 'evalState'
 
149
evalStateT :: (Monad m) => StateT s m a -> s -> m a
 
150
evalStateT m s = do
 
151
    (a, _) <- runStateT m s
 
152
    return a
 
153
 
 
154
-- |Similar to 'execState'
 
155
execStateT :: (Monad m) => StateT s m a -> s -> m s
 
156
execStateT m s = do
 
157
    (_, s') <- runStateT m s
 
158
    return s'
 
159
 
 
160
-- |Similar to 'mapState'
 
161
mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
 
162
mapStateT f m = StateT $ f . runStateT m
 
163
 
 
164
-- |Similar to 'withState'
 
165
withStateT :: (s -> s) -> StateT s m a -> StateT s m a
 
166
withStateT f m = StateT $ runStateT m . f
 
167
 
 
168
instance (Monad m) => Functor (StateT s m) where
 
169
    fmap f m = StateT $ \s -> do
 
170
        (x, s') <- runStateT m s
 
171
        return (f x, s')
 
172
 
 
173
instance (Monad m) => Monad (StateT s m) where
 
174
    return a = StateT $ \s -> return (a, s)
 
175
    m >>= k  = StateT $ \s -> do
 
176
        (a, s') <- runStateT m s
 
177
        runStateT (k a) s'
 
178
    fail str = StateT $ \_ -> fail str
 
179
 
 
180
instance (MonadPlus m) => MonadPlus (StateT s m) where
 
181
    mzero       = StateT $ \_ -> mzero
 
182
    m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s
 
183
 
 
184
instance (MonadFix m) => MonadFix (StateT s m) where
 
185
    mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s
 
186
 
 
187
instance (Monad m) => MonadState s (StateT s m) where
 
188
    get   = StateT $ \s -> return (s, s)
 
189
    put s = StateT $ \_ -> return ((), s)
 
190
 
 
191
-- ---------------------------------------------------------------------------
 
192
-- Instances for other mtl transformers
 
193
 
 
194
instance MonadTrans (StateT s) where
 
195
    lift m = StateT $ \s -> do
 
196
        a <- m
 
197
        return (a, s)
 
198
 
 
199
instance (MonadIO m) => MonadIO (StateT s m) where
 
200
    liftIO = lift . liftIO
 
201
 
 
202
instance (MonadCont m) => MonadCont (StateT s m) where
 
203
    callCC f = StateT $ \s ->
 
204
        callCC $ \c ->
 
205
        runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s
 
206
 
 
207
instance (MonadError e m) => MonadError e (StateT s m) where
 
208
    throwError       = lift . throwError
 
209
    m `catchError` h = StateT $ \s -> runStateT m s
 
210
        `catchError` \e -> runStateT (h e) s
 
211
 
 
212
-- Needs UndecidableInstances
 
213
instance (MonadReader r m) => MonadReader r (StateT s m) where
 
214
    ask       = lift ask
 
215
    local f m = StateT $ \s -> local f (runStateT m s)
 
216
 
 
217
-- Needs UndecidableInstances
 
218
instance (MonadWriter w m) => MonadWriter w (StateT s m) where
 
219
    tell     = lift . tell
 
220
    listen m = StateT $ \s -> do
 
221
        ((a, s'), w) <- listen (runStateT m s)
 
222
        return ((a, w), s')
 
223
    pass   m = StateT $ \s -> pass $ do
 
224
        ((a, f), s') <- runStateT m s
 
225
        return ((a, s'), f)
 
226
 
 
227
-- ---------------------------------------------------------------------------
 
228
-- $examples
 
229
-- A function to increment a counter.  Taken from the paper
 
230
-- /Generalising Monads to Arrows/, John
 
231
-- Hughes (<http://www.math.chalmers.se/~rjmh/>), November 1998:
 
232
--
 
233
-- > tick :: State Int Int
 
234
-- > tick = do n <- get
 
235
-- >           put (n+1)
 
236
-- >           return n
 
237
--
 
238
-- Add one to the given number using the state monad:
 
239
--
 
240
-- > plusOne :: Int -> Int
 
241
-- > plusOne n = execState tick n
 
242
--
 
243
-- A contrived addition example. Works only with positive numbers:
 
244
--
 
245
-- > plus :: Int -> Int -> Int
 
246
-- > plus n x = execState (sequence $ replicate n tick) x
 
247
--
 
248
-- An example from /The Craft of Functional Programming/, Simon
 
249
-- Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),
 
250
-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a
 
251
-- tree of integers in which the original elements are replaced by
 
252
-- natural numbers, starting from 0.  The same element has to be
 
253
-- replaced by the same number at every occurrence, and when we meet
 
254
-- an as-yet-unvisited element we have to find a \'new\' number to match
 
255
-- it with:\"
 
256
--
 
257
-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)
 
258
-- > type Table a = [a]
 
259
--
 
260
-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)
 
261
-- > numberTree Nil = return Nil
 
262
-- > numberTree (Node x t1 t2)
 
263
-- >        =  do num <- numberNode x
 
264
-- >              nt1 <- numberTree t1
 
265
-- >              nt2 <- numberTree t2
 
266
-- >              return (Node num nt1 nt2)
 
267
-- >     where
 
268
-- >     numberNode :: Eq a => a -> State (Table a) Int
 
269
-- >     numberNode x
 
270
-- >        = do table <- get
 
271
-- >             (newTable, newPos) <- return (nNode x table)
 
272
-- >             put newTable
 
273
-- >             return newPos
 
274
-- >     nNode::  (Eq a) => a -> Table a -> (Table a, Int)
 
275
-- >     nNode x table
 
276
-- >        = case (findIndexInList (== x) table) of
 
277
-- >          Nothing -> (table ++ [x], length table)
 
278
-- >          Just i  -> (table, i)
 
279
-- >     findIndexInList :: (a -> Bool) -> [a] -> Maybe Int
 
280
-- >     findIndexInList = findIndexInListHelp 0
 
281
-- >     findIndexInListHelp _ _ [] = Nothing
 
282
-- >     findIndexInListHelp count f (h:t)
 
283
-- >        = if (f h)
 
284
-- >          then Just count
 
285
-- >          else findIndexInListHelp (count+1) f t
 
286
--
 
287
-- numTree applies numberTree with an initial state:
 
288
--
 
289
-- > numTree :: (Eq a) => Tree a -> Tree Int
 
290
-- > numTree t = evalState (numberTree t) []
 
291
--
 
292
-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil
 
293
-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil
 
294
--
 
295
-- sumTree is a little helper function that does not use the State monad:
 
296
--
 
297
-- > sumTree :: (Num a) => Tree a -> a
 
298
-- > sumTree Nil = 0
 
299
-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)