Composition of free monads

gistfile1.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

import Control.Monad
import Control.Monad.Free

class (Functor f, Functor g, Functor h) => Compose f g h | f g -> h where
  compose :: f x -> g y -> Free h (Free f x, Free g y)
  compose f g = return (liftF f, liftF g)

composeF :: Compose f g h => Free f x -> Free g x -> Free h x
composeF (Pure r) p2 = Pure r
composeF p1 (Pure r) = Pure r
composeF (Free f) (Free g) = do
  (p1, p2) <- compose f g
  composeF (join p1) (join p2)

data PipeF a b m x
  = Yield b x
  | Await (a -> x)
  | M (m x)

instance Monad m => Functor (PipeF a b m) where
  fmap f (Yield b x) = Yield b (f x)
  fmap f (Await k) = Await $ f . k
  fmap f (M m) = M $ liftM f m

type Pipe a b m r = Free (PipeF a b m) r

instance Monad m => Compose (PipeF a b m) (PipeF b c m) (PipeF a c m) where
  compose p1 (Yield c y) = liftF $ Yield c (liftF p1, return y)
  compose p1 (M m) = liftF . M $ m >>= \y -> return (liftF p1, return y)
  compose (M m) p2 = liftF . M $ m >>= \x -> return (return x, liftF p2)
  compose (Yield b x) (Await k) = return $ (return x, return $ k b)
  compose (Await k) p2 = liftF $ Await $ \x -> (return $ k x, liftF p2)

(>+>) :: Monad m => Pipe a b m r -> Pipe b c m r -> Pipe a c m r
(>+>) = composeF