(* MicroML: minimalistic interpreted ML-like language Andreas van Cranenburgh 2010 *) type monop = Neg | Not type binop = Add | Sub | Mul | Div | Mod | (* arithmetic operators *) Eq | Ne | Lt | Le | Gt | Ge | (* relational operators *) And | Or (* logic operators *) type expr = Num of int (* integer constant *) | Bool of bool (* boolean constant *) | Var of string (* variable *) | MonopAp of monop * expr (* unary operator application *) | BinopAp of binop * expr * expr (* binary operator application *) | Cond of expr * expr * expr (* conditional expression *) | Fun of string * expr (* function abstraction *) | FunAp of expr * expr (* function application *) | Let of string * expr * expr (* variable binding *) | LetRec of string * expr * expr (* recursive variable binding *) let op2string = function | Add -> " + " | Sub -> " - " | Mul -> " * " | Div -> " / " | Mod -> " mod " | Eq -> " = " | Ne -> " <> " | Lt -> " < " | Le -> " <= " | Gt -> " > " | Ge -> " >= " | And -> " && " | Or -> " || ";; let mop2string = function | Neg -> " - " | Not -> " not ";; let rec expr2string = function | Num(x) -> string_of_int x | Bool(x) -> string_of_bool x | Var(x) -> x | MonopAp(op, expr) -> "(" ^ mop2string op ^ expr2string expr ^ ")" | BinopAp(op, e1, e2) -> "(" ^ expr2string e1 ^ op2string op ^ expr2string e2 ^ ")" | Cond(e1, e2, e3) -> "if " ^ expr2string e1 ^ " then " ^ expr2string e2 ^ " else " ^ expr2string e3 | Fun(s, e) -> "(fun " ^ s ^ " -> " ^ expr2string e ^ ")" | FunAp(e1, e2) -> "(" ^ expr2string e1 ^ " " ^ expr2string e2 ^ ")" | Let(s, e1, e2) -> "let " ^ s ^ " = " ^ expr2string e1 ^ " in " ^ expr2string e2 | LetRec(s, e1, e2) -> "let rec " ^ s ^ " = " ^ expr2string e1 ^ " in " ^ expr2string e2;; let rec map f = function | [] -> [] | x::xs -> f x::map f xs;; let rec filter p = function | [] -> [] | x::xs when p x -> x::filter p xs | _::xs -> filter p xs;; (* generic unhelpful error message *) exception Hell;; let rec foldr f = function | [] -> raise Hell | [x] -> x | x::xs -> f x (foldr f xs);; let concat ll = let rec append l m = match l with | [] -> m | x::xs -> x::append xs m in foldr append ll;; let drop e l = filter ((<>) e) l;; let rec set = function | [] -> [] | x::xs -> x::(set (drop x xs));; let rec freevars = function | Num(x) -> [] | Bool(x) -> [] | Var(x) -> [x] | MonopAp(_, e1) -> freevars e1 | Fun(s, e1) -> drop s (freevars e1) | BinopAp(_, e1, e2) | FunAp(e1, e2) -> set (concat (map freevars [e1; e2])) | Let(s, e1, e2) -> set (concat [freevars e1; drop s (freevars e2)]) | LetRec(s, e1, e2) -> drop s (set (concat (map freevars [e1; e2]))) | Cond(e1, e2, e3) -> set (concat (map freevars [e1; e2; e3]));; let rec subst orig s newexpr = match orig with (* substitute! *) | Var(x) when x = s -> newexpr (* navigate down the tree *) | MonopAp(op, expr) -> MonopAp(op, (subst expr s newexpr)) | BinopAp(op, e1, e2) -> BinopAp(op, (subst e1 s newexpr), (subst e2 s newexpr)) | Cond(e1, e2, e3) -> Cond((subst e1 s newexpr), (subst e2 s newexpr), (subst e3 s newexpr)) | FunAp(e1, e2) -> FunAp((subst e1 s newexpr), (subst e2 s newexpr)) | Fun(t, e) when s <> t -> Fun(t, (subst e s newexpr)) | Let(t, e1, e2) when s <> t -> Let(t, (subst e1 s newexpr), (subst e2 s newexpr)) | Let(t, e1, e2) -> Let(t, (subst e1 s newexpr), e2) | LetRec(t, e1, e2) when s <> t -> LetRec(t, (subst e1 s newexpr), (subst e2 s newexpr)) (* anything else is returned verbatim, no substitutions necessary *) | _ -> orig;; (* global state *) let cnt = ref 0 let getNewId id = (cnt := !cnt + 1; "_" ^ id ^ "_" ^ string_of_int (!cnt)) exception TypeError of string * expr;; let evalop = function | MonopAp(Neg, Num(x)) -> Num(-x) | BinopAp(op, Num(x), Num(y)) -> (match op with | Add -> Num(x + y) | Sub -> Num(x - y) | Mul -> Num(x * y) | Div -> Num(x / y) | Mod -> Num(x mod y) | Eq -> Bool(x = y) | Ne -> Bool(x <> y) | Lt -> Bool(x < y) | Le -> Bool(x <= y) | Gt -> Bool(x > y) | Ge -> Bool(x >= y) | _ -> raise (TypeError("binary operator not applicable to numercial arguments: ", BinopAp(op, Num(x), Num(y))))) | x -> raise (TypeError("operator not applicable to numercial arguments:", x));; let evalboolop = function | MonopAp(Not, Bool(x)) -> Bool(not x) | BinopAp(op, Bool(x), Bool(y)) -> (match op with | And -> Bool(x && y)| Or -> Bool(x || y) | _ -> raise (TypeError("binary operator not applicable to boolean arguments:", BinopAp(op, Bool(x), Bool(y))))) | x -> raise (TypeError("operator not applicable to boolean arguments: ", x));; let rec alphaconv = function | Fun(s, e) -> let x = getNewId s in Fun(x, subst (alphaconv e) s (Var x)) | Let(s, e1, e2) -> let x = getNewId s in Let(x, alphaconv e1, subst (alphaconv e2) s (Var x)) | LetRec(s, e1, e2) -> let x = getNewId s in LetRec(x, subst (alphaconv e1) s (Var x), subst (alphaconv e2) s (Var x)) | MonopAp(op, expr) -> MonopAp(op, alphaconv expr) | BinopAp(op, e1, e2) -> BinopAp(op, alphaconv e1, alphaconv e2) | Cond(e1, e2, e3) -> Cond(alphaconv e1, alphaconv e2, alphaconv e3) | FunAp(e1, e2) -> FunAp(alphaconv e1, alphaconv e2) (* Return constants verbatim *) | x -> x;; exception NoCigar of expr;; let rec apply f arg = match f with | Fun(s, e) -> subst e s arg | MonopAp(op, expr) -> apply expr arg | BinopAp(op, e1, e2) -> (try apply e1 arg with (NoCigar arg) -> apply e2 arg) | Cond(e1, e2, e3) -> (try apply e1 arg with (NoCigar arg) -> (try apply e2 arg with (NoCigar arg) -> apply e3 arg)) | FunAp(e1, e2) -> apply (apply e1 e2) arg | Let(s, e1, e2) -> apply (subst e2 s e1) arg | LetRec(s, e1, e2) -> apply (subst e2 s e1) arg (* f is dysfunctional *) | _ -> raise (NoCigar arg);; let rec eval = function | MonopAp(op, expr) -> (match eval expr with | Num(x) -> evalop (MonopAp(op, Num(x))) | Bool(x) -> Bool(not x) | x -> MonopAp(op, x)) | BinopAp(And, e1, e2) -> if eval e1 = (Bool true) then eval e2 else (Bool false) | BinopAp(Or, e1, e2) -> if eval e1 = (Bool true) then (Bool true) else eval e2 | BinopAp(op, e1, e2) -> (match eval e1, eval e2 with | Num(x), Num(y) -> evalop (BinopAp(op, Num(x), Num(y))) | x, y -> BinopAp(op, x, y)) | Cond(e1, e2, e3) -> eval (if eval e1 = Bool(true) then e2 else e3) | FunAp(e1, e2) -> eval (apply (alphaconv e1) e2) | Fun(s, e) -> Fun(s, eval e) | Let(s, e1, e2) -> eval (subst e2 s e1) (* apply some lambda-fu to enable recursion *) | LetRec(s, e1, e2) -> let rece1 = Let("g", Fun(s, e1), (* let Z = fun f -> (fun x -> (f ((x x) y)) fun x -> (f (fun y -> ((x x) y)))) *) Let("Z", Fun("f", FunAp( Fun("x", FunAp(Var("f"), Fun("y", FunAp(FunAp(Var("x"), Var("x")), Var("y"))))), Fun("x", FunAp(Var("f"), Fun("y", FunAp(FunAp(Var("x"), Var("x")), Var("y"))))))), (* (Z g) *) FunAp(Var("Z"), Var("g")))) in eval (subst e2 s rece1) (* anything else is returned verbatim *) | x -> x;; (* Assignment 12 *) let myMap = map let rec myZip f l m = match l m with | [], _ | _, [] -> [] | x::xs, y::ys -> f x y::myZip f l m;; let myFilter = filter let rec myFoldR f n = function | [] -> n | [x] -> f x n | x::xs -> f x (myFoldR f n xs);; (* examples *) (* Z = λf. (λx. f (λy. x x y)) (λx. f (λy. x x y)) *) (* Recursive factorial using Y-combinator *) let factorial = (* let rec f = fun n -> if n = 0 then 1 else n * f (n - 1) *) LetRec("f", Fun("n", Cond(BinopAp(Eq, Var("n"), Num(0)), Num(1), BinopAp(Mul, Var("n"), FunAp(Var("f"), BinopAp(Sub, Var("n"), Num(1)))))), (* (f 5) *) FunAp(Var("f"), Num(5)));; let optoexp = function | "*" -> Mul | "/" -> Div | "+" -> Add | "-" -> Sub | "=" -> Eq | "<>" -> Ne | "<" -> Lt | ">" -> Gt | "<=" -> Le | ">=" -> Ge | "&&" -> And | "||" -> Or | "mod" -> Mod | _ -> raise Hell;; let factstr = "let rec f = let dec n = n - 1 in fun n -> if n = 0 then 1 else n * f @ dec @ n in f @ 5" (*let ex = interpret "fun x -> if x = 2 then 2 * 3 else 3";;*) (* all of the following code adapted from: http://www.cl.cam.ac.uk/teaching/Lectures/funprog-jrh-1996/l10.ps.gz *) type token = Name of string | Numt of string | Other of string;; exception Nolex of string list;; exception Noparse of token list;; let chain parser1 parser2 input = let result1,rest1 = parser1 input in let result2,rest2 = parser2 rest1 in (result1,result2),rest2;; let rec many parser input = try let result,next = parser input in let results,rest = many parser next in (result::results),rest with (Noparse _) | (Nolex _) -> [],input;; let treat parser treatment input = let result,rest = parser input in treatment(result),rest;; let either parser1 parser2 input = try parser1 input with (Noparse _) | (Nolex _) -> parser2 input;; let rec itlist f l b = match l,b with [], b -> b | (h::t), b -> f h (itlist f t b);; let k x y = x;; let o f g x = f(g x);; let explode s = let rec exap n l = if n < 0 then l else exap (n - 1) ((String.sub s n 1)::l) in exap (String.length s - 1) [];; let ssome p = function [] -> raise (Nolex []) | (h::t) -> if p h then (h,t) else raise (Nolex(h::t));; let some p = function [] -> raise (Noparse []) | (h::t) -> if p h then (h,t) else raise (Noparse(h::t));; let a tok = some (fun item -> item = tok);; let sfinished input = if input = [] then 0,input else raise (Nolex input);; let finished input = if input = [] then 0,input else raise (Noparse input);; let lex = let several p = many (ssome p) in let lowercase_letter s = "a" <= s & s <= "z" in let uppercase_letter s = "A" <= s & s <= "Z" in let letter s = lowercase_letter s or uppercase_letter s in let alpha s = letter s or s = "_" or s = "'" in let digit s = "0" <= s & s <= "9" in let opchar s = String.contains "|&=<>+-*" (String.get s 0) in let opcharsingle s = String.contains "+*/()" (String.get s 0) in let alphanum s = alpha s or digit s in let space s = s = " " or s = "\n" or s = "\t" in let collect(h,t) = h^(itlist (^) t "") in let rawname = treat (chain (ssome alpha) (several alphanum)) (o (fun x -> match x with | "not" | "mod" | "let" | "rec" | "in" | "if" | "then"| "else" | "fun" | "true" | "false" -> (Other x) | _ -> (Name x)) collect) in let rawnumeral = treat (chain (ssome digit) (several digit)) (o (fun x -> (Numt x)) collect) in let rawothersingle = treat (ssome opcharsingle) (fun x -> (Other x)) in let rawother = treat (chain (ssome opchar) (several opchar)) (o (fun x -> (Other x)) collect) in let token = treat (chain (either rawname (either rawnumeral (either rawothersingle rawother))) (several space)) fst in let tokens = treat (chain (several space) (many token)) snd in let alltokens = treat (chain tokens sfinished) fst in o fst (o alltokens explode);; let name = function (Name s::rest) -> s,rest | x -> raise (Noparse x);; let numeral = function (Numt s::rest) -> s,rest | x -> raise (Noparse x);; let other = function (Other s::rest) -> s,rest | x -> raise (Noparse x);; let rec binop op parser input = let atom1,rest1 as result = parser input in if not (rest1 = []) & (List.hd rest1 = (Other op)) then let atom2,rest2 = binop op parser (List.tl rest1) in BinopAp(optoexp op, atom1, atom2),rest2 else result;; let findmin l = itlist (fun (_,pr1 as p1) (_,pr2 as p2) -> if pr1 <= pr2 then p1 else p2) (List.tl l) (List.hd l);; let rec precedence ilist parser input = if ilist = [] then parser input else let opp = findmin ilist in let ilist' = drop opp ilist in binop (fst opp) (precedence ilist' parser) input;; let rec atom input = let rec schonfinkel f = function | [] -> f | [x] -> FunAp(f, x) | x::xs -> schonfinkel (FunAp(f, x)) xs in (either (treat (chain (chain (chain (chain (chain (chain (a (Other "let")) (a (Other "rec"))) name) (a (Other "="))) term) (a (Other "in"))) term) (fun x -> match x with | ((((((_,_),a),_),b),_),c) -> (LetRec(a,b,c)))) (either (treat (chain (chain (chain (chain (chain (a (Other "let")) name) (a (Other "="))) term) (a (Other "in"))) term) (fun x -> match x with | (((((_,a),_),b),_),c) -> (Let(a,b,c)))) (either (treat (chain (chain (a (Other "(")) term) (a (Other ")"))) (o snd fst)) (either (treat (chain (chain (chain (a (Other "fun")) name) (a (Other "->"))) term) (fun x -> match x with | (((_,a),_),b) -> (Fun(a,b)))) (either (treat (chain name termlist) (fun x -> match x with | (f, a) -> (schonfinkel (Var f) a))) (either (treat (chain (chain (chain (chain (chain (a (Other "if")) term) (a (Other "then"))) term) (a (Other "else"))) term) (fun x -> match x with | (((((_,a),_),b),_),c) -> (Cond(a,b,c)))) (either (treat name (fun s -> Var s)) (either (treat numeral (fun s -> Num (int_of_string s))) (either (treat (a (Other "false")) (fun x -> (Bool false))) (either (treat (a (Other "true")) (fun x -> (Bool true))) (either (treat (chain (a (Other "not")) atom) (fun x -> match x with (_,a) -> (MonopAp(Not, a)))) (treat (chain (a (Other "~")) atom) (fun x -> match x with (_,a) -> (MonopAp(Neg, a)))) )))))))))) input) and term input = let oplist = ["&&", 1; "||", 1; "=", 2; "<>", 2; ">", 2; "<", 2; "<=", 2; ">=", 2; "+",2;"-",2;"*",5;"/",5; "mod", 5] in precedence oplist atom input and termlist input = ((treat (chain term (many term)) (fun (h,t) -> h::t)) input);; (* TODO: - matching - types - lists - exceptions - globals *) (* last but not least, the parser *) let parser = o fst (o (treat (chain term finished) fst) lex);; let interpret source = eval (parser source);; let factstr = "let rec f = fun n -> if n = 0 then 1 else n * (f (n - 1)) in f 5";; let evalloop = print_endline "Welcome to MicroML. Press ctrl-c to quit."; while true do fst (print_endline (expr2string (interpret (read_line()))), print_string "MicroML# ") done;;