Claus Reinke wrote:
while (hGetBuf h buf bufsize == bufsize) crc := updateCrc crc buf bufsize break if crc==0 print crc
inContT $ callCC $ \break -> do flip execStateT 0 $ do whileM (liftM (== bufsize) (hGetBuf h buf bufsize)) $ do modifyM (updateCrc buf bufsize) crc <- get when (crc == 0) (lift (break crc)) print crc
first. it's longer than original.
The above version required passing break explicitly. I can pack that into a Reader. The actual semantics of the while loop from 'c' are then more closely followed. This allows:
run_ = runner_ testWhile_ runner_ m = runRWS (runContT m return) NoExit_ (17::Int) testWhile_ = while_ (liftM (>10) get) innerWhile_ innerWhile_ = do v <- get tell_ [show v] when' (v==20) (tell_ ["breaking"] >> breakW_) if v == 15 then put 30 >> continueW_ else modify pred
The result is
((),20,["17","16","15","30","29","28","27","26","25","24","23","22","21","20","breaking"])
Where there is the benefit over C of putting the break or continue in a sub-function. The full code (for two versions) is: -- By Chris Kuklewicz, BSD-3 license, February 2007 -- Example of pure "while" and "repeat until" looping constructs 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_ m = runRWS (runContT m return) NoExit_ (17::Int) 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")) -- 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 let go = do check <-mCondition when' check (withLoop_ loop mBody >> go) when' proceed go while mCondition mBody = do (proceed,loop) <- getCC' True let go = do check <-mCondition when' check (withLoop loop mBody >> go) when' proceed go repeatUntil_ mCondition mBody = do (proceed,loop) <- getCC' True let go = do withLoop_ loop mBody check <- mCondition when' (not check) go when' proceed go repeatUntil mCondition mBody = do (proceed,loop) <- getCC' True let go = do withLoop loop mBody check <- mCondition when' (not check) go when' proceed go -- 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