Example for writing a small interpreted language using Free monads

FreeNotAsInBeer.hs

{-
Copyright 2016 Google Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Free
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.State as State

-- | A small language capable of storing and asking for integers.
-- The list of instructions is bounded only by our imagination - in this case
-- our imagination is pretty poor.
data Cmd a
    = Emit Int a
    | Pull (Int -> a)
    deriving Functor

-- | Sample program. Observe how the type depends on the number of
-- instructions.
nonFreeProgram :: Cmd (Cmd (Cmd ()))
nonFreeProgram = Emit 5 (Pull (\k -> Emit (2*k) ()))

-- Now let's wrap in a Free monad, to keep the type signature fixed, regardless
-- of instruction count. It also gives us monad syntax for (almost) free.
-- Actually that would be too easy, so we wrap it in FreeT which also lets
-- interleaving other monadic effects - in our sample program below we'll use
-- it for IO.

-- See https://hackage.haskell.org/package/free-4.12.4/docs/Control-Monad-Trans-Free.html
type CmdM = FreeT Cmd

emit :: (Monad m) => Int -> CmdM m ()
emit x = liftF (Emit x ())
-- liftF is shorthand for writing out with hand:
-- emit x = return (Free (Emit x (return (Pure ()))))

pull :: (Monad m) => CmdM m Int
pull = liftF (Pull id)

-- | Sample program, revisited.
freeProgram :: (MonadIO m) => CmdM m ()
freeProgram = do
    emit 5
    x <- pull
    liftIO (putStrLn ("[Debug] Got " ++ show x))
    emit (2 * x)

type App = StateT Int IO

-- | This is the interpreter for our language, here in the specific App
-- context. We could have different interpreters working in different contexts.
-- For example, we don't have to keep a state, we can just always give the
-- program 42 when it asks a number - though keep in mind that programs might
-- have expectations on the semantics of the operations, which we should have
-- documented.
runProg :: CmdM App a -> App a
runProg = iterT go
  where
    go (Emit x k) = State.put x >> k
    go (Pull k) = State.get >>= k

main1 = do
    putStrLn "\n*** Running program 1 **"
    -- Tear down all the layers.
    res <- runStateT (runProg freeProgram) 0
    putStrLn ("Result is: " ++ show res)

-- A program using multiple contexts simultaneously.

type Two m = CmdM (CmdM m)

twoContexts :: Two IO ()
twoContexts = do
    a <- pull
    b <- lift pull
    lift (emit (a + b))
    liftIO (putStrLn "[Debug] Finished")

-- For simplicity this interpreter spares the state, and return the context
-- number on pull. Emit just logs.
runTwo :: Two IO a -> IO a
runTwo = iterT (go 2) . iterT (go 1)
  where
    go :: forall m a . (MonadIO m) => Int -> Cmd (m a) -> m a
    go c i = case i of
        Emit x k -> log ("program emits " ++ show x) >> k
        Pull k   -> log ("program pulls") >> k c
      where
        log s = liftIO (putStrLn ("[Interpreter Ctx#" ++ show c ++ "] " ++ s))

main2 = do
    putStrLn "\n*** Running program 2 (two contexts) ***"
    runTwo twoContexts

main = do
    main1
    main2

Output is:

*** Running program 1 **
[Debug] Got 5
Result is: ((),10)

*** Running program 2 (two contexts) ***
[Interpreter Ctx#1] program pulls
[Interpreter Ctx#2] program pulls
[Interpreter Ctx#2] program emits 3
[Debug] Finished