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