resumptions

I can't seem to find enough examples of using resumption monads for my taste.

Here is the code from William Harrison et al's code from 'Asynchronous Exceptions As An Effect' re-written with standard machinery (i.e. with monads from mtl).

--

{-# LANGUAGE TypeSynonymInstances       #-}
{-# OPTIONS -Wall #-}


module AsyncE where


import Control.Monad.Error


merge :: [[a]] -> [a]
merge = concat


data Err = Error 
  deriving Show

instance Error Err where
  noMsg = Error
  strMsg = const Error

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


instance Monad m => Monad (ResT m) where
  return = Done
  Done v >>= f = f v
  Pause phi >>= f = Pause $ phi >>= \k -> return (k >>= f)

type N a = [a]

type R = ResT E


type E = ErrorT Err []



instance Show a => Show (E a) where
  show = show . runErrorT


instance Show a => Show (R a) where
  show (Done a) = "Done " ++ show a
  show (Pause phi) = "Pause " ++ show phi



ok :: a -> Either Err a
ok = Right

err :: Either Err a
err = Left Error

-- page 7 examples
ex1 :: N Int
ex2 :: E Int
ex3 :: N Int
ex4 :: E Int

ex1 = return 9
ex2 = return 9
ex3 = [1,2,3] >>= (\v -> return (v+1))
ex4 = (ErrorT [ok 1, ok 2, err]) >>= (\v -> return (v+1))


step :: E a -> R a
step x = Pause (x >>= (return . Done))



run :: R a -> E a
run (Pause phi) = phi >>= run
run (Done v)    = return v


ex5 :: E Int
ex5 = run (step (ErrorT [ok 1, ok 2, err]))

mergeN :: N (N a) -> N a
mergeN = concat


mergeE :: N (E a) -> E a
mergeE = ErrorT . mergeN . map runErrorT


mergeR :: N (R a) -> R a
mergeR xs = Pause (mergeE (map return xs))


-- page 8 examples
ex6 :: N Int
ex6 = mergeN [[1,2],[4]]

ex7 :: E Int
ex7 = mergeE [ (ErrorT [ok 1, ok 2, err]), (ErrorT [ok 4,err])]

bindN :: [a] -> (a -> [b]) -> [b]
bindN = (>>=)

etaN :: a -> [a]
etaN = return 




statusE :: E a -> E (Either Err a)
statusE phi = ErrorT $  
  (runErrorT phi) >>= \v -> 
    case v of
      Right y -> return (Right (Right y))
      Left Error  -> return (Left Error)


statusR :: R a -> R (Either Err a)
statusR (Pause phi) = 
    Pause $ (statusE phi) >>=  \v ->
              case v of
                Right x -> return (statusR x)
                Left Error  -> return (Done (Left Error)) 
    
statusR (Done v) = (Done (ok v))


throwE :: E a
throwE = ErrorT $ return (Left Error)

throwR :: R a
throwR = step throwE

fork :: R a -> R a
fork phi = mergeR [ phi, throwR ]


catchE :: E a -> E a -> E a
catchE phi gamma = (statusE phi) >>= \s ->
                          case s of 
                            Right v -> return v
                            Left Error  -> gamma

catchR :: R a -> R a -> R a
catchR phi gamma = (statusR phi) >>= \s ->
                          case s of 
                            Right v -> return v
                            Left Error  -> gamma


-- page 8 and 9 examples

ex8 :: E a
ex8 = throwE

ex9 :: E Int
ex9 = throwE >>= \v -> return (v + 1)

ex10 :: E (Either Err a)
ex10 = statusE throwE

ex11 :: E (Either Err Int)
ex11 = statusE (return 9) 


ex12 :: E Int
ex12 = catchE throwE (return 9)

ex13 :: R Int
ex13 = fork (return 9)

ex14 :: E Int
ex14 = run (fork (return 9))


-- Section 4

data Expr = Val Int
          | Add Expr Expr
          | Seqn Expr Expr
          | Throw
          | Catch Expr Expr
          | Block Expr
          | Unblock Expr
  deriving (Show)




evB :: Expr -> R Int
evB (Val i)       = step (return i)
evB (Add e1 e2)   = (evB e1) >>= \v1 ->
                    (evB e2) >>= \v2 ->
                      return (v1 + v2)
evB (Seqn e1 e2)  = (evB e1) >> (evB e2)
evB Throw         = throwR
evB (Catch e1 e2) = catchR (evB e1) (evB e2)
evB (Block e)     = (evB e)
evB (Unblock e)   = (evU e)

evU :: Expr -> R Int
evU (Val i)       = fork (step (return i))
evU (Add e1 e2)   = fork ((evU e1) >>= \v1 ->
                          (evU e2) >>= \v2 ->
                          return (v1 + v2))
evU (Seqn e1 e2)  = fork ((evU e1) >> (evU e2))
evU Throw         = fork throwR
evU (Catch e1 e2) = fork (catchR (evU e1) (evU e2))
evU (Block e)     = fork (evB e)
evU (Unblock e)   = fork (evU e)

ex15 :: E Int
ex15 = run (evU (Add (Val 1) (Val 2)))