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:
{-# 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