Skip to content

Instantly share code, notes, and snippets.

@queertypes
Created June 5, 2015 17:11
Show Gist options
  • Save queertypes/c1464518e554341bf578 to your computer and use it in GitHub Desktop.
Save queertypes/c1464518e554341bf578 to your computer and use it in GitHub Desktop.
Exploring Free Monads, Cofree Comonads, and Pairings: DSLs and Interpreters
{-# 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
@dalaing
Copy link

dalaing commented Jun 15, 2015

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.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment