Implementing `machines` using `streaming` library

Play.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Play where

import Prelude hiding ((.), id)
import Data.Foldable
import Streaming.Internal
import Control.Category

infixr 9 <~

data Coroutine k o a where
  Yield :: o -> a -> Coroutine k o a
  Await :: (i -> a) -> k i -> a -> Coroutine k o a
  Stop  :: Coroutine k o a

instance Functor (Coroutine k o) where
  fmap f (Yield o a)   = Yield o (f a)
  fmap f (Await s k a) = Await (f . s) k (f a)
  fmap _ Stop          = Stop

data Is a b where
  Refl :: Is a a

instance Category Is where
  id = Refl
  Refl . Refl = Refl

type Machine k o m r = Stream (Coroutine k o) m r
type Process a b m r = Machine (Is a) b m r
type Source m o r    = forall k. Machine k o m r

await :: (Monad m, Category k) => Machine (k i) o m i
await = Step (Await return id (Step Stop))

yield :: Monad m => o -> Machine k o m ()
yield o = Step (Yield o (return ()))

(<~) :: Monad m => Process b c m r -> Machine k b m r -> Machine k c m r
mp <~ mb =
  case mp of
    Return _  -> Step Stop
    Effect m  -> Effect (fmap (<~ mb) m)
    Step consumer ->
      case consumer of
        Yield c next        -> Step $ Yield c (next <~ mb)
        Stop                -> Step Stop
        Await k Refl failed ->
          case mb of
            Return _      -> failed <~ (Step Stop)
            Effect m      ->  Effect (fmap (Step consumer <~) m)
            Step producer ->
              case producer of
                Yield b next -> k b <~ next
                Await kb instr kfailed ->
                  Step (Await ((Step consumer <~) . kb) instr (Step consumer <~ kfailed))
                Stop -> failed <~ Step Stop

repeatedly :: Functor m => Machine k o m x -> Machine k o m r
repeatedly start = go start
  where
    go (Return _)  = go start
    go (Effect m)  = Effect (fmap go m)
    go (Step step) =
      case step of
        Yield o next         -> Step $ Yield o (go next)
        Await k instr failed -> Step $ Await (go . k) instr (go failed)
        Stop                 -> go start

producingInts :: Monad m => Source m Int ()
producingInts = traverse_ yield [0..]

mappingInts :: Monad m => Process Int String m r
mappingInts = repeatedly $ do
  i <- await
  yield (show i)

producingStrings :: Monad m => Source m String ()
producingStrings = mappingInts <~ producingInts