resumptions

More resumptions, here's a translation of the code from Andrzej Filinski's 'Representing Layered Monads'. I think the translation is accurate, except par in the version below has deterministic scheduling:

{-# OPTIONS -Wall #-}

module FilinskiConc where

data ResT m a = Done a | Susp (m (ResT m a))

instance Monad m => Monad (ResT m) where
  return = Done
  (Done v) >>= f = f v
  (Susp r) >>= f = Susp (r >>= \k -> return (k >>= f))


step :: Monad m => m a -> ResT m a
step x = Susp $ x >>= (return . Done)

yield :: Monad m => ResT m ()
yield = Susp (return (return ()))

pOr :: Monad m => ResT m Bool -> ResT m Bool -> ResT m Bool
pOr (Done True)  _  = Done True
pOr (Done False) p  = p
pOr (Susp t1)    t2 = Susp $ t1 >>= \r -> return (pOr t2 r)


atomically :: Monad m => ResT m a -> ResT m a
atomically = work `flip` False where
    work (Done a) False = step (return a)
    work (Done a) True  = Done a
    work (Susp t) _     = do { a <- step t ; work a True }

-- Unlike Filinkski's 'par' the 'par' here has a deterministic 
-- scheduler - we do one step of a and one step of b at each
-- turn.
--
par :: Monad m => ResT m a -> ResT m b -> ResT m (a,b)
par (Done a)  (Done b)  = Done (a,b)
par (Done a)  (Susp tb) = Susp $ tb >>= \r -> return (r >>= \b -> Done (a,b))
par (Susp ta) (Done b)  = Susp $ ta >>= \r -> return (r >>= \a -> Done (a,b))
par (Susp ta) (Susp tb) = do { a <- step ta; b <- step tb; par a b }


run :: Monad m => ResT m a -> m a
run (Susp phi)  = phi >>= run
run (Done v)    = return v


demo1 :: IO ((),())
demo1 = run  (par (step $ putStrLn "a") (step $ putStrLn "b"))

demo2 :: IO Bool
demo2 = run  (pOr (step $ do { putStrLn "a"; return False} ) 
                  (step $ do { putStrLn "b"; return True} ))

asteps, bsteps :: ResT IO [()]
asteps = mapM (step . putChar) "aaaaaaa"
bsteps = mapM (step . putChar) "bbbbb"

demo3 :: IO ([()],[()])
demo3 = run (par asteps bsteps)