Example using Monad Transformer stack handles failure, IO, and state. Useful for evaluating ASTs.

EvalStack.hs

module MoreState where

import Control.Monad.Except
import Control.Monad.State.Class
import Control.Monad.Trans.State hiding (get, put)
import Data.List
import Data.Map (Map)

import qualified Data.Map as M

data Expr = IntLit Integer
          | Plus Expr Expr
          | Print Expr
          | Bind String Expr
          | Ref String

instance Show Expr where
    show (IntLit i) = show i
    show (Plus a b) = "(" ++ show a ++ " + " ++ show b ++ ")"
    show (Print a) = "print(" ++ show a ++ ")"
    show (Bind a b) = "let " ++ a ++ " = " ++ show b
    show (Ref a) = a

data Value = IntVal Integer

instance Show Value where
    show (IntVal i) = show i

newtype Program = Program { getProgram :: [Expr] }

instance Show Program where
    show = intercalate "\n" . map show . getProgram

sampleProgram :: Program
sampleProgram = Program [ Bind "a" (IntLit 1)
                        , Bind "b" (IntLit 2)
                        , Bind "c" (Plus (Ref "a") (Ref "b"))
                        , Print (Ref "c")
                        ]

type SymbolTable = Map String Value

runProgram :: Program -> IO ()
runProgram (Program exprs) = do
    result <- evalStateT (runExceptT (evalExprs exprs)) M.empty
    case result of
      Left e -> putStrLn "Error:\n" >> putStrLn (perline ("  " ++) e)
      Right _ -> return ()

perline :: (String -> String) -> String -> String
perline f = unlines . map f . lines

evalExprs :: [Expr] -> ExceptT String (StateT SymbolTable IO) Value
evalExprs [] = ExceptT $ return $ Left "Empty program"
evalExprs [x] = eval x
evalExprs (x : xs) = eval x >> evalExprs xs

instance Num Value where
    (IntVal a) + (IntVal b) = IntVal $ a + b
    (IntVal a) - (IntVal b) = IntVal $ a - b
    (IntVal a) * (IntVal b) = IntVal $ a * b
    abs (IntVal a) = IntVal $ abs a
    signum (IntVal a) = IntVal $ signum a
    fromInteger = IntVal

eval :: Expr -> ExceptT String (StateT SymbolTable IO) Value
eval (IntLit a) = return $ IntVal a
eval (Plus a b) = (+) <$> eval a <*> eval b
eval (Print a) = do a' <- eval a
                    liftIO $ print a'
                    return a'
eval (Bind a b) = do b' <- eval b
                     s <- get
                     put $ M.insert a b' s
                     return b'
eval (Ref a) = do binds <- get
                  case M.lookup a binds of
                    Nothing -> ExceptT . return . Left $ a ++ " is undefined"
                    Just x -> return x