Ocaml: Use a real map type

T.Map is now a real OCaml binary-tree map, and supports arbitrary mal value
types for both keys and values.  Metadata support is provided in the data
objects, but not yet in the printer, reader, or core library.

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")