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

👍