(* An interpreter for the following little language: M = V values | (- M M) | ( * M M) built-in numeric ops | ifzero M then M else M branch on zero | x variable | (M M) function application | fix M fixpoint of a function V = n built-in numbers | lam x:T.M function T = Num | T -> T n = x = Basic re-writing rules: ( - n1 n2) -> ( * n1 n2) -> ifzero 0 then M1 else M2 -> M1 ifzero n then M1 else M2 -> M2 if N is not 0 ((lam x:T.M) V) -> M with V replacing free instances of x fix (lam x:T.M) -> M with (fix (lam x:T.M)) replacing free x Also allow subexpression reductions, left to right: M1 - M2 -> M1' - M2 if M1 -> M1' V - M2 -> V - M2' if M2 -> M2' (M1 M2) -> (M1' M2) if M1 -> M1' (V M2) -> (V M2') if M2 -> M2' ifzero M1 then M2 else M3 -> ifzero M1' then M2 else M3 if M1 -> M1' (fix M) -> (fix M') if M -> M' *) (*********** Datatypes ***********) (* Variables *) type xvar = string (* Types *) type xtype = NumT | FunT of xtype * xtype (* Values *) type xval = Num of int | Lam of xvar * xtype * xpr (* Expressions *) and xpr = Val of xval | Minus of xpr * xpr | Times of xpr * xpr | Var of xvar | App of xpr * xpr | IfZero of xpr * xpr * xpr | Fix of xpr ;; (*********** Examples ***********) (* five is 5 *) let five = Val(Num(5)) (* fivetimesfive is ( * 5 5) *) let fivetimesfive = Times(five, five) (* mkfac is lam f:Num->Num . lam n:Num . (ifzero n 1 ( * n (f (- n 1)))) *) let mkfac = Val(Lam("f", FunT(NumT, NumT), Val(Lam("n", NumT, IfZero(Var("n"), Val(Num(1)), Times(Var("n"), App(Var("f"), Minus(Var("n"), Val(Num(1)))))))))) (* fac is fix mkfac *) let fac = Fix(mkfac) (* onetwentry is (fac 5) *) let onetwenty = App(fac, five) (* illformed is (5 (lam x:Num . x)) *) let illformed = App(Val(Num(5)), Val(Lam("x", NumT, Var("x")))) (* badapp is ((lam x:Num->Num . (- (x 10) ((x (lam y:Num . y)) 4))) (lam x:Num . x)) *) let badapp = App(Val(Lam("x", FunT(NumT, NumT), Minus(App(Var("x"), Val(Num(10))), App(App(Var("x"), Val(Lam("y", NumT, Var("y")))), Val(Num(4)))))), Val(Lam("x", NumT, Var("x")))) ;; (*********** Examples with Type Abstraction ***********) (* (for the second part of the assignment) *) (* COMMENT STARTS HERE (* ident is (Lam a (lam x:a . x)) *) let ident = Val(TyLam("a", Val(Lam("x", TyVar("a"), Var("x"))))) (* broken is (Lam a (lam x:a . ( * x 1)) *) let broken = Val(TyLam("a", Val(Lam("x", TyVar("a"), Times(Var("x"), Val(Num(0))))))) (* seven is (((Lam a (lam x:a . x)) [Num]) 7) *) let seven = App(TyApp(Val(TyLam("a", Val(Lam("x", TyVar("a"), Var("x"))))), NumT), Val(Num(7))) (* absapp is ((lam x:(A a.a->a) . (- (x [Num] 10) ((x [Num->Num] (lam y:Num . y)) 4))) (Lam a (lam x:a . x))) *) let absapp = App(Val(Lam("x", ForAll("a", FunT(TyVar("a"), TyVar("a"))), Minus(App(TyApp(Var("x"), NumT), Val(Num(10))), App(App(TyApp(Var("x"), FunT(NumT, NumT)), Val(Lam("y", NumT, Var("y")))), Val(Num(4)))))), Val(TyLam("a", Val(Lam("x", TyVar("a"), Var("x")))))) ;; COMMENT ENDS HERE *) (*********** Evaluator ***********) exception Stuck (* One-step reduction *) let rec reduce = function Minus(Val(Num(n1)), Val(Num(n2))) -> Val(Num(n1 - n2)) | Minus(Val(v1), m2) -> Minus(Val(v1), reduce m2) | Minus(m1, m2) -> Minus(reduce m1, m2) | Times(Val(Num(n1)), Val(Num(n2))) -> Val(Num(n1 * n2)) | Times(Val(v1), m2) -> Times(Val(v1), reduce m2) | Times(m1, m2) -> Times(reduce m1, m2) | App(Val(Lam(x, t, m)), Val(v)) -> replace(x, Val(v), m) | App(Val(f), m2) -> App(Val(f), reduce m2) | App(m1, m2) -> App(reduce m1, m2) | IfZero(Val(Num(0)), m2, m3) -> m2 | IfZero(Val(Num(n)), m2, m3) -> m3 | IfZero(m1, m2, m3) -> IfZero(reduce m1, m2, m3) | Fix(Val(Lam(x, t, m))) -> replace(x, Fix(Val(Lam(x, t, m))), m) | Fix(m) -> Fix(reduce m) | _ -> raise Stuck (* Replacement (assumes m is a closed expression) *) and replace = fun (x, v, m) -> let rec r = function Minus(m1, m2) -> Minus(r m1, r m2) | Times(m1, m2) -> Times(r m1, r m2) | Var(x2) -> if (x = x2) then v else Var(x2) | App(m1, m2) -> App(r m1, r m2) | IfZero(m1, m2, m3) -> IfZero(r m1, r m2, r m3) | Fix(m) -> Fix(r m) | Val(Lam(fx, t, m)) -> Val(Lam(fx, t, if (fx = x) then m else (r m))) | Val(Num(n)) -> Val(Num(n)) in r(m) (*********** Typechecker ***********) (* Type environments, NOT COMPLETE! *) type tenv = Empty (* | ... *) exception NoType (* Typecheck function, NOT COMPLETE! *) let rec typecheck = function (m, e) -> NumT (*********** Printer and Stepper ***********) (* Pretty-printer *) let rec print = function Val(Num(n)) -> print_int(n) | Val(Lam(x, t, m)) -> print_string("(lam "); print_string(x); print_string(":"); printType(t); print_string(" . "); print(m); print_string(")") | Minus(m1, m2) -> print_string("(- "); print(m1); print_string(" "); print(m2); print_string(")") | Times(m1, m2) -> print_string("(* "); print(m1); print_string(" "); print(m2); print_string(")") | Var(x) -> print_string(x) | App(m1, m2) -> print_string("("); print(m1); print_string(" "); print(m2); print_string(")") | IfZero(m1, m2, m3) -> print_string("(ifzero "); print(m1); print_string(" then "); print(m2); print_string(" else "); print(m3); print_string(")") | Fix(m) -> print_string("(fix "); print(m); print_string(")") and printType = function NumT -> print_string("Num") | FunT(t1, t2) -> print_string("("); printType(t1); print_string("->"); printType(t2); print_string(")") (* Evaluation loop *) and showEval = function Val(v) -> print(Val(v)); print_newline(); print_string("Done"); print_newline() | m -> print(m); print_string(" -> "); print_newline(); showEval(reduce m) ;; (*********** Example Evaluation ***********) let example = fivetimesfive ;; let exampleType = typecheck(example, Empty) ;; print_string("Type: "); printType(exampleType); print_newline() ;; showEval(example) ;;