Cool coroutines with free monad transformers

Main.hs

-- packages "free" and "transformers" assumed

{-# LANGUAGE DeriveFunctor #-}

module Main where

import Control.Monad.Trans.Free
import Control.Monad.Trans.Class

data CoroutineF a = Yield a 
  deriving (Show, Functor)
  
type CoroutineT m a = FreeT CoroutineF m a

yield :: Monad m => CoroutineT m ()
yield = liftF $ Yield ()

runCoroutine :: Monad m => CoroutineT m a -> m a;
runCoroutine c = let m = runFreeT c in do
  f <- m;
  case f of
    Pure x -> return x;
    Free (Yield f) -> runCoroutine f

runCoroutines :: Monad m =>
  CoroutineT m a -> CoroutineT m b -> m (a, b)
runCoroutines c1 c2 = let (m1, m2) = (runFreeT c1, runFreeT c2) in do
      f1 <- m1; f2 <- m2;
      case (f1, f2) of
        (Pure x, Pure y) -> return (x, y);
        (Pure x, Free (Yield c)) -> (\y -> (x, y)) <$> runCoroutine c;
        (Free (Yield c), Pure y) -> (\x -> (x, y)) <$> runCoroutine c;
        (Free (Yield c1), Free (Yield c2)) -> runCoroutines c1 c2

c1 :: CoroutineT IO ()
c1 = do
  lift $ putStrLn "Hi1"
  line <- lift getLine
  yield
  lift $ putStrLn line

c2 :: CoroutineT IO ()
c2 = do
  lift $ putStrLn "Hi2"
  yield
  lift $ putStrLn "Bye2"

main :: IO ()
main = runCoroutines c1 c2 >> return ()