Yesterday someone posted a link to a great monad transformers tutorial. It's incredible. I think I finally start to understand (or at least being able to use) it.

As part of testing my fresh knowledge I've written a simple virtual machine for a Forth-like language. Code (as usual - Literate Haskell, so you can just put it into .lhs file and run it) below.

Enjoy!

Data type

> module Main where

>

> import Control.Monad.State

> import Control.Monad.Reader

> import Data.Char

> import Data.Maybe

> import System.IO

>

> import qualified Data.Map as Map

`Op`

defines all primitive operations available in our language.

> data Op =

> Number Int -- push number on stack

> | Plus -- add two elements on top of stack

> | Minus -- subtract

> | Mul -- multiplicate

> | Div -- divide

> | Out -- write single number from stack to stdout

> | Emit -- emit character with code from stack to stdout

> | Dup -- duplicate item on top of stack

> | Drop -- drop top-most item

> | Call String -- call function with given name

> | GetI -- get current loop counter and push on stack

> | Loop [Op] -- execute loop body; max and min must be on stack

> | If [Op] [Op] -- if statement with "then" and "else" block

> | Equal -- push 1 if top-most items are equal, 0 otherwise

> | Less -- push 1 if top-most item is greater than item below it

> | Greater -- push 1 if top-most item is smaller than item below it

> deriving Show

`Words`

is a dictionary mapping function names to their code.

> type Words = Map.Map String [Op]

`ForthState`

contains current interpreter state. It consists of data stack and of loop counter. Currently no nested loops are supported.Interpreter state is defined using two monad transformers -

> data ForthState = ForthState {

> stack :: [Int],

> counter :: Int

> } deriving Show

`StateT`

responsible for state management (stack, counter), and `ReaderT`

providing read-only environment, in this case dictionary of user-defined words. `IO`

is used as internal monad since program is supposed to perform I/O operations.Computation does not return any useful results, hence return type of whole computation is

`()`

.

> type Forth = ReaderT Words (StateT ForthState IO) ()

>

> initState = ForthState [] 0

`runForth`

function performs execution of given program in given environment (defined words) starting from given state.Execution of sequence of operations is realized by simple (monadic) mapping of

> runForth :: Words -> ForthState -> [Op] -> IO ((), ForthState)

> runForth env st program = runStateT (runReaderT (execSequence program) env) st

`exec`

function which interprets single operation over whole program. Mapping variant used ignores return values of subsequent `exec`

invocations since it does not return any useful data anyway.Utility functions for stack operations.

> execSequence program = mapM_ exec program

And

> push n = do state <- get

> put $ state { stack = n:(stack state) }

>

> pop = do state <- get

> case stack state of

> (x:xs) -> do put $ state { stack = xs }

> return x

`exec`

implementation for different operations.Time for a sample program to be executed. Program will calculate factorials of numbers from 1 to 7 and output them as lines with pairs number - factorial.

> -- ( -- n )

> exec (Number n) = push n

>

> -- ( n -- )

> exec Drop = pop >> return () -- pop and ignore returned value

>

> -- ( n -- n n )

> exec Dup = do x <- pop

> push x

> push x

>

> -- ( y x -- y+x )

> exec Plus = do x <- pop

> y <- pop

> push (y + x)

>

> -- ( y x -- y-x )

> exec Minus = do x <- pop

> y <- pop

> push (y - x)

>

> -- ( y x -- y*x )

> exec Mul = do x <- pop

> y <- pop

> push (y * x)

>

> -- ( y x -- y/x )

> exec Div = do x <- pop

> y <- pop

> push (y `div` x)

>

> -- ( y x -- y==x )

> exec Equal = do x <- pop

> y <- pop

> if y == x then push 1 else push 0

>

> -- ( y x -- y> exec Less = do x <- pop

> y <- pop

> if y < x then push 1 else push 0

>

> -- ( y x -- y>x )

> exec Greater = do x <- pop

> y <- pop

> if y > x then push 1 else push 0

>

> -- ( x -- )

> exec Out = do x <- pop

> liftIO $ (putStr (show x) >> putStr " " >> hFlush stdout)

>

> -- ( x -- )

> exec Emit = do x <- pop

> liftIO $ (putChar (chr x) >> hFlush stdout)

>

> -- stack effect depends on invoked function

> exec (Call fn) = do body <- asks (fromJust . Map.lookup fn)

> execSequence body

>

> -- ( -- I )

> exec GetI = do state <- get

> push $ counter state

>

> -- ( n m -- .. ) - n - high loop bound, m - low loop bound

> exec (Loop b) = do low <- pop

> high <- pop

> if low < high then mapM_ (doOnce b) [low .. high-1] else return () where

> doOnce program c = do state <- get

> put $ state { counter = c }

> execSequence program

>

> -- ( x -- .. ) - if x != 0 then t else e

> exec (If t e) = do x <- pop

> if x /= 0 then execSequence t else execSequence e

Environment contains definition of a

`factorial`

function that calculates factorial of an item on top of stack, that is used by the main program to perform calculations.

> env = Map.fromList [ ("factorial",

> [ Dup

> , Number 1

> , Greater -- if n > 0

> , If [ Dup

> , Number 1

> , Minus

> , Call "factorial" -- factorial (n-1)

> , Mul -- *

> ]

> [ Drop

> , Number 1

> ] -- else 1

> ])

> ]

> sample = [ Number 8

> , Number 1

> , Loop [ GetI

> , Dup

> , Out

> , Call "factorial"

> , Out

> , Number 10

> , Emit

> ]

> ]

> main = do a <- runForth env initState sample

> return ()