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
| 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)
| 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)
• 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 KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}

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

-- | 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

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 ()
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)

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

interpretG a@(Look dir)    = logAction a (return Image)
interpretG a@(Fire dir)    = logAction a (return ())
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