Specializing Coroutine to our purposes

Rather than explain right now why we're doing this, just stick with me while I specialize the previous Coroutine code to our use case, hardcoding the Interface into the type, and making Producing and Consuming newtypes. One benefit to this is that users will have clearer type errors. I've included the Coroutine type declarations to help illustrate that all I have done here is set the suspension functor to Interface i o.

-- newtype Coroutine s m r
--   = Coroutine { resume :: m (CoroutineState s m r) }
newtype Producing o i m r
  = Producing { resume :: m (ProducerState o i m r) }

-- data CoroutineState s m r
--   = Run (s (Coroutine s m r))
--   | Done r
data ProducerState o i m r
  = Produced o (Consuming r m i o)
  | Done r

newtype Consuming r m i o
  = Consuming { provide :: i -> Producing o i m r }

Since nothing has really changed, the type class instances remain essentially the same as well. I'll provide my implementation here for clarity, though. Notice the similar recursion scheme for implementing fmap for ProducerState o i, and implementing >>= and hoist for Producing o i.

instance (Functor m) => Functor (Producing o i m) where
   fmap f p = Producing $ fmap (fmap f) (resume p)

instance (Functor m) => Functor (ProducerState o i m) where
  fmap f (Done x) = Done (f x)
  fmap f (Produced o k) = Produced o $ Consuming (fmap f . provide k)

instance (Functor m, Monad m) => Applicative (Producing o i m) where
   pure = return
   (<*>) = ap

instance (Monad m) => Monad (Producing o i m) where
   return x = Producing $ return (Done x)
   p >>= f = Producing $ resume p >>= \s -> case s of
     Done x -> resume (f x)
     Produced o k ->
      return $ Produced o $ Consuming ((>>= f) . provide k)

instance MonadTrans (Producing o i) where
   lift = Producing . liftM Done

instance MFunctor (Producing o i) where
  hoist f = go where
    go p = Producing $ f $ liftM map' (resume p)
    map' (Done r) = Done r
    map' (Produced o k) = Produced o $ Consuming (go . provide k)

The main operations, yield and $$, remain the same, modulo newtype gymnastics.

yield :: Monad m => o -> Producing o i m i
yield o = Producing $ return $ Produced o $ Consuming return

infixl 0 $$
($$) :: Monad m => Producing a b m r -> Consuming r m a b -> m r
producing $$ consuming = resume producing >>= \s -> case s of
  Done r -> return r
  Produced o k -> provide consuming o $$ k

Before we go further, I suppose we should play with what we've got.

Play time

-- /show
import Control.Applicative
import Control.Monad
import Control.Monad.Morph
import Control.Monad.Trans.Class

newtype Producing o i m r
  = Producing { resume :: m (ProducerState o i m r) }

data ProducerState o i m r
  = Produced o (Consuming r m i o)
  | Done r

newtype Consuming r m i o
  = Consuming { provide :: i -> Producing o i m r }

instance (Functor m) => Functor (Producing o i m) where
   fmap f p = Producing $ fmap (fmap f) (resume p)

instance (Functor m) => Functor (ProducerState o i m) where
  fmap f (Done x) = Done (f x)
  fmap f (Produced o k) = Produced o $ Consuming (fmap f . provide k)

instance (Functor m, Monad m) => Applicative (Producing o i m) where
   pure = return
   (<*>) = ap

instance (Monad m) => Monad (Producing o i m) where
   return x = Producing $ return (Done x)
   p >>= f = Producing $ resume p >>= \s -> case s of
     Done x -> resume (f x)
     Produced o k ->
      return $ Produced o $ Consuming ((>>= f) . provide k)

instance MonadTrans (Producing o i) where
   lift = Producing . liftM Done

instance MFunctor (Producing o i) where
  hoist f = go where
    go p = Producing $ f $ liftM map' (resume p)
    map' (Done r) = Done r
    map' (Produced o k) = Produced o $ Consuming (go . provide k)

yield :: Monad m => o -> Producing o i m i
yield o = Producing $ return $ Produced o $ Consuming return

infixl 0 $$

($$) :: Monad m => Producing a b m r -> Consuming r m a b -> m r
producing $$ consuming = resume producing >>= \s -> case s of
  Done r -> return r
  Produced o k -> provide consuming o $$ k


-- show
example1 :: Producing String String IO ()
example1 = do
  name <- yield "What's your name? "
  lift $ putStrLn $ "Hello, " ++ name
  color <- yield "What's your favorite color? "
  lift $ putStrLn $ "I like " ++ color ++ ", too."

-- this comes in handy for defining Consumers
foreverK :: Monad m => (a -> m a) -> a -> m r
foreverK f = go where
  go a = f a >>= go

stdOutIn :: Consuming r IO String String
stdOutIn = Consuming $ foreverK $ \str -> do
  lift $ putStrLn str
  lift getLine >>= yield

stdInOut :: Producing String String IO r
stdInOut = provide stdOutIn ""

main = example1 $$ stdOutIn

Try building your own coroutines with the Producing monad, and hooking them together with $$. But remember, they must be in opposite states, and have compatible interfaces, as well as the same underlying monad, in order to connect.

Two interfaces makes a Proxy

What happens when we put two interfaces on top of each other?

Producing a b (Producing c d m) r

What is this? Well, it is a computation which can transfer control to one of two interfaces. The action yield a will surrender control to the outer interface, while lift (yield c) will surrender control to the inner interface. What happens when we connect such a thing's outer interface?

p :: Producing a b (Producing c d m) r
c :: Consuming r   (Producing c d m) a b
p $$ c ::           Producing c d m r

Since the "inner monad" is Producing c d m, the "Consuming" counterpart must have the same inner monad, Producing c d m. Once connected, the two computations merge their use of the c/d interface, and become (to the outside world) one computation. The a/b interface becomes unobservable, or satisfied, or connected, or whatever you want to call it.

That's cool, but there is something obnoxious about it. What if I want to connect computations which don't necessarily suspend on the same underlying interfaces?

p :: Producing a b m r
c :: Consuming r (Producing c d m) a b
p $$ c :: Type Error

Luckily, hoist and lift can help us insert the missing layer, so that the two can connect. After all, we can say that p communicates on the c/d interface, it just happens to do so zero times.

insert0 = lift          -- add a new layer at depth 0 (the outermost layer)
insert1 = hoist insert0 -- add a new layer at depth 1
insert2 = hoist insert1 -- add a new layer at depth 2

p :: Producing a b m r
insert1 p :: Producing a b (t m) r -- t = any MonadTrans we want
c :: Consuming r (Producing c d m) a b

-- t becomes specialized to (Producing c d)
insert1 p $$ c :: Producing c d m r

What just happened? We took a computation over the a/b interface, connected it to a computation over both the a/b and c/d interfaces, and transformed it into just a computation over the c/d interface. My friends, we have stumbled onto the concept of a Proxy, and just implemented $=.

newtype Proxy r m upI downI
  = Proxy { unProxy :: Consuming r (Producing (Fst downI) (Snd downI) m) (Fst upI) (Snd upI) }

type family Fst (xy :: (*,*)) :: *
type family Snd (xy :: (*,*)) :: *
type instance Fst '(x,y) = x
type instance Snd '(x,y) = y

($=) :: Monad m => Producing a b m r -> Proxy r m '(a,b) '(c,d) -> Producing c d m r
producing $= Proxy proxy = insert1 producing $$ proxy

Proxies have two interfaces, a "downstream" interface, and an "upstream" interface. We can connect a proxy to a Producing coroutine via the proxy's upstream interface (also its outer interface, which is in a state of Consuming). I gave Proxy a rather unsightly definition, which allows us to write each interface as a tuple. (This requires DataKinds, KindSignatures, and TypeFamilies language extensions.) The reason for this is so that we can (once ghc-7.8 is finished) write the Category instance for Proxy. We'll talk more about this later.

Producing layers commute

On the topic of two interfaces, when thinking about it from the "enhanced language" perspective, it seems intuitive that Producing a b (Producing c d m) r is the same as Producing c d (Producing a b m) r. And it is!

-- show given this (puzzle pieces)
{-# LANGUAGE ScopedTypeVariables #-} -- this comes in handy
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE KindSignatures #-}

import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Morph (MFunctor, hoist)

data Producing o i (m :: * -> *) r -- don't rely on the internals of this
instance (Monad m) => Monad (Producing o i m) where
instance MonadTrans (Producing o i) where
instance MFunctor (Producing o i) where

newtype Consuming r m i o
  = Consuming { provide :: i -> Producing o i m r }

infixl 0 $$
($$) :: Monad m => Producing a b m r -> Consuming r m a b -> m r
producing $$ consuming = undefined -- take this as a given

-- The proxy newtype was left out for simplicity
idProxy :: Monad m => Consuming r (Producing a b m) a b
idProxy = undefined -- take this as a given
-- bonus: implement this by also assuming yield as a given

insert0 :: Monad m =>
  m r -> Producing a b m r
insert0 = lift

insert1 :: (MFunctor t, Monad m) =>
  t m r -> t (Producing a b m) r
insert1 = hoist insert0

insert2 :: (MFunctor t, MFunctor t2, Monad m, Monad (t m)) =>
  t2 (t m) r -> t2 (t (Producing a b m)) r
insert2 = hoist insert1

-- show implement this (the puzzle)
commute :: forall a b c d m r. Monad m =>
  Producing a b (Producing c d m) r -> Producing c d (Producing a b m) r
commute p = p' $$ funnel where
  -- what types should p' and funnel have? (leverage scoped type variables)
  p' :: ()
  p' = undefined
  funnel :: ()
  funnel = undefined
  -- types hint: remember, $$ removes the outermost interface
  -- implementation hint: use insert0/1/2 with p and idProxy

-- show and see if it compiles. Type tetris is fun!
main = putStrLn "It compiles!"

commute :: forall a b c d m r. Monad m =>
  Producing a b (Producing c d m) r -> Producing c d (Producing a b m) r
commute p = p' $$ funnel where
  p' :: Producing a b (Producing c d (Producing a b m)) r
  p' = insert2 p
  funnel :: Consuming r (Producing c d (Producing a b m)) a b
  funnel = Consuming (insert1 . provide idProxy)

Cool! With clever use of insert1 and friends, we see that coroutine interface layers commute.

More implementation

Now that we have $$, and commute at our disposal, we have the high-level tools we need to implement =$ and =$= as well. Go ahead, give it a shot!

-- show given this
{-# LANGUAGE ScopedTypeVariables #-} -- this comes in handy
{-# LANGUAGE EmptyDataDecls, KindSignatures #-}
{-# LANGUAGE DataKinds, TypeFamilies #-}

import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Morph (MFunctor, hoist)

data Producing o i (m :: * -> *) r -- don't rely on the internals of this
instance (Monad m) => Monad (Producing o i m) where
instance MonadTrans (Producing o i) where
instance MFunctor (Producing o i) where

newtype Consuming r m i o
  = Consuming { provide :: i -> Producing o i m r }

newtype Proxy r m upI downI
  = Proxy { unProxy :: Consuming r (Producing (Fst downI) (Snd downI) m) (Fst upI) (Snd upI) }

type family Fst (xy :: (*,*)) :: *
type family Snd (xy :: (*,*)) :: *
type instance Fst '(x,y) = x
type instance Snd '(x,y) = y

infixl 0 $$
($$) :: Monad m => Producing a b m r -> Consuming r m a b -> m r
producing $$ consuming = undefined -- take this as a given

commute :: Monad m => Producing a b (Producing c d m) r
                   -> Producing c d (Producing a b m) r
commute = undefined -- take this as a given

insert0 :: Monad m =>
  m r -> Producing a b m r
insert0 = lift

insert1 :: (MFunctor t, Monad m) =>
  t m r -> t (Producing a b m) r
insert1 = hoist insert0

insert2 :: (MFunctor t, MFunctor t2, Monad m, Monad (t m)) =>
  t2 (t m) r -> t2 (t (Producing a b m)) r
insert2 = hoist insert1

-- show implement these
(=$) :: forall a b c d m r. Monad m =>
  Proxy r m '(a,b) '(c,d) -> Consuming r m c d -> Consuming r m a b
Proxy proxy =$ consuming = Consuming $ \(a :: a) ->
  let
    p :: ()
    p = undefined
    c :: ()
    c = undefined
  in
    p $$ c

(=$=) :: forall a a' b b' c c' m r. Monad m =>
  Proxy r m '(a,a') '(b,b') -> Proxy r m '(b,b') '(c,c') -> Proxy r m '(a,a') '(c,c')
Proxy proxyl =$= Proxy proxyr = Proxy $ Consuming $ \(a :: a) ->
  let
    p :: ()
    p = undefined
    c :: ()
    c = undefined
  in
    p $$ c

-- show and see if it compiles.
main = putStrLn "It compiles!"

(=$) :: forall a b c d m r. Monad m =>
  Proxy r m '(a,b) '(c,d) -> Consuming r m c d -> Consuming r m a b
Proxy proxy =$ consuming = Consuming $ \(a :: a) ->
  let
    p :: Producing c d (Producing b a m) r
    p = commute (provide proxy a)
    c :: Consuming r (Producing b a m) c d
    c = Consuming (insert1 . provide consuming)
  in
    p $$ c

(=$=) :: forall a a' b b' c c' m r. Monad m =>
  Proxy r m '(a,a') '(b,b') -> Proxy r m '(b,b') '(c,c') -> Proxy r m '(a,a') '(c,c')
Proxy proxyl =$= Proxy proxyr = Proxy $ Consuming $ \(a :: a) ->
  let
    p :: Producing b b' (Producing a' a (Producing c c' m)) r
    p = insert2 (commute (provide proxyl a))
    c :: Consuming r (Producing a' a (Producing c c' m)) b b'
    c = Consuming $ insert1 . provide proxyr
  in
    p $$ c