Exploring Free Monads, Cofree Comonads, and Pairings: DSLs and Interpreters

FreeCoFree.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-

Explores Free Monads (DSLs) and Cofree Comonads (interpreters) and
their relationship.

Most of the code in this file comes from (1) below. Only minor
modifications are made - semantics are preserved.

Resources:

1. Free for DSLs, cofree for interpreters: http://dlaing.org/cofun/posts/free_and_cofree.html
2. Why free monads matter: http://www.haskellforall.com/2012/06/you-could-have-invented-free-monads.html
3. Purify code using free monads: http://www.haskellforall.com/2012/07/purify-code-using-free-monads.html
4. Cofree meets free: http://blog.sigfpe.com/2014/05/cofree-meets-free.html
5. Cofree meets free (notes): http://kovach.me/notes/2014-08-14-cofree.html
6. Free Monads are Simple: http://underscore.io/blog/posts/2015/04/14/free-monads-are-simple.html
7. The Monad Called Free: http://blog.sigfpe.com/2014/04/the-monad-called-free.html
8. Type Families Make Life and Free Monads Simpler: http://aaronlevin.ca/post/106721413033/type-families-make-life-and-free-monads-simpler

-}
module Free where

import Control.Applicative
import Control.Monad
import Control.Monad.Identity

--------------------------------------------------------------------------------
                           -- Free Monad --
--------------------------------------------------------------------------------
-- Free monad core type
data Free f r
  = Free (f (Free f r))
  | Pure r

-- Functor over free monad
instance (Functor f) => Functor (Free f) where
  fmap f (Free fx) = Free (fmap f <$> fx)
  fmap f (Pure x)  = Pure (f x)

-- Applicative instance to make GHC 7.10 happy
instance (Functor f) => Applicative (Free f) where
  pure = Pure
  (<*>) = ap

-- Free monad construction
instance (Functor f) => Monad (Free f) where
  return = Pure
  (Free x) >>= f = Free (fmap (>>= f) x)
  (Pure r) >>= f = f r

-- Lifts operations into Free
liftF :: Functor f => f r -> Free f r
liftF x = Free (fmap Pure x)

--------------------------------------------------------------------------------
            -- Adder DSL, Free Monad, Ad-Hoc Intepreter --
--------------------------------------------------------------------------------
-- The adder DSL
data AdderF k
  = Add Int (Bool -> k)
  | Clear k
  | Total (Int -> k)

-- Manual functor instance for fun: could just 'deriving Functor'
instance Functor AdderF where
  fmap f (Add b k) = Add b (f . k)
  fmap f (Clear k) = Clear (f k)
  fmap f (Total k) = Total (f . k)

type Adder a = Free AdderF a

-- convenience functions for working with Adder DSL
add :: Int -> Adder Bool
add x = liftF $ Add x id

clear :: Adder ()
clear = liftF $ Clear ()

total :: Adder Int
total = liftF $ Total id

-- safety: distinguish Count from Limit
newtype Limit = Limit Int
newtype Count = Count Int

-- ad-hoc interpreter
eval :: Limit -> Count -> Adder r -> r
eval (Limit limit) (Count count) a =
  case a of
    (Pure r) -> r
    (Free (Add x k)) ->
      let count' = count + x
          test = count' <= limit
          next = if test then count' else count
      in eval (Limit limit) (Count next) (k test)
    (Free (Clear x)) -> eval (Limit limit) (Count 0) x
    (Free (Total x)) -> eval (Limit limit) (Count count) (x count)

--------------------------------------------------------------------------------
                      -- Cofree and Comonads --
--------------------------------------------------------------------------------
-- Duplicated for convenience: Available under free on Hackage.
data Cofree f a = a :< f (Cofree f a) deriving Functor

-- Duplicated for convenience. Available under comonad on Hackage.
class Functor w => Comonad w where
  extract :: w a -> a
  duplicate :: w a -> w (w a)

instance Functor f => Comonad (Cofree f) where
  extract (a :< _) = a
  duplicate c@(_ :< fs) = c :<  fmap duplicate fs

coiter :: Functor f => (a -> f a) -> a -> Cofree f a
coiter next start = start :< (coiter next <$> next start)

-- Comonad for Adder DSL
data CoAdderF k =
  CoAdderF { addH :: Int -> (Bool, k)
           , clearH :: k
           , totalH :: (Int, k)
           }

instance Functor CoAdderF where
  fmap f (CoAdderF a c t) = CoAdderF (fmap (fmap f) a) (f c) (fmap f t)

type CoAdder a = Cofree CoAdderF a

-- Comonadic machinery for CoAdder
mkCoAdder :: Limit -> Count -> CoAdder (Int, Int)
mkCoAdder (Limit limit) (Count count) = coiter next start
  where next w = CoAdderF (coAdd w) (coClear w) (coTotal w)
        start = (limit, count)

coClear :: (Int, Int) -> (Int, Int)
coClear (limit, _) = (limit, 0)

coTotal :: (Int, Int) -> (Int, (Int, Int))
coTotal (limit, count) = (count, (limit, count))

coAdd :: (Int, Int) -> Int -> (Bool, (Int, Int))
coAdd (limit, count) x = (test, (limit, next))
  where count' = count + x
        test = count' <= limit
        next = if test then count' else count

--------------------------------------------------------------------------------
            -- Pairing Free Monads and Cofree Comonads --
--------------------------------------------------------------------------------
class (Functor f, Functor g) => Pairing f g where
  pair :: (a -> b -> r) -> f a -> g b -> r

instance Pairing Identity Identity where
  pair f (Identity a) (Identity b) = f a b

instance Pairing ((->) a) ((,) a) where
  pair p f = uncurry (p . f)

instance Pairing ((,) a) ((->) a) where
  pair p f g = p (snd f) (g (fst f))

{-

"The Pairing is what allows us to define our DSL and interpreter
independently from one another while still being able to bring them
together like this." - (1)

-}
instance Pairing f g => Pairing (Cofree f) (Free g) where
  pair p (a :< _) (Pure x) = p a x
  pair p (_ :< fs) (Free gs) = pair (pair p) fs gs

instance Pairing CoAdderF AdderF where
  pair f (CoAdderF a _ _) (Add x k) = pair f (a x) k
  pair f (CoAdderF _ c _) (Clear k) = f c k
  pair f (CoAdderF _ _ t) (Total k) = pair f t k

--------------------------------------------------------------------------------
                     -- Trying the Pieces Out --
--------------------------------------------------------------------------------
-- composing programs in the Adder DSL
program :: Adder Int
program = add 3 >> add 4 >> total

runProgram :: CoAdder a -> Int
runProgram w = pair (\_ b -> b) w program

-- a simple main putting together Free w/ ad-hoc interpretation
main :: IO ()
main = print (
    runProgram (mkCoAdder limit count)  -- comonadically
  , eval limit count program            -- ad-hoc interpreter
  )
  where limit = Limit 200
        count = Count 20

Most of this is available here, if you want to save some typing.

In general, I'll be making sure the code in the repo is at least up to date with whatever is mentioned in the associated blog posts.