[Haskell-cafe] Channel9 Interview: Software Composability andthe Future of Languages

[Chris Kuklewicz]

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