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 _______________________________________________ Haskell-Cafe mailing list [email protected] http://www.haskell.org/mailman/listinfo/haskell-cafe
