Skip to content

Instantly share code, notes, and snippets.

@danstn
Last active January 4, 2017 01:14
Show Gist options
  • Star 1 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
  • Save danstn/9ea544a77060fa2cbc05 to your computer and use it in GitHub Desktop.
Save danstn/9ea544a77060fa2cbc05 to your computer and use it in GitHub Desktop.
An example of using Free Monads for writing custom AST/DSL and its interpreters.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
import Prelude
import Data.String
import Control.Monad.Free
type Program a r = Free (AST a) r
data AST a next =
Output a next
| Bell next
| End
deriving Functor
-- DSL API
output :: a -> Program a ()
output x = liftF (Output x ())
bell :: Program a ()
bell = liftF (Bell ())
end :: Program a ()
end = liftF End
-- Interpreters
showProgram :: (Show a, Show r) => Program a r -> String
showProgram (Free (Output a x)) = "output " ++ show a ++ "\n" ++ showProgram x
showProgram (Free (Bell x)) = "bell\n" ++ showProgram x
showProgram (Free End) = "PROGRAM TERMINATED\n"
showProgram (Pure r) = "return " ++ show r ++ "\n"
prettyPrint :: (Show a, Show r) => Program a r -> IO ()
prettyPrint = putStr . showProgram
interpret :: (Show a, Show r) => Program a r -> IO ()
interpret (Free (Output a x)) = print a >> interpret x
interpret (Free (Bell x)) = putStrLn "Ding-Ding!" >> interpret x
interpret (Free End) = return ()
interpret (Pure r) = print (show r)
-- Sample programs
p1 :: Program String ()
p1 = output "hello" >> bell >> end
p2 :: Program String ()
p2 = output "hello2" >> bell >> bell >> end
p3 :: Program String ()
p3 = bell >> output "wow!" >> end >> bell >> bell
main :: IO ()
main = do
interpret p1
interpret p2
prettyPrint p2
putStrLn $ showProgram p3
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment