OCaml: Add step 9

ragne · Jan 30, 2015 · ecd3b6d · ecd3b6d
1 parent fb21afa
commit ecd3b6d
Show file tree

Hide file tree

Showing 13 changed files with 326 additions and 38 deletions.
diff --git a/ocaml/Makefile b/ocaml/Makefile
@@ -1,6 +1,6 @@
 STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \
         step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \
-	step8_macros.ml
+	step8_macros.ml step9_try.ml
 MODULES = types.ml reader.ml printer.ml env.ml core.ml
 LIBS = str.cmxa
 MAL_LIB = mal_lib.cmxa

diff --git a/ocaml/core.ml b/ocaml/core.ml
@@ -16,6 +16,38 @@ let seq = function
      Types.MalMap.fold (fun k v list -> k :: v :: list) xs []
   | _ -> []
 
+let rec assoc = function
+  | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs)
+  | [T.Map { T.value = m; T.meta = meta }; k; v]
+    -> T.Map { T.value = (Types.MalMap.add k v m);
+               T.meta = meta;
+               T.is_macro = false}
+  | _ -> T.Nil
+
+let rec dissoc = function
+  | c :: x :: (_ :: _ as xs) -> dissoc ((dissoc [c; x]) :: xs)
+  | [T.Map { T.value = m; T.meta = meta }; k]
+    -> T.Map { T.value = (Types.MalMap.remove k m);
+               T.meta = meta;
+               T.is_macro = false}
+  | _ -> T.Nil
+
+let rec conj = function
+  | c :: x :: (_ :: _ as xs) -> conj ((conj [c; x]) :: xs)
+  | [T.Map { T.value = c; T.meta = meta }; T.Vector { T.value = [k; v] }]
+    -> T.Map { T.value = (Types.MalMap.add k v c);
+               T.meta = meta;
+               T.is_macro = false}
+  | [T.List { T.value = c; T.meta = meta }; x ]
+    -> T.List { T.value = x :: c;
+                T.meta = meta;
+                T.is_macro = false}
+  | [T.Vector { T.value = c; T.meta = meta }; x ]
+    -> T.Vector { T.value = c @ [x];
+                  T.meta = meta;
+                  T.is_macro = false}
+  | _ -> T.Nil
+
 let init env = begin
   Env.set env (Types.symbol "+")  (num_fun mk_int  ( +  ));
   Env.set env (Types.symbol "-")  (num_fun mk_int  ( -  ));
@@ -29,6 +61,9 @@ let init env = begin
   Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs));
   Env.set env (Types.symbol "list?")
     (Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "vector") (Types.fn (function xs -> Types.vector xs));
+  Env.set env (Types.symbol "vector?")
+    (Types.fn (function [T.Vector _] -> T.Bool true | _ -> T.Bool false));
   Env.set env (Types.symbol "empty?")
     (Types.fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false));
   Env.set env (Types.symbol "count")
@@ -87,5 +122,75 @@ let init env = begin
     (Types.fn (function
                 | [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> [])
                 | _ -> T.Nil));
-end
 
+  Env.set env (Types.symbol "symbol")
+    (Types.fn (function [T.String x] -> Types.symbol x | _ -> T.Nil));
+  Env.set env (Types.symbol "symbol?")
+    (Types.fn (function [T.Symbol _] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "keyword")
+    (Types.fn (function [T.String x] -> T.Keyword x | _ -> T.Nil));
+  Env.set env (Types.symbol "keyword?")
+    (Types.fn (function [T.Keyword _] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "nil?")
+    (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "true?")
+    (Types.fn (function [T.Bool true] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "false?")
+    (Types.fn (function [T.Bool false] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "sequential?")
+    (Types.fn (function [T.List _] | [T.Vector _] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "apply")
+    (Types.fn (function
+                | (T.Fn { T.value = f } :: apply_args) ->
+                   (match List.rev apply_args with
+                    | last_arg :: rev_args ->
+                       f ((List.rev rev_args) @ (seq last_arg))
+                    | [] -> f [])
+                | _ -> raise (Invalid_argument "First arg to apply must be a fn")));
+  Env.set env (Types.symbol "map")
+    (Types.fn (function
+                | [T.Fn { T.value = f }; xs] ->
+                   Types.list (List.map (fun x -> f [x]) (seq xs))
+                | _ -> T.Nil));
+  Env.set env (Types.symbol "readline")
+    (Types.fn (function
+                | [T.String x] -> print_string x; T.String (read_line ())
+                | _ -> T.String (read_line ())));
+
+  Env.set env (Types.symbol "map?")
+    (Types.fn (function [T.Map _] -> T.Bool true | _ -> T.Bool false));
+  Env.set env (Types.symbol "hash-map")
+    (Types.fn (function xs -> Types.list_into_map Types.MalMap.empty xs));
+  Env.set env (Types.symbol "assoc") (Types.fn assoc);
+  Env.set env (Types.symbol "dissoc") (Types.fn dissoc);
+  Env.set env (Types.symbol "get")
+    (Types.fn (function
+                | [T.Map { T.value = m }; k]
+                  -> (try Types.MalMap.find k m with _ -> T.Nil)
+                | _ -> T.Nil));
+  Env.set env (Types.symbol "keys")
+    (Types.fn (function
+                | [T.Map { T.value = m }]
+                  -> Types.list (Types.MalMap.fold (fun k _ c -> k :: c) m [])
+                | _ -> T.Nil));
+  Env.set env (Types.symbol "vals")
+    (Types.fn (function
+                | [T.Map { T.value = m }]
+                  -> Types.list (Types.MalMap.fold (fun _ v c -> v :: c) m [])
+                | _ -> T.Nil));
+  Env.set env (Types.symbol "contains?")
+    (Types.fn (function
+                | [T.Map { T.value = m }; k] -> T.Bool (Types.MalMap.mem k m)
+                | _ -> T.Bool false));
+  Env.set env (Types.symbol "conj") (Types.fn conj);
+
+  Env.set env (Types.symbol "atom")
+          (Types.fn (function [x] -> T.Atom (ref x) | _ -> T.Nil));
+  Env.set env (Types.symbol "deref")
+          (Types.fn (function [T.Atom x] -> !x | _ -> T.Nil));
+  Env.set env (Types.symbol "reset!")
+          (Types.fn (function [T.Atom x; v] -> x := v; v | _ -> T.Nil));
+  Env.set env (Types.symbol "swap!")
+          (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args
+                              -> let v = f (!x :: args) in x := v; v | _ -> T.Nil));
+end
diff --git a/ocaml/env.ml b/ocaml/env.ml
@@ -29,5 +29,5 @@ let get env sym =
     | 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")))
+         | None -> raise (Invalid_argument ("'" ^ key ^ "' not found")))
     | _ -> raise (Invalid_argument "get requires a Symbol for its key")
diff --git a/ocaml/printer.ml b/ocaml/printer.ml
@@ -6,6 +6,7 @@ let meta obj =
     | T.Map    { T.meta = meta } -> meta
     | T.Vector { T.meta = meta } -> meta
     | T.Symbol { T.meta = meta } -> meta
+    | T.Fn     { T.meta = meta } -> meta
     | _ -> T.Nil
 
 let rec pr_str mal_obj print_readably =
@@ -30,7 +31,8 @@ let rec pr_str mal_obj print_readably =
       | T.Vector { T.value = xs } ->
           "[" ^ (String.concat " " (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 "")
+         "{" ^ (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>"
+      | T.Atom x -> "(atom " ^ (pr_str !x r) ^ ")"
diff --git a/ocaml/reader.ml b/ocaml/reader.ml
@@ -48,10 +48,11 @@ let read_atom token =
 
 let with_meta obj meta =
   match obj with
-    | T.List   { T.value = value } -> T.List   { T.value = value; T.meta = meta };
-    | T.Map    { T.value = value } -> T.Map    { T.value = value; T.meta = meta };
-    | T.Vector { T.value = value } -> T.Vector { T.value = value; T.meta = meta };
-    | T.Symbol { T.value = value } -> T.Symbol { T.value = value; T.meta = meta };
+    | T.List   { T.value = v } -> T.List   { T.value = v; T.meta = meta; T.is_macro = false };
+    | T.Map    { T.value = v } -> T.Map    { T.value = v; T.meta = meta; T.is_macro = false };
+    | T.Vector { T.value = v } -> T.Vector { T.value = v; T.meta = meta; T.is_macro = false };
+    | T.Symbol { T.value = v } -> T.Symbol { T.value = v; T.meta = meta; T.is_macro = false };
+    | T.Fn     { T.value = v } -> T.Fn     { T.value = v; T.meta = meta; T.is_macro = false };
     | _ -> raise (Invalid_argument "metadata not supported on this type")
 
 let rec read_list eol list_reader =

diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml
@@ -26,11 +26,16 @@ let rec eval_ast ast env =
        (try Env.find s !env
         with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found")))
     | T.List { T.value = xs; T.meta = meta }
-      -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.List { T.value = (List.map (fun x -> eval x env) xs);
+                  T.meta = meta;
+                  T.is_macro = false}
     | T.Vector { T.value = xs; T.meta = meta }
-      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+                    T.meta = meta;
+                    T.is_macro = false}
     | T.Map { T.value = xs; T.meta = meta }
       -> T.Map {T.meta = meta;
+                T.is_macro = false;
                 T.value = (Types.MalMap.fold
                              (fun k v m
                               -> Types.MalMap.add (eval k env) (eval v env) m)
@@ -40,7 +45,7 @@ let rec eval_ast ast env =
 and eval ast env =
   let result = eval_ast ast env in
     match result with
-      | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> (f args)
+      | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> (f args)
       | _ -> result
 
 let read str = Reader.read_str str

diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml
@@ -18,11 +18,16 @@ let rec eval_ast ast env =
   match ast with
     | T.Symbol s -> Env.get env ast
     | T.List { T.value = xs; T.meta = meta }
-      -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.List { T.value = (List.map (fun x -> eval x env) xs);
+                  T.meta = meta;
+                  T.is_macro = false}
     | T.Vector { T.value = xs; T.meta = meta }
-      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+                    T.meta = meta;
+                    T.is_macro = false}
     | T.Map { T.value = xs; T.meta = meta }
       -> T.Map {T.meta = meta;
+                T.is_macro = false;
                 T.value = (Types.MalMap.fold
                              (fun k v m
                               -> Types.MalMap.add (eval k env) (eval v env) m)
@@ -47,7 +52,7 @@ and eval ast env =
           eval body sub_env)
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.value = 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
@@ -6,11 +6,16 @@ let rec eval_ast ast env =
   match ast with
     | T.Symbol s -> Env.get env ast
     | T.List { T.value = xs; T.meta = meta }
-      -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.List { T.value = (List.map (fun x -> eval x env) xs);
+                  T.meta = meta;
+                  T.is_macro = false}
     | T.Vector { T.value = xs; T.meta = meta }
-      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+                    T.meta = meta;
+                    T.is_macro = false}
     | T.Map { T.value = xs; T.meta = meta }
       -> T.Map {T.meta = meta;
+                T.is_macro = false;
                 T.value = (Types.MalMap.fold
                              (fun k v m
                               -> Types.MalMap.add (eval k env) (eval v env) m)
@@ -56,7 +61,7 @@ and eval ast env =
               eval expr sub_env)
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | _ -> eval_ast ast env
 

diff --git a/ocaml/step6_file.ml b/ocaml/step6_file.ml
@@ -6,11 +6,16 @@ let rec eval_ast ast env =
   match ast with
     | T.Symbol s -> Env.get env ast
     | T.List { T.value = xs; T.meta = meta }
-      -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.List { T.value = (List.map (fun x -> eval x env) xs);
+                  T.meta = meta;
+                  T.is_macro = false}
     | T.Vector { T.value = xs; T.meta = meta }
-      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+                    T.meta = meta;
+                    T.is_macro = false}
     | T.Map { T.value = xs; T.meta = meta }
       -> T.Map {T.meta = meta;
+                T.is_macro = false;
                 T.value = (Types.MalMap.fold
                              (fun k v m
                               -> Types.MalMap.add (eval k env) (eval v env) m)
@@ -56,7 +61,7 @@ and eval ast env =
               eval expr sub_env)
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | _ -> eval_ast ast env
 

diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml
@@ -18,11 +18,16 @@ let rec eval_ast ast env =
   match ast with
     | T.Symbol s -> Env.get env ast
     | T.List { T.value = xs; T.meta = meta }
-      -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.List { T.value = (List.map (fun x -> eval x env) xs);
+                  T.meta = meta;
+                  T.is_macro = false}
     | T.Vector { T.value = xs; T.meta = meta }
-      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+                    T.meta = meta;
+                    T.is_macro = false}
     | T.Map { T.value = xs; T.meta = meta }
       -> T.Map {T.meta = meta;
+                T.is_macro = false;
                 T.value = (Types.MalMap.fold
                              (fun k v m
                               -> Types.MalMap.add (eval k env) (eval v env) m)
@@ -71,7 +76,7 @@ and eval ast env =
        eval (quasiquote ast) env
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | _ -> eval_ast ast env
 

diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml
@@ -18,19 +18,24 @@ let rec macroexpand ast env =
   match ast with
   | T.List { T.value = s :: args } ->
      (match (try Env.get env s with _ -> T.Nil) with
-      | T.Fn { T.f = f; T.is_macro = true } -> macroexpand (f args) env
+      | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env
       | _ -> ast)
   | _ -> ast
 
 let rec eval_ast ast env =
   match ast with
     | T.Symbol s -> Env.get env ast
     | T.List { T.value = xs; T.meta = meta }
-      -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.List { T.value = (List.map (fun x -> eval x env) xs);
+                  T.meta = meta;
+                  T.is_macro = false}
     | T.Vector { T.value = xs; T.meta = meta }
-      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+                    T.meta = meta;
+                    T.is_macro = false}
     | T.Map { T.value = xs; T.meta = meta }
       -> T.Map {T.meta = meta;
+                T.is_macro = false;
                 T.value = (Types.MalMap.fold
                              (fun k v m
                               -> Types.MalMap.add (eval k env) (eval v env) m)
@@ -44,8 +49,8 @@ and eval ast env =
           Env.set env key value; value
     | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } ->
        (match (eval expr env) with
-          | T.Fn { T.f = f } ->
-             let fn = T.Fn { T.f = f; is_macro = true } in
+          | T.Fn { T.value = f; T.meta = meta } ->
+             let fn = T.Fn { T.value = f; is_macro = true; meta = meta } in
              Env.set env key fn; fn
           | _ -> raise (Invalid_argument "devmacro! value must be a fn"))
     | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] }
@@ -87,7 +92,7 @@ and eval ast env =
        macroexpand ast env
     | T.List _ as ast ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | ast -> eval_ast ast env