An AST interpreter example for language with scoped variables and addition, subtraction, logical and/or.

interpreter.hs

import Control.Monad.State.Lazy
import qualified Data.Map.Strict as Map
import Data.Maybe

data Op = Plus | Minus | And | Or deriving (Show)

newtype VarName = VarName (String) deriving (Show, Ord, Eq)

data Expr
  = Var (VarName)
  | Num (Int)
  | BinOp (Expr, Op, Expr)
  | If (Expr, Expr, Expr)
  | Let (VarName, Expr, Expr)
  | WhilePos (VarName, VarName, Expr, Expr)
  deriving (Show)

data Result = Bool (Bool) | Int (Int) | RuntimeError deriving (Show)

type Env = Map.Map VarName Result

type Interpreter = State Env Result

add :: Result -> Result -> Result
add (Int (l)) (Int (r)) = Int (l + r)
add _ _ = RuntimeError

sub :: Result -> Result -> Result
sub (Int (l)) (Int (r)) = Int (l - r)
sub _ _ = RuntimeError

logical_and :: Result -> Result -> Result
logical_and (Bool (l)) (Bool (r)) = Bool (l && r)
logical_and _ _ = RuntimeError

logical_or :: Result -> Result -> Result
logical_or (Bool (l)) (Bool (r)) = Bool (l || r)
logical_or _ _ = RuntimeError

if_then_else :: Result -> Expr -> Expr -> Interpreter
if_then_else (Bool (True)) y _ = eval y
if_then_else (Bool (False)) _ n = eval n
if_then_else _ _ _ = do
  return RuntimeError

is_non_positive :: Result -> Bool
is_non_positive (Int (n)) = n <= 0
is_non_positive _ = False

eval :: Expr -> Interpreter
eval (Var (name)) = do
  env <- get
  return $ fromMaybe RuntimeError $ Map.lookup name env
eval (Num (n)) = do
  return $ Int (n)
eval (BinOp (lhs, Plus, rhs)) = do
  l <- eval lhs
  r <- eval rhs
  return $ add l r
eval (BinOp (lhs, Minus, rhs)) = do
  l <- eval lhs
  r <- eval rhs
  return $ sub l r
eval (BinOp (lhs, And, rhs)) = do
  l <- eval lhs
  r <- eval rhs
  return $ logical_and l r
eval (BinOp (lhs, Or, rhs)) = do
  l <- eval lhs
  r <- eval rhs
  return $ logical_or l r
eval (If (cond, yes, no)) = do
  c <- eval cond
  if_then_else c yes no
eval (Let (name, value, body)) = do
  new_value <- eval value
  old_value <- gets $ Map.lookup name
  modify $ Map.insert name new_value
  ret <- eval body
  maybe (return ()) (\old_v -> modify $ Map.insert name old_v) old_value
  return ret
eval (WhilePos (cond_name, acc_name, cond_next, body)) = do
  cond_next_value <- eval cond_next
  body_value <- eval body
  if is_non_positive cond_next_value
    then
      return body_value
    else do
      modify $ Map.insert cond_name cond_next_value
      modify $ Map.insert acc_name body_value
      eval (WhilePos (cond_name, acc_name, cond_next, body))

interpreter_example.hs

example :: Expr
example =
  Let
    ( VarName ("x"),
      Num (3),
      Let
        ( VarName ("y"),
          Num (4),
          Let
            ( VarName ("z"),
              Num (0),
              WhilePos
                ( VarName ("x"),
                  VarName ("z"),
                  BinOp (Var (VarName ("x")), Minus, Num (1)),
                  BinOp (Var (VarName ("y")), Plus, Var (VarName ("z")))
                )
            )
        )
    )

main :: IO ()
main = putStrLn $ show $ evalState (eval example) Map.empty