Applying Semantics to Free Monads

Question

I am trying to abstract the pattern of applying a certain semantics to a free monad over some functor. The running example I am using to motivate this is applying updates to an entity in a game. So I import a few libraries and define a few example types and an entity class for the purposes of this example (I am using the free monad implementation in control-monad-free):

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Monad.Free
import Control.Monad.Identity
import Control.Monad.Writer

-- Things which can happen to an entity
data Order = Order deriving Show
data Damage = Damage deriving Show

class Entity a where
    evolve :: Double -> a -> a
    order :: Order -> a -> a
    damage :: Damage -> a -> a

-- Make a trivial entity for testing purposes
data Example = Example deriving Show
instance Entity Example where
    evolve _ a = a
    order _ a = a
    damage _ a = a

-- A type to hold all the possible update types
data EntityUpdate = 
      UpdateTime Double
    | UpdateOrder Order
    | UpdateDamage Damage
    deriving (Show)

-- Wrap UpdateMessage to create a Functor for constructing the free monad
data UpdateFunctor cont = 
    UpdateFunctor {updateMessage :: EntityUpdate, continue :: cont} deriving (Show, Functor)

-- Type synonym for the free monad
type Update = Free UpdateEntity

I now lift some basic updates into the monad:

liftF = wrap . fmap Pure

updateTime :: Double -> Update ()
updateTime t = liftUpdate $ UpdateTime t

updateOrder :: Order -> Update ()
updateOrder o = liftUpdate $ UpdateOrder o

updateDamage :: Damage -> Update ()
updateDamage d = liftUpdate $ UpdateDamage d

test :: Update ()
test = do
    updateTime 8.0
    updateOrder Order
    updateDamage Damage
    updateTime 4.0
    updateDamage Damage
    updateTime 6.0
    updateOrder Order
    updateTime 8.0

Now we have the free monad, we need to provide the possibility of different implementations, or semantic interpretations, of monad instance such as test above. The best pattern I can come up with for this is given by the following function:

interpret :: (Monad m, Functor f, fm ~ Free f c) => (f fm -> fm) -> (f fm -> a -> m a) -> fm -> a -> m a
interpret _ _ (Pure _  ) entity = return entity
interpret c f (Impure u) entity = f u entity >>= interpret c f (c u)

Then with some basic semantic functions we can give the two following possible interpretations, one as a basic evaluation and one as a writer monad preforming logging:

update (UpdateTime t) = evolve t
update (UpdateOrder o) = order o
update (UpdateDamage d) = damage d

eval :: Entity a => Update () -> a -> a
eval updates entity = runIdentity $ interpret continue update' updates entity where
    update' u entity = return $ update (updateMessage u) entity

logMessage (UpdateTime t) = "Simulating time for " ++ show t ++ " seconds.\n"
logMessage (UpdateOrder o) = "Giving an order.\n"
logMessage (UpdateDamage d) = "Applying damage.\n"

evalLog :: Entity a => Update () -> a -> Writer String a
evalLog = interpret continue $ \u entity -> do
    let m = updateMessage u
    tell $ logMessage m
    return $ update m entity

Testing this in GHCI:

> eval test Example
Example
> putStr . execWriter $ evalLog test Example
Simulating time for 8.0 seconds.
Giving an order.
Applying damage.
Simulating time for 4.0 seconds.
Applying damage.
Simulating time for 6.0 seconds.
Giving an order.
Simulating time for 8.0 seconds.

This all works fine, but it gives me a slightly uneasy feeling that it could be more general, or could be better organised. Having to provide a function to provide the continuation wasn't obvious at first and I'm not sure it is the best approach. I have made several efforts to redefine interpret in terms of functions in the Control.Monad.Free module, such as foldFree and induce. But they all seem to not quite work.

Am I on the right lines with this, or am a making a misjudgement? Most of the articles on free monads I have found concentrate on their efficiency or different ways to implement them, rather than on patterns for actually using them like this.

It also seems desirable to encapsulate this in some kind of Semantic class, so I could simply make different monad instances from my free monad by wrapping the functor in a newtype and making it an instance of this class. I couldn't quite work out how to do this however.

UPDATE --

I wish I could have accepted both answers as they are both extremely informative and thoughtfully written. In the end though, the edit to the accepted answer contains the function I was after:

interpret :: (Functor m, Monad m) => (forall x. f x -> m x) -> Free f a -> m a
interpret evalF = retract . hoistFree evalF

(retract and hoistFree are in Edward Kemmet's free package in Control.Monad.Free).

All three of pipes, operational and sacundim's free-operational package are very relevant and look like they will be very useful for me in the future. Thank you all.

Answer 1

You can use my pipes library, which provides higher level abstractions for working with free monads.

pipes uses free monads to reify every part of the computation:

• The Producer of data (i.e. your update) is a free monad
• The Consumer of data (i.e. your interpreter) is a free monad
• The Pipe of data (i.e. your logger) is a free monad

In fact, they are not three separate free monads: they are all the same free monad in disguise. Once you define all three of them you connect them using pipe composition, (>->), in order to start streaming data.

I'll begin with a slightly modified version of your example that skips the type class you wrote:

{-# LANGUAGE RankNTypes #-}

import Control.Lens
import Control.Proxy
import Control.Proxy.Trans.State
import Control.Monad.Trans.Writer

data Order  = Order deriving (Show)
data Damage = Damage deriving (Show)

data EntityUpdate
    = UpdateTime   Double
    | UpdateOrder  Order
    | UpdateDamage Damage
    deriving (Show)

Now what we do is define an Update to be a Producer of EntityUpdates:

type Update r = forall m p . (Monad m, Proxy p) => Producer p EntityUpdate m r

Then we define the actual commands. Each command yields the corresponding update using the respond pipe primitive, which sends the data further downstream for processing.

updateTime :: Double -> Update ()
updateTime t = respond (UpdateTime t)

updateOrder :: Order -> Update ()
updateOrder o = respond (UpdateOrder o)

updateDamage :: Damage -> Update ()
updateDamage d = respond (UpdateDamage d)

Since a Producer is a free monad, we can assemble it using do notation just like you did for your test function:

test :: () -> Update ()
-- i.e. () -> Producer p EntityUpdate m ()
test () = runIdentityP $ do
    updateTime 8.0
    updateOrder Order
    updateDamage Damage
    updateTime 4.0
    updateDamage Damage
    updateTime 6.0
    updateOrder Order
    updateTime 8.0

However, we can reify the interpreter as a Consumer of data, too. This is nice because we can then directly layer on state over the interpreter instead of using the Entity class you defined.

I'll use a simple state:

data MyState = MyState { _numOrders :: Int, _time :: Double, _health :: Int }
    deriving (Show)

begin :: MyState
begin= MyState 0 0 100

... and define some convenient lenses for clarity:

numOrders :: Lens' MyState Int
numOrders = lens _numOrders (\s x -> s { _numOrders = x})

time :: Lens' MyState Double
time = lens _time (\s x -> s { _time = x })

health :: Lens' MyState Int
health = lens _health (\s x -> s { _health = x })

... and now I can define a stateful interpreter:

eval :: (Proxy p) => () -> Consumer (StateP MyState p) EntityUpdate IO r
eval () = forever $ do
    entityUpdate <- request ()
    case entityUpdate of
        UpdateTime   tDiff -> modify (time      +~ tDiff)
        UpdateOrder  _     -> modify (numOrders +~ 1    )
        UpdateDamage _     -> modify (health    -~ 1    )
    s <- get
    lift $ putStrLn $ "Current state is: " ++ show s

That makes it much more clear what the interpreter is doing. We can see at a glance how it processes incoming values in a stateful way.

To connect our Producer and Consumer we use the (>->) composition operator, followed by runProxy, which transforms our pipeline back to the base monad:

main1 = runProxy $ evalStateK begin $ test >-> eval

... which produces the following result:

>>> main1
Current state is: MyState {_numOrders = 0, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 98}
Current state is: MyState {_numOrders = 1, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 26.0, _health = 98}

You might wonder why we have to do this in two steps. Why not just get rid of the runProxy part?

The reason why is that we may wish to compose more than two things. For example, we can very easily insert a logging stage in between test and eval. I call these intermediate stages Pipes:

logger
    :: (Monad m, Proxy p)
    => () -> Pipe p EntityUpdate EntityUpdate (WriterT String m) r
logger () = runIdentityP $ forever $ do
    entityUpdate <- request ()
    lift $ tell $ case entityUpdate of
        UpdateTime   t -> "Simulating time for " ++ show t ++ " seconds.\n"
        UpdateOrder  o -> "Giving an order.\n"
        UpdateDamage d -> "Applying damage.\n"
    respond entityUpdate

Again, we can very clearly see what logger does: It requests a value, tells a representation of the value, and then passes the value further downstream using respond.

We can insert this in between test and logger. The only thing we must be aware of is that all stages must have the same base monad, so we use raiseK to insert a WriterT layer for eval so that it matches the base monad of logger:

main2 = execWriterT $ runProxy $ evalStateK begin $
    test >-> logger >-> raiseK eval

... which produces the following result:

>>> main2
Current state is: MyState {_numOrders = 0, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 98}
Current state is: MyState {_numOrders = 1, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 26.0, _health = 98}
"Simulating time for 8.0 seconds.\nGiving an order.\nApplying damage.\nSimulating time for 4.0 seconds.\nApplying damage.\nSimulating time for 6.0 seconds.\nGiving an order.\nSimulating time for 8.0 seconds.\n"

pipes was designed to solve exactly the kind of problem you describe. A lot of the time we want to reify not only the DSL that generates the data, but the interpreters and intermediate processing stages, too. pipes treats all of these concepts identically and models all of them as connectable stream DSLs. This makes it very easy to swap in and out various behaviors without having to define your own custom interpreter framework.

If you are new to pipes, then you might want to check out the tutorial.

Answer 2

I don't quite understand your example, but I think you are basically reconstructing the operational package in here. Your EntityUpdate type is very much like an instruction set in the sense of operational, and your UpdateFunctor is something like the free functor over the instruction set—which is precisely the construction that relates operational and free monads. (See "Is operational really isomorphic to a free monad?" and this Reddit discussion).

But anyway, the operational package has the function you want, interpretWithMonad:

interpretWithMonad :: forall instr m b.
                      Monad m => 
                      (forall a. instr a -> m a) 
                   -> Program instr b
                   -> m b

This allows you to provide a function that interprets each of the instructions in your program (each EntityUpdate value) as a monadic action, and takes care of the rest.

If I may be allowed a tad of self-promotion, I was just recently writing my own version of operational using free monads, because I wanted to have an Applicative version of operational's Program type. Since your example struck me as being purely applicative, I went through the exercise of writing your evalLog in terms of my library, and I might as well paste it here. (I couldn't understand your eval function.) Here goes:

{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes #-}

import Control.Applicative
import Control.Applicative.Operational
import Control.Monad.Writer

data Order = Order deriving Show
data Damage = Damage deriving Show

-- UpdateI is short for "UpdateInstruction"
data UpdateI a where
    UpdateTime   :: Double -> UpdateI ()
    UpdateOrder  :: Order -> UpdateI ()
    UpdateDamage :: Damage -> UpdateI ()

type Update = ProgramA UpdateI

updateTime :: Double -> Update ()
updateTime = singleton . UpdateTime

updateOrder :: Order -> Update ()
updateOrder = singleton . UpdateOrder

updateDamage :: Damage -> Update ()
updateDamage = singleton . UpdateDamage

test :: Update ()
test = updateTime 8.0 
    *> updateOrder Order
    *> updateDamage Damage
    *> updateTime 4.0
    *> updateDamage Damage
    *> updateTime 6.0
    *> updateOrder Order
    *> updateTime 8.0

evalLog :: forall a. Update a -> Writer String a
evalLog = interpretA evalI
    where evalI :: forall x. UpdateI x -> Writer String x
          evalI (UpdateTime t) = 
              tell $ "Simulating time for " ++ show t ++ " seconds.\n"
          evalI (UpdateOrder Order) = tell $ "Giving an order.\n"
          evalI (UpdateDamage Damage) = tell $ "Applying damage.\n"

Output:

*Main> putStr $ execWriter (evalLog test)
Simulating time for 8.0 seconds.
Giving an order.
Applying damage.
Simulating time for 4.0 seconds.
Applying damage.
Simulating time for 6.0 seconds.
Giving an order.
Simulating time for 8.0 seconds.

The trick here is the same as in the interpretWithMonad function from the original package, but adapted to applicatives:

interpretA :: forall instr f a. Applicative f =>
              (forall x. instr x -> f x)
           -> ProgramA instr a -> f a

If you truly need a monadic interpretation it's just a mater of importing Control.Monad.Operational (either the original one or mine) instead of Control.Applicative.Operational, and using Program instead of ProgramA. ProgramA however gives you greater power to examine the program statically:

-- Sum the total time requested by updateTime instructions in an
-- applicative UpdateI program.  You can't do this with monads.
sumTime :: ProgramA UpdateI () -> Double
sumTime = sumTime' . viewA 
    where sumTime' :: forall x. ProgramViewA UpdateI x -> Double
          sumTime' (UpdateTime t :<**> k) = t + sumTime' k
          sumTime' (_ :<**> k) = sumTime' k
          sumTime' (Pure _) = 0

Example usage of sumTime:

*Main> sumTime test
26.0

---

EDIT: In retrospect, I should have provided this shorter answer. This assumes you're using Control.Monad.Free from Edward Kmett's package:

interpret :: (Functor m, Monad m) =>
             (forall x. f x -> m x) 
          -> Free f a -> m a
interpret evalF = retract . hoistFree evalF