Skip to content

Instantly share code, notes, and snippets.

@pcapriotti
Created February 7, 2012 18:30
Show Gist options
  • Save pcapriotti/1761136 to your computer and use it in GitHub Desktop.
Save pcapriotti/1761136 to your computer and use it in GitHub Desktop.
Composition of free monads
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment