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)

(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