Free Monads from Functors from GADTs

comments on reddit

In 2012, Gabriel Gonzalez wrote a popular blog post on how free monads and interpreters make for cheap DSLs. I played with it (and I also tried to understand comonadic interpreters, which helped my understanding) and noticed there is more to factor out, so we have a little less to do each time we create a new DSL.

At the core of each DSL is an algebraic datatype which defines the possible actions. This is the example from the post:

data Interaction next =
    Look Direction (Image -> next)
  | Fire Direction next
  | ReadLine (String -> next)
  | WriteLine String (Bool -> next)

There is a little irregularity between the individual cases' last fields. All cases except Fire have as the last field functions from what the case is supposed to “return” when interpreted, to next. The Fire action has no meaningful return value, so there is no function but simply a next value.

As a result, writing interpreters over Free Interaction r is less straightforward than it could be (bear in mind this is only a toy example).

interpret :: Free Interaction r -> Game r
interpret (Free (Look dir g))    = collectImage dir >>= interpret . g
interpret (Free (Fire dir next)) = sendBullet dir   >>  interpret next
interpret (Free (ReadLine g))    = getChatLine      >>= interpret . g
interpret (Free (WriteLine s g)) = putChatLine      >>= interpret . g
interpret (Pure r)               = return r

Note how we need to make sure we don't forget to interpret the next part each time (that's because we write this definition in Free Interaction r instead of simply in Interaction a), and how the Fire case is different because its last member is not a function.

We can fix the irregularity by replacing the last member of the Fire case with a function from ():

data Interaction next
    = Look Direction   (Image  -> next)
    | Fire Direction   (()     -> next)
    | ReadLine         (String -> next)
    | WriteLine String (Bool   -> next)

But the (_ -> next) part in each case is still redundancy. Here is some code which shows what more can be factored out. Overview:

• Define DSL as GADT of kind * -> * (no Functor instance required)
• Define how to get from GADT to execution monad
• And with some reusable code we get an interpreter:
  • Wrapper type to automatically extend GADT to a functor
  • Interpretation from the functor to the execution monad is inferred
  • Interpretation from the free monad over the functor to the execution monad is inferred

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}

import Control.Monad (join)

{-
    2015-11-07:
      - Code cleanup. Rename Interpreter to FunctorInterpreter and
      - WrappedInterpreter to GADTInterpreter
-}

-- | Standard Free Monad theme

data Free f a = Pure a | Free (f (Free f a)) deriving (Functor)

instance Functor f => Monad (Free f) where
    return = Pure
    m >>= f = join' (fmap f m) where
        join' (Pure m) = m
        join' (Free m) = Free (fmap join' m)

-- | Reusable bits

class (Functor m, Monad m) => GADTInterpreter t m where
    interpretG :: t a -> m a

class (Functor f, Monad m) => FunctorInterpreter f m where
    interpretF :: f a -> m a

data Wrap t next = forall a . Wrap (t a) (a -> next)

instance Functor (Wrap t) where
    fmap f (Wrap t g) = Wrap t (f . g)

instance GADTInterpreter t m => FunctorInterpreter (Wrap t) m where
    interpretF (Wrap t f) = fmap f (interpretG t)

interpret :: (FunctorInterpreter f m) => Free f a -> m a
interpret (Pure a) = return a
interpret (Free f) = join (interpretF (fmap interpret f))

liftF :: (Functor f) => f a -> Free f a
liftF f = Free (fmap Pure f)

liftW :: t a -> Free (Wrap t) a
liftW t = liftF (Wrap t id)

-- | mini language

data Direction = Up | Down deriving (Show)
data Image = Image deriving (Show)

data InteractionG :: * -> * where
    Look      :: Direction -> InteractionG Image
    Fire      :: Direction -> InteractionG ()
    ReadLine  ::              InteractionG String
    WriteLine :: String    -> InteractionG ()

deriving instance Show (InteractionG a)

type Interaction = Wrap InteractionG

look :: Direction -> Free Interaction Image
look dir = liftW (Look dir)

fire :: Direction -> Free Interaction ()
fire dir = liftW (Fire dir)

readline :: Free Interaction String
readline = liftW (ReadLine)

writeline :: String -> Free Interaction ()
writeline s = liftW (WriteLine s)

-- | interpret mini language programs in the IO monad

logAction :: (Show a) => InteractionG a -> IO a -> IO a
logAction a io = do
    r <- io
    putStrLn $ show r ++ " <- " ++ show a
    return r

instance GADTInterpreter InteractionG IO where
    interpretG a@(Look dir)    = logAction a (return Image)
    interpretG a@(Fire dir)    = logAction a (return ())
    interpretG a@(ReadLine)    = logAction a (readLn)
    interpretG a@(WriteLine s) = logAction a (putStrLn ("(write " ++ s ++ ")"))

-- | program written in mini language

program :: Free Interaction ()
program = do
    img <- look Up
    writeline (show img)

main = interpret program

Created: 2015-07-12
Last Updated: 2015-11-07