1 module StateMonad where
    2 
    3 -- General purpose state monad -----------------------------------------------
    4 
    5 type SM s a       = s -> (s, a)
    6 
    7 -- Primitive monad operators -------------------------------------------------
    8 
    9 retURN           :: a -> SM s a
   10 retURN x          = \s -> (s, x)
   11 
   12 bind             :: SM s a -> (a -> SM s b) -> SM s b
   13 m `bind` f        = \s -> let (s',a) = m s in f a s'
   14 
   15 join             :: SM s (SM s a) -> SM s a
   16 join m            = \s -> let (s',ma) = m s in ma s'
   17 
   18 mmap             :: (a -> b) -> (SM s a -> SM s b)
   19 mmap f m          = \s -> let (s',a)  = m s in (s', f a)
   20 
   21 -- General monad operators ---------------------------------------------------
   22 
   23 mmapl            :: (a -> SM s b) -> ([a] -> SM s [b])
   24 mmapl f []        = retURN []
   25 mmapl f (a:as)    = f a             `bind` \b ->
   26                     mmapl f as      `bind` \bs ->
   27                     retURN (b:bs)
   28 
   29 mmapr            :: (a -> SM s b) -> ([a] -> SM s [b])
   30 mmapr f []        = retURN []
   31 mmapr f (x:xs)    = mmapr f xs      `bind` \ys ->
   32                     f x             `bind` \y  ->
   33                     retURN (y:ys)
   34 
   35 mfoldl           :: (a -> b -> SM s a) -> a -> [b] -> SM s a
   36 mfoldl f a []     = retURN a
   37 mfoldl f a (x:xs) = f a x           `bind` \fax ->
   38                     mfoldl f fax xs
   39 
   40 mfoldr           :: (a -> b -> SM s b) -> b -> [a] -> SM s b
   41 mfoldr f a []     = retURN a
   42 mfoldr f a (x:xs) = mfoldr f a xs   `bind` \y ->
   43                     f x y
   44 
   45 mif              :: SM s Bool -> SM s a -> SM s a -> SM s a
   46 mif c t f         = c               `bind` \cond ->
   47                     if cond then t
   48                             else f
   49 
   50 -- Specific utilities for state monads ---------------------------------------
   51 
   52 startingWith      :: SM s a -> s -> a
   53 m `startingWith` v = answer where (final,answer) = m v
   54 
   55 fetch             :: SM s s
   56 fetch              = \s -> (s,s)
   57 
   58 fetchWith         :: (s -> a) -> SM s a
   59 fetchWith f        = \s -> (s, f s)
   60 
   61 update            :: (s -> s) -> SM s s
   62 update f           = \s -> (f s, s)
   63 
   64 set               :: s -> SM s s
   65 set s'             = \s -> (s',s)
   66 
   67 -- Common use of state monad: counter ----------------------------------------
   68 
   69 incr              :: SM Int Int
   70 incr               = update (1+)