> module CPSState ( CPS.., -- reexport CPS
> CPSST(..),
> raise, run, tryST, fixST, update,
> handleST, zero, (?),
> -- name supply
> Supply(..),
> newVar, nameSupply
> )
> where
> import CPS hiding ( zero, (?) )
> infixr 1 ?
State transformer
> type CPSST st val res = CPS val (st -> res)
Raising an exception.
> raise :: exc -> CPSST st val (Either exc res)
> raise e = \c s -> Left e
Handling an exception.
> tryST :: CPSST st val (Either exc (val, st))
> -> CPSST st (Either exc val) res
> tryST m = \c s -> case m (\v s -> Right (v, s)) s of
> Left e -> c (Left e) s -- old state
> Right (v, s') -> c (Right v) s' -- new state
Fixpoint `plumbing' combinator (run argument and knot result in case
it is not an exception).
> fixST :: (val -> CPSST st val (Either exc (val, st)))
> -> CPSST st val (Either exc res)
> fixST f = \c s ->
> let res = f v (\v s -> Right (v, s)) s
> Right (v, _) = res
> in case res of
> Left e -> Left e -- re-raise exc
> Right (v, s') -> c v s'
Updating the state.
> update :: (st -> st) -> CPSST st st res
> update f = \c s -> c s (f s)
Running a CPS Monad.
> run :: CPSST st val (val, st) -> st -> (val, st)
> run m s0 = m (\v s -> (v, s)) s0
Derived actions.
> handleST :: CPSST st val (Either exc (val, st))
> -> (exc -> CPSST st val res) -> CPSST st val res
> handleST m h = tryST m &= either h unit
> zero :: CPSST st val (Either () (val, st))
> zero = raise ()
> (?) :: CPSST st val (Either () (val, st))
> -> CPSST st val res -> CPSST st val res
> m ? n = m `handleST` \() -> n
Application: Name Supply
> type Supply val res = CPSST [String] val res
> newVar :: Supply String res
> newVar = update tail &@ head
> newVars :: Int -> Supply [String] res
> newVars n = update (drop n) &@ (take n)
> nameSupply :: Char -> [String]
> nameSupply c = map (c:) names
> where names = [ [c] | c<-['a'..'z'] ]
> ++ [ c:x | c<-['a'..'z'], x<-nameSupply c ]