Skip to content

Instantly share code, notes, and snippets.

@TerrorJack
Created December 25, 2014 11:53
Show Gist options
  • Save TerrorJack/a413ebced3494e2148a5 to your computer and use it in GitHub Desktop.
Save TerrorJack/a413ebced3494e2148a5 to your computer and use it in GitHub Desktop.
A simple interpreter (that works). Supports ADT/pattern matching. No type system/callcc/macro.
import qualified Data.Map as Map
type Env = Map.Map String Val
data Exp =
ConstExp Val
| VarExp String
| LambdaExp Pat Exp
| LetrecExp [(Pat,Exp)] Exp
| IfExp Exp Exp Exp
| CaseExp Exp [(Pat,Exp)]
| AppExp Exp Exp
| ADTExp String [Exp]
| UnaryOpExp String Exp
| BinaryOpExp String Exp Exp
data Val =
UnitVal
| BoolVal Bool
| IntVal Int
| FloatVal Float
| ClosureVal Pat Exp Env
| ADTVal String [Val]
data Pat =
NilPat
| ConstPat Val
| VarPat String
| ADTPat String [Pat]
instance Eq Val where
UnitVal == UnitVal = True
(BoolVal x) == (BoolVal y) = x == y
(IntVal x) == (IntVal y) = x == y
(FloatVal x) == (FloatVal y) = x == y
(ADTVal x_adt x_val_list) == (ADTVal y_adt y_val_list) = (x_adt == y_adt) && (and [x==y|(x,y)<-zip x_val_list y_val_list])
match :: Pat -> Val -> Maybe Env
match NilPat _ = Just Map.empty
match (ConstPat pval) val = if pval == val then Just (Map.empty) else Nothing
match (VarPat var) val = Just (Map.singleton var val)
match (ADTPat pname plist) (ADTVal vname vlist) =
let merge Nothing _ = Nothing
merge _ Nothing = Nothing
merge (Just env0) (Just env1) = Just (Map.union env0 env1)
in if pname == vname then (foldl merge (Just Map.empty) [match p v|(p,v)<-zip plist vlist]) else Nothing
evalExp :: Exp -> Env -> Val
evalExp (ConstExp val) _ = val
evalExp (VarExp var) env = env Map.! var
evalExp (LambdaExp pat exp) env = ClosureVal pat exp env
evalExp (LetrecExp pat_exp_list exp) env =
let new_env = Map.union delta_env env
Just delta_env = match (ADTPat "" pat_list) (ADTVal "" val_list)
pat_list = [p|(p,_)<-pat_exp_list]
val_list = [evalExp e new_env|(_,e)<-pat_exp_list]
in evalExp exp new_env
evalExp (IfExp cond_exp then_exp else_exp) env =
let (BoolVal flag) = evalExp cond_exp env in
if flag then evalExp then_exp env else evalExp else_exp env
evalExp (CaseExp exp pat_exp_list) env =
let val = evalExp exp env
f ((p,e):p_e_list) =
case match p val of
Just delta_env -> evalExp e (Map.union delta_env env)
Nothing -> f p_e_list
in f pat_exp_list
evalExp (AppExp f_exp x_exp) env =
let (ClosureVal c_pat c_exp c_env) = evalExp f_exp env
x_val = evalExp x_exp env
(Just delta_env) = match c_pat x_val
in evalExp c_exp (Map.union delta_env c_env)
evalExp (ADTExp adt_name exp_list) env = ADTVal adt_name [evalExp exp env|exp<-exp_list]
evalExp (UnaryOpExp op x_exp) env = error "todo"
evalExp (BinaryOpExp op x_exp y_exp) env =
let x_val = evalExp x_exp env
y_val = evalExp y_exp env
in if op == "==" then BoolVal (x_val == y_val) else
let f = (Map.fromList [("+",(+)),("-",(-)),("*",(*))]) Map.! op
(IntVal x_int) = x_val
(IntVal y_int) = y_val
in IntVal (f x_int y_int)
top_exp :: Exp
top_exp =
LetrecExp
[(VarPat "f",
LambdaExp (VarPat "x")
(IfExp (BinaryOpExp "==" (VarExp "x") (ConstExp (IntVal 0)))
(ConstExp (IntVal 1))
(BinaryOpExp "*" (VarExp "x") (AppExp (VarExp "f") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1)))))))]
(AppExp (VarExp "f") (ConstExp (IntVal 5)))
top_exp_2 :: Exp
top_exp_2 =
LetrecExp
[(VarPat "even",
LambdaExp (VarPat "x")
(IfExp (BinaryOpExp "==" (VarExp "x") (ConstExp (IntVal 0)))
(ConstExp (BoolVal True))
(AppExp (VarExp "odd") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1)))))),
(VarPat "odd",
LambdaExp (VarPat "x")
(IfExp (BinaryOpExp "==" (VarExp "x") (ConstExp (IntVal 0)))
(ConstExp (BoolVal False))
(AppExp (VarExp "even") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1))))))]
(AppExp (VarExp "even") (ConstExp (IntVal 19)))
top_exp_3 :: Exp
top_exp_3 =
LetrecExp
[(VarPat "f",
LambdaExp (VarPat "x")
(CaseExp (VarExp "x")
[(ConstPat (IntVal 0),ConstExp (IntVal 1)),
(VarPat "x",BinaryOpExp "*" (VarExp "x") (AppExp (VarExp "f") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1)))))]))]
(AppExp (VarExp "f") (ConstExp (IntVal 5)))
top_exp_4 :: Exp
top_exp_4 =
LetrecExp
[(VarPat "make_adder",
LambdaExp (VarPat "x")
(LambdaExp (VarPat "y") (BinaryOpExp "+" (VarExp "x") (VarExp "y")))),
(VarPat "adder",
AppExp (VarExp "make_adder") (ConstExp (IntVal 5)))]
(AppExp (VarExp "adder") (ConstExp (IntVal 42)))
main :: IO ()
main = let (IntVal x) = evalExp top_exp_4 Map.empty in print x
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment