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
