Definitional.hs

-- The meta-circular interpreter from section 5 of Reynolds's Definitional
-- Interpreters for Higher Order Programming Languages
-- (http://www.cs.uml.edu/~giam/91.531/Textbooks/definterp.pdf)

data EXP
  = CONST Const
  | VAR Var
  | APPL Appl
  | LAMBDA Lambda
  | COND Cond
  | LETREC LetRec
  deriving (Show)

newtype Const = Const { evcon :: Val }
  deriving (Show)

data Val = ValInt Integer | ValBool Bool | ValFun (Val -> Val)

instance Eq Val where
  ValInt i == ValInt j = i == j
  ValBool b == ValBool b' = b == b'
  _ == _ = False

instance Show Val where
  show (ValInt i) = "ValInt " ++ show i
  show (ValBool b) = "ValBool " ++ show b
  show (ValFun _) = "ValFun undefined"

data Var = Var String
  deriving (Show, Eq)

data Appl = Appl { opr :: EXP, opnd :: EXP }
  deriving (Show)

data Lambda = Lambda { fp :: Var, lambdaBody :: EXP }
  deriving (Show)

data Cond = Cond { prem :: EXP, conc :: EXP, altr :: EXP }
  deriving (Show)

data LetRec = LetRec { dvar :: Var, dexp :: Lambda, letRecBody :: EXP }
  deriving (Show)

type Env = Var -> Val

eval :: EXP -> Env -> Val
eval r e = case r of
  CONST c -> evcon c
  VAR v -> e v
  APPL a -> case (eval (opr a) e) of
    ValFun f -> f (eval (opnd a) e)
    _ -> error "APPL operator is not a function"
  LAMBDA l -> evlambda l e
  COND c -> case eval (prem c) e of
    ValBool True -> eval (conc c) e
    ValBool False -> eval (altr c) e
    _ -> error "COND premise is not boolean"
  LETREC lrc ->
    let e' = \x -> if x == dvar lrc
                   then evlambda (dexp lrc) e'
                   else e x
    in eval (letRecBody lrc) e'
  where
    evlambda :: Lambda -> Env -> Val
    evlambda l e = ValFun (\a -> eval (lambdaBody l) (ext (fp l) a e))

    ext :: Var -> Val -> Env -> Env
    ext z a e = \x -> if x == z then a else e z

interpret r = eval r initenv
  where
    initenv :: Env
    initenv x = case x of
      Var "succ" -> ValFun (\(ValInt i) -> ValInt (succ i))
      Var "equal" -> ValFun (\a -> ValFun (\b -> ValBool (a == b)))


main = print $ interpret $ APPL (Appl (VAR (Var "succ")) (CONST (Const (ValInt 1))))