diff options
| -rw-r--r-- | ocaml/core.ml | 70 | ||||
| -rw-r--r-- | ocaml/env.ml | 8 | ||||
| -rw-r--r-- | ocaml/printer.ml | 51 | ||||
| -rw-r--r-- | ocaml/reader.ml | 26 | ||||
| -rw-r--r-- | ocaml/step2_eval.ml | 12 | ||||
| -rw-r--r-- | ocaml/step3_env.ml | 26 | ||||
| -rw-r--r-- | ocaml/step4_if_fn_do.ml | 30 | ||||
| -rw-r--r-- | ocaml/types.ml | 55 |
8 files changed, 160 insertions, 118 deletions
diff --git a/ocaml/core.ml b/ocaml/core.ml index db3424a..95e2f4c 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -1,46 +1,50 @@ +module T = Types.Types let ns = Env.make None -let num_fun t f = Types.Fn +let num_fun t f = T.Fn (function - | [(Types.Int a); (Types.Int b)] -> t (f a b) + | [(T.Int a); (T.Int b)] -> t (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) -let mk_int x = Types.Int x -let mk_bool x = Types.Bool x +let mk_int x = T.Int x +let mk_bool x = T.Bool x let init env = begin - Env.set env (Types.Symbol "+") (num_fun mk_int ( + )); - Env.set env (Types.Symbol "-") (num_fun mk_int ( - )); - Env.set env (Types.Symbol "*") (num_fun mk_int ( * )); - Env.set env (Types.Symbol "/") (num_fun mk_int ( / )); - Env.set env (Types.Symbol "<") (num_fun mk_bool ( < )); - Env.set env (Types.Symbol "<=") (num_fun mk_bool ( <= )); - Env.set env (Types.Symbol ">") (num_fun mk_bool ( > )); - Env.set env (Types.Symbol ">=") (num_fun mk_bool ( >= )); + Env.set env (Types.symbol "+") (num_fun mk_int ( + )); + Env.set env (Types.symbol "-") (num_fun mk_int ( - )); + Env.set env (Types.symbol "*") (num_fun mk_int ( * )); + Env.set env (Types.symbol "/") (num_fun mk_int ( / )); + Env.set env (Types.symbol "<") (num_fun mk_bool ( < )); + Env.set env (Types.symbol "<=") (num_fun mk_bool ( <= )); + Env.set env (Types.symbol ">") (num_fun mk_bool ( > )); + Env.set env (Types.symbol ">=") (num_fun mk_bool ( >= )); - Env.set env (Types.Symbol "list") (Types.Fn (function xs -> Types.List xs)); - Env.set env (Types.Symbol "list?") - (Types.Fn (function [Types.List _] -> Types.Bool true | _ -> Types.Bool false)); - Env.set env (Types.Symbol "empty?") - (Types.Fn (function [Types.List []] -> Types.Bool true | _ -> Types.Bool false)); - Env.set env (Types.Symbol "count") - (Types.Fn (function [Types.List xs] -> Types.Int (List.length xs) | _ -> Types.Int 0)); - Env.set env (Types.Symbol "=") - (Types.Fn (function [a; b] -> Types.Bool (a = b) | _ -> Types.Bool false)); + Env.set env (Types.symbol "list") (T.Fn (function xs -> Types.list xs)); + Env.set env (Types.symbol "list?") + (T.Fn (function [T.List _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "empty?") + (T.Fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "count") + (T.Fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0)); + Env.set env (Types.symbol "=") + (T.Fn (function [a; b] -> T.Bool (a = b) | _ -> T.Bool false)); - Env.set env (Types.Symbol "pr-str") - (Types.Fn (function xs -> - Types.String (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)))); - Env.set env (Types.Symbol "str") - (Types.Fn (function xs -> - Types.String (Printer.join "" (List.map (fun s -> Printer.pr_str s false) xs)))); - Env.set env (Types.Symbol "prn") - (Types.Fn (function xs -> + Env.set env (Types.symbol "pr-str") + (T.Fn (function xs -> + T.String (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)))); + Env.set env (Types.symbol "str") + (T.Fn (function xs -> + T.String (Printer.join "" (List.map (fun s -> Printer.pr_str s false) xs)))); + Env.set env (Types.symbol "prn") + (T.Fn (function xs -> print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)); - Types.Nil)); - Env.set env (Types.Symbol "println") - (Types.Fn (function xs -> + T.Nil)); + Env.set env (Types.symbol "println") + (T.Fn (function xs -> print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s false) xs)); - Types.Nil)); + T.Nil)); + + Env.set env (Types.symbol "compare") + (T.Fn (function [a; b] -> T.Int (compare a b))); end diff --git a/ocaml/env.ml b/ocaml/env.ml index d4388ad..97f9cc8 100644 --- a/ocaml/env.ml +++ b/ocaml/env.ml @@ -1,3 +1,4 @@ +module T = Types.Types module Data = Map.Make (String) type env = { @@ -9,12 +10,12 @@ let make outer = { outer = outer; data = ref Data.empty } let set env sym value = match sym with - | Types.Symbol key -> env.data := Data.add key value !(env.data) + | T.Symbol { T.value = key } -> env.data := Data.add key value !(env.data) | _ -> raise (Invalid_argument "set requires a Symbol for its key") let rec find env sym = match sym with - | Types.Symbol key -> + | T.Symbol { T.value = key } -> (if Data.mem key !(env.data) then Some env else @@ -25,9 +26,8 @@ let rec find env sym = let get env sym = match sym with - | Types.Symbol key -> + | T.Symbol { T.value = key } -> (match find env sym with | Some found_env -> Data.find key !(found_env.data) | None -> raise (Invalid_argument ("Symbol '" ^ key ^ "' not found"))) | _ -> raise (Invalid_argument "get requires a Symbol for its key") - diff --git a/ocaml/printer.ml b/ocaml/printer.ml index 1257a69..3e09019 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -1,30 +1,27 @@ +module T = Types.Types + let join sep xs = List.fold_left (fun a x -> if a = "" then x else a ^ sep ^ x) "" xs -let rec pr_pairs xs str print_readably = match xs with - | k :: v :: more -> pr_pairs more ((if str = "" then str else (str ^ ", ")) - ^ (pr_str k print_readably) - ^ " " - ^ (pr_str v print_readably)) - print_readably - | _ :: [] -> raise (Invalid_argument "Partition requires even number of items") - | [] -> str - -and pr_str mal_obj print_readably = - match mal_obj with - | Types.Int i -> string_of_int i - | Types.Symbol s -> s - | Types.Keyword s -> ":" ^ s - | Types.Nil -> "nil" - | Types.Bool true -> "true" - | Types.Bool false -> "false" - | Types.String s -> - if print_readably - then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" - else s - | Types.List xs -> - "(" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ ")" - | Types.Vector xs -> - "[" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ "]" - | Types.Map xs -> "{" ^ pr_pairs xs "" print_readably ^ "}" - | Types.Fn f -> "#<fn>" +let rec pr_str mal_obj print_readably = + let r = print_readably in + match mal_obj with + | T.Int i -> string_of_int i + | T.Symbol { T.value = s } -> s + | T.Keyword s -> ":" ^ s + | T.Nil -> "nil" + | T.Bool true -> "true" + | T.Bool false -> "false" + | T.String s -> + if r + then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" + else s + | T.List { T.value = xs } -> + "(" ^ (join " " (List.map (fun s -> pr_str s r) xs)) ^ ")" + | T.Vector { T.value = xs } -> + "[" ^ (join " " (List.map (fun s -> pr_str s r) xs)) ^ "]" + | T.Map { T.value = xs } -> + (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "{" else ", ") ^ (pr_str k r) + ^ " " ^ (pr_str v r)) xs "") + ^ "}" + | T.Fn f -> "#<fn>" diff --git a/ocaml/reader.ml b/ocaml/reader.ml index c452e05..6827597 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -1,3 +1,6 @@ +module T = Types.Types + (* ^file ^module *) + let find_re re str = List.map (function | Str.Delim x -> x | Str.Text x -> "impossible!") (List.filter (function | Str.Delim x -> true | Str.Text x -> false) @@ -17,17 +20,17 @@ type list_reader = { let read_atom token = match token with - | "nil" -> Types.Nil - | "true" -> Types.Bool true - | "false" -> Types.Bool false + | "nil" -> T.Nil + | "true" -> T.Bool true + | "false" -> T.Bool false | _ -> match token.[0] with - | '0'..'9' -> Types.Int (int_of_string token) - | '"' -> Types.String (Str.global_replace (Str.regexp "\\\\\\(.\\)") + | '0'..'9' -> T.Int (int_of_string token) + | '"' -> T.String (Str.global_replace (Str.regexp "\\\\\\(.\\)") "\\1" (String.sub token 1 ((String.length token) - 2))) - | ':' -> Types.Keyword (Str.replace_first (Str.regexp "^:") "" token) - | _ -> Types.Symbol token + | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token) + | _ -> Types.symbol token let rec read_list list_reader = match list_reader.tokens with @@ -43,7 +46,7 @@ let rec read_list list_reader = tokens = reader.tokens} and read_quote sym tokens = let reader = read_form tokens in - {form = Types.List [ Types.Symbol sym; reader.form ]; + {form = Types.list [ Types.symbol sym; reader.form ]; tokens = reader.tokens} and read_form all_tokens = match all_tokens with @@ -54,17 +57,18 @@ and read_form all_tokens = | "`" -> read_quote "quasiquote" tokens | "~" -> read_quote "unquote" tokens | "~@" -> read_quote "splice-unquote" tokens + | "@" -> read_quote "deref" tokens | "(" -> let list_reader = read_list {list_form = []; tokens = tokens} in - {form = Types.List list_reader.list_form; + {form = Types.list list_reader.list_form; tokens = list_reader.tokens} | "{" -> let list_reader = read_list {list_form = []; tokens = tokens} in - {form = Types.Map list_reader.list_form; + {form = Types.list_into_map Types.MalMap.empty list_reader.list_form; tokens = list_reader.tokens} | "[" -> let list_reader = read_list {list_form = []; tokens = tokens} in - {form = Types.Vector list_reader.list_form; + {form = Types.vector list_reader.list_form; tokens = list_reader.tokens} | _ -> {form = read_atom token; tokens = tokens} diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index d5ec9a3..7be4a3e 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -1,3 +1,5 @@ +module T = Types.Types + module Env = Map.Make ( String @@ -7,9 +9,9 @@ module Env = end)*) ) -let num_fun f = Types.Fn +let num_fun f = T.Fn (function - | [(Types.Int a); (Types.Int b)] -> Types.Int (f a b) + | [(T.Int a); (T.Int b)] -> T.Int (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty @@ -20,15 +22,15 @@ let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty let rec eval_ast ast env = match ast with - | Types.Symbol s -> + | T.Symbol { T.value = s } -> (try Env.find s !env with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) - | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) + | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = let result = eval_ast ast env in match result with - | Types.List ((Types.Fn f) :: args) -> (f args) + | T.List { T.value = ((T.Fn f) :: args) } -> (f args) | _ -> result let read str = Reader.read_str str diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 3f64cae..3bb0be0 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -1,28 +1,30 @@ -let num_fun f = Types.Fn +module T = Types.Types + +let num_fun f = T.Fn (function - | [(Types.Int a); (Types.Int b)] -> Types.Int (f a b) + | [(T.Int a); (T.Int b)] -> T.Int (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) let repl_env = Env.make None let init_repl env = begin - Env.set env (Types.Symbol "+") (num_fun ( + )); - Env.set env (Types.Symbol "-") (num_fun ( - )); - Env.set env (Types.Symbol "*") (num_fun ( * )); - Env.set env (Types.Symbol "/") (num_fun ( / )); + Env.set env (Types.symbol "+") (num_fun ( + )); + Env.set env (Types.symbol "-") (num_fun ( - )); + Env.set env (Types.symbol "*") (num_fun ( * )); + Env.set env (Types.symbol "/") (num_fun ( / )); end let rec eval_ast ast env = match ast with - | Types.Symbol s -> Env.get env ast - | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = match ast with - | Types.List [(Types.Symbol "def!"); key; expr] -> + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> let value = (eval expr env) in Env.set env key value; value - | Types.List [(Types.Symbol "let*"); (Types.List bindings); body] -> + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> @@ -32,9 +34,9 @@ and eval ast env = | [] -> ()) in bind_pairs bindings; eval body sub_env) - | Types.List _ -> + | T.List _ -> (match eval_ast ast env with - | Types.List ((Types.Fn f) :: args) -> f args + | T.List { T.value = ((T.Fn f) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index bf8a5ab..72ac09d 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -1,16 +1,18 @@ +module T = Types.Types + let repl_env = Env.make (Some Core.ns) let rec eval_ast ast env = match ast with - | Types.Symbol s -> Env.get env ast - | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = match ast with - | Types.List [(Types.Symbol "def!"); key; expr] -> + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> let value = (eval expr env) in Env.set env key value; value - | Types.List [(Types.Symbol "let*"); (Types.List bindings); body] -> + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> @@ -20,19 +22,19 @@ and eval ast env = | [] -> ()) in bind_pairs bindings; eval body sub_env) - | Types.List ((Types.Symbol "do") :: body) -> - List.fold_left (fun x expr -> eval expr env) Types.Nil body - | Types.List [Types.Symbol "if"; test; then_expr; else_expr] -> + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | Types.List [Types.Symbol "if"; test; then_expr] -> - if Types.to_bool (eval test env) then (eval then_expr env) else Types.Nil - | Types.List [Types.Symbol "fn*"; Types.List arg_names; expr] -> - Types.Fn + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + T.Fn (function args -> let sub_env = Env.make (Some env) in let rec bind_args a b = (match a, b with - | [Types.Symbol "&"; name], args -> Env.set sub_env name (Types.List args); + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); | (name :: names), (arg :: args) -> Env.set sub_env name arg; bind_args names args; @@ -40,9 +42,9 @@ and eval ast env = | _ -> raise (Invalid_argument "Bad param count in fn call")) in bind_args arg_names args; eval expr sub_env) - | Types.List _ -> + | T.List _ -> (match eval_ast ast env with - | Types.List ((Types.Fn f) :: args) -> f args + | T.List { T.value = ((T.Fn f) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/types.ml b/ocaml/types.ml index 6440580..287cc88 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,15 +1,46 @@ -type mal_type = - | List of mal_type list - | Vector of mal_type list - | Map of mal_type list - | Int of int - | Symbol of string - | Keyword of string - | Nil - | Bool of bool - | String of string - | Fn of (mal_type list -> mal_type) +module rec Types + : sig + type 'a with_meta = { value : 'a; meta : t } + and t = + | List of t list with_meta + | Vector of t list with_meta + | Map of t MalMap.t with_meta + | Int of int + | Symbol of string with_meta + | Keyword of string + | Nil + | Bool of bool + | String of string + | Fn of (t list -> t) + end = Types + +and MalValue + : sig + type t = Types.t + val compare : t -> t -> int + end + = struct + type t = Types.t + let compare = Pervasives.compare + end + +and MalMap + : Map.S with type key = MalValue.t + = Map.Make(MalValue) let to_bool x = match x with - | Nil | Bool false -> false + | Types.Nil | Types.Bool false -> false | _ -> true + +type mal_type = MalValue.t + +let list x = Types.List { Types.value = x; meta = Types.Nil } +let map x = Types.Map { Types.value = x; meta = Types.Nil } +let vector x = Types.Vector { Types.value = x; meta = Types.Nil } +let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil } + +let rec list_into_map target source = + match source with + | k :: v :: more -> list_into_map (MalMap.add k v target) more + | [] -> map target + | _ :: [] -> raise (Invalid_argument "Literal maps must contain an even number of forms") |