[Haskell-cafe] Pesky monads...

[haskell at list.mightyreason.com]

I previously worked out how to use the monad transformers to make a when /
repeat control structure that admitted both break and continue
statements.  It uses a ContT monad transformer to provide the escape semantics
and the Reader to store the continuation.

I'll paste the code here:

> -- By Chris Kuklewicz, BSD-3 license, February 2007
> -- Example of pure "while" and "repeat until" looping constucts using
> -- the monad transformer library.  Works for me in GHC 6.6
> --
> -- The underscore version is ContT of RWS and this works more
> -- correctly than the non-underscore version of RWST of Cont.
> --
> -- Perhaps "Monad Cont done right" from the wiki would help?
> import Control.Monad.Cont
> import Control.Monad.RWS
> import Control.Monad.Error
> import Control.Monad.ST
> import System.IO.Unsafe
> import Data.STRef
> 
> -- Note that all run* values are the same Type
> main = mapM_ print [run,run2,run_,run2_]
> 
> run,run_,run2,run2_ :: MyRet ()
> run = runner testWhile
> run2 = runner testRepeatUntil
> run_ = runner_ testWhile_
> run2_ = runner_ testRepeatUntil_
> 
> -- runner_ uses ContT RWS to provide better semantics when break is called
> -- runner_ :: (Monad (RWS (Exit_ r a1 b) w Int)) => ContT a (RWS (Exit_ r a1 b) w Int) a -> (a, Int, w)
> runner_ m = runRWS (runContT m return) NoExit_ (17::Int)
> 
> -- runner uses RWST Cont and does not work as desired
> -- runner :: (Num s) => RWST (Exit r a1 b) w s (Cont (a, s, w)) a -> (a, s, w)
> runner m = (flip runCont) id (runRWST m NoExit (17))
> 
> testRepeatUntil_ = repeatUntil_ (liftM (==17) get) innerRepeatUntil_
> testRepeatUntil = repeatUntil (liftM (==17) get) innerRepeatUntil
> 
> innerRepeatUntil_ = tell_ ["I ran"] >> breakW_
> innerRepeatUntil = tell ["I ran"] >> breakW
> 
> testWhile_ = while_ (liftM (>10) get) innerWhile_
> testWhile = while (liftM (>10) get) innerWhile
> 
> -- innerWhile_ :: ContT () (T_ (Exit_ () Bool Bool)) ()
> innerWhile_ = do
>   v <- get
>   tell_ [show v]
>   when' (v==20) (tell_ ["breaking"] >> breakW_)
>   if v == 15 
>     then put 30 >> continueW_
>     else modify pred
> 
> innerWhile = do
>   v <- get
>   tell [show v]
>   when' (v==20) (tell ["breaking"] >> breakW)
>   if v == 15 
>     then put 30 >> continueW
>     else modify pred
> 
> -- The Monoid restictions means I can't write an instance, so use tell_
> tell_ = lift . tell
> 
> -- Generic defintions
> getCC :: MonadCont m => m (m a)
> getCC = callCC (\c -> let x = c x in return x)
> getCC' :: MonadCont m => a -> m (a, a -> m b)
> getCC' x0 = callCC (\c -> let f x = c (x, f) in return (x0, f))
> 
> when' :: (Monad m) => Bool -> m a -> m ()
> when' b m = if b then (m >> return ()) else return ()
> 
> -- Common types
> type MyState = Int
> type MyWriter = [String]
> type MyRet a = (a,MyState,MyWriter)
> -- RWST of Cont Types
> type T r = RWST r MyWriter MyState
> type Foo r a = T (Exit (MyRet r) a a) (Cont (MyRet r))
> type WhileFunc = Foo () Bool
> type ExitFoo r a = Foo r a a --  (Exit r a a)  (Cont r) a
> type ExitType r a = T (Exit r a a)  (Cont r) a
> data Exit r a b = Exit (a -> ExitType r b) | NoExit
> -- ContT of RWS Types
> type T_ r = RWS r MyWriter MyState
> type ExitType_ r a = ContT r (T_ (Exit_ r a a)) a
> data Exit_ r a b = Exit_ (a -> ExitType_ r b) | NoExit_
> 
> -- Smart destructor for Exit* types
> getExit (Exit loop) = loop
> getExit NoExit = (\ _ -> return (error "NoExit"))
> getExit_ (Exit_ loop) = loop
> getExit_ NoExit_ = (\ _ -> return (error "NoExit"))
> 
> -- The with* functions here use the Reader monad features to scope the
> -- break and continue commands.
> 
> -- I cannot see how to lift withRWS, so use local
> -- Perhaps "Monad Cont done right" from the wiki would help?
> withLoop_ loop = local (\r -> Exit_ loop)
> -- withRWST can change the reader Type
> withLoop loop = withRWST (\r s -> (Exit loop,s)) 
> 
> -- The condition is never run in the scope of the (withLoop loop)
> -- continuation.  I could have invoked (loop True) for normal looping
> -- but I decided a tail call works as well.  This decision has
> -- implication for the non-underscore version, since the writer/state
> -- can get lost if you call (loop _).
> while_ mCondition mBody = do
>   (proceed,loop) <- getCC' True
>   -- break and continue jump here with new 'proceed' value
>   let go = do check <- mCondition
>               when' check (withLoop_ loop mBody >> go)
>   when' proceed go
> 
> while mCondition mBody = do
>   (proceed,loop) <- getCC' True
>   -- break and continue jump here with new 'proceed' value
>   let go = do check <- mCondition
>               when' check (withLoop loop mBody >> go)
>   when' proceed go
> 
> repeatUntil_ mCondition mBody = do
>   (proceed,loop) <- getCC' True
>   -- break and continue jump here with new 'proceed' value
>   let go = do withLoop_ loop mBody
>               check <- mCondition
>               when' (not check) go
>   when' proceed go
> 
> repeatUntil mCondition mBody = do
>   (proceed,loop) <- getCC' True
>   -- break and continue jump here with new 'proceed' value
>   let go = do withLoop loop mBody
>               check <- mCondition
>               when' (not check) go
>   when' proceed go
> 
> -- The break and continue commands depends on the Reader Monad being
> -- setup by withLoop* to contain the desired continuation.  Passing
> -- the continuation "False" means 'break' and "True" means 'continue'
> 
> -- breakW :: WhileFunc a
> breakW_ =  ask >>= \e -> getExit_ e False >> return undefined
> breakW =  ask >>= \e -> getExit e False >> return undefined
> -- continueW :: WhileFunc a
> continueW_ =  ask >>= \e -> getExit_ e True >> return undefined
> continueW =  ask >>= \e -> getExit e True >> return undefined