Skip to content

Instantly share code, notes, and snippets.

@reinh
Last active April 22, 2023 01:07
Show Gist options
  • Save reinh/3e1d54b35d0dc6eadc66f1b672ccad2e to your computer and use it in GitHub Desktop.
Save reinh/3e1d54b35d0dc6eadc66f1b672ccad2e to your computer and use it in GitHub Desktop.
-- 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))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment