CoroutineT.hs

{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}

import Control.Monad.Writer

newtype CoroutineT m a = CoroutineT { runCoroutineT :: m (Either (CoroutineT m a) a) }

instance Monad m => Functor (CoroutineT m) where
    fmap = liftM

instance Monad m => Applicative (CoroutineT m) where
    pure = return
    (<*>) = ap

instance Monad m => Monad (CoroutineT m) where
    return = lift . return
    c >>= k = CoroutineT $ do
        eca <- runCoroutineT c
        case eca of
            Left ca -> return $ Left $ ca >>= k
            Right x -> runCoroutineT (k x)

instance MonadTrans CoroutineT where
 -- lift :: Monad m => m a -> CoroutineT m a
    lift ma = CoroutineT $ Right <$> ma

runCoroutines :: Monad m => CoroutineT m () -> CoroutineT m () -> m ()
runCoroutines c1 c2 = do
    eca <- runCoroutineT c1
    case eca of
        Left ca -> runCoroutines c2 ca
        Right _ -> runSingle c2

runSingle :: Monad m => CoroutineT m () -> m ()
runSingle c = do
    eca <- runCoroutineT c
    case eca of
        Left ca -> runSingle ca
        Right _ -> return ()

yield :: Monad m => CoroutineT m ()
yield = CoroutineT $ return $ Left $ return ()

instance MonadWriter w m => MonadWriter w (CoroutineT m) where
    tell = lift . tell

coroutine3 = do
    tell "1"
    yield
    yield
    tell "2"

coroutine4 = do
    tell "a"
    yield
    tell "b"
    yield
    tell "c"
    yield
    tell "d"
    yield

main :: IO ()
main = do
    putStrLn $ show $ execWriter (runCoroutines coroutine3 coroutine4)