Ocaml: various style changes

impls/ocaml/Dockerfile

@@ -1,4 +1,4 @@
-FROM ubuntu:24.04
+FROM ubuntu:25.04
 MAINTAINER Joel Martin <[email protected]>
 
 ##########################################################
@@ -19,4 +19,4 @@ WORKDIR /mal
 # Specific implementation requirements
 ##########################################################
 
-RUN apt-get -y install ocaml-batteries-included
+RUN apt-get -y install ocaml

impls/ocaml/Makefile

@@ -4,6 +4,8 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \
 MODULES = types.ml reader.ml printer.ml env.ml core.ml
 LIBS = str.cmxa unix.cmxa
 MAL_LIB = mal_lib.cmxa
+# Apparently necessary with caml 5.0:
+OPTIONS = -I +str -I +unix
 
 STEP_BINS = $(STEPS:%.ml=%)
 LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS))
@@ -22,10 +24,10 @@ repl:
 	rlwrap ocaml $(LIBS:%.cmxa=%.cma) $(MODULES:%.ml=%.cmo)
 
 $(MAL_LIB): $(MODULES)
-	ocamlopt -a $(MODULES) -o $@
+	ocamlopt -a $(MODULES) -o $@ $(OPTIONS)
 
 $(STEP_BINS): %: %.ml $(MAL_LIB)
-	ocamlopt $(LIBS) $(MAL_LIB) $< -o $@
+	ocamlopt $(LIBS) $(MAL_LIB) $< -o $@ $(OPTIONS)
 
 clean:
 	rm -f $(STEP_BINS) mal mal_lib.* *.cmo *.cmx *.cmi *.o

impls/ocaml/core.ml

@@ -11,11 +11,19 @@ let num_fun t f = Types.fn
 let mk_int x = T.Int x
 let mk_bool x = T.Bool x
 
+let rec mal_equal a b = match (a, b) with
+  | (T.List   { T.value = xs }, T.List   { T.value = ys })
+  | (T.List   { T.value = xs }, T.Vector { T.value = ys })
+  | (T.Vector { T.value = xs }, T.List   { T.value = ys })
+  | (T.Vector { T.value = xs }, T.Vector { T.value = ys })
+      -> List.equal mal_equal xs ys
+  | (T.Map { T.value = xs }, T.Map { T.value = ys })
+    -> Types.MalMap.equal mal_equal xs ys
+  | _ -> a = b
+
 let seq = function
   | T.List   { T.value = xs } -> xs
   | T.Vector { T.value = xs } -> xs
-  | T.Map    { T.value = xs } ->
-     Types.MalMap.fold (fun k v list -> k :: v :: list) xs []
   | _ -> []
 
 let mal_seq = function
@@ -29,25 +37,16 @@ let mal_seq = function
   | _ ->  T.Nil
 
 let rec assoc = function
-  | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs)
-  | [T.Nil; k; v] -> Types.map (Types.MalMap.add k v Types.MalMap.empty)
-  | [T.Map { T.value = m; T.meta = meta }; k; v]
-    -> T.Map { T.value = (Types.MalMap.add k v m);
-               T.meta = meta }
+  | T.Map { T.value = m } :: xs -> Types.list_into_map m xs
   | _ -> 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.Map { T.value = m } :: xs ->
+     Types.map (List.fold_left (fun k m -> Types.MalMap.remove m k) m xs)
   | _ -> 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.List { T.value = c; T.meta = meta }; x ]
     -> T.List { T.value = x :: c;
                 T.meta = meta }
@@ -87,35 +86,52 @@ let init env = begin
                 | _ -> T.Int 0));
   Env.set env "="
     (Types.fn (function
-                | [a; b] -> T.Bool (Types.mal_equal a b)
+                | [a; b] -> T.Bool (mal_equal a b)
                 | _ -> T.Bool false));
 
   Env.set env "pr-str"
     (Types.fn (function xs ->
-      T.String (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs))));
+      T.String (Format.asprintf "%a" (Printer.pr_list true true) xs)));
   Env.set env "str"
     (Types.fn (function xs ->
-      T.String (String.concat "" (List.map (fun s -> Printer.pr_str s false) xs))));
+      T.String (Format.asprintf "%a" (Printer.pr_list false false) xs)));
   Env.set env "prn"
     (Types.fn (function xs ->
-      print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs));
+      Format.printf "%a\n" (Printer.pr_list true true) xs;
       T.Nil));
   Env.set env "println"
     (Types.fn (function xs ->
-      print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s false) xs));
+      Format.printf "%a\n" (Printer.pr_list false true) xs;
       T.Nil));
 
   Env.set env "compare"
     (Types.fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil));
   Env.set env "with-meta"
-    (Types.fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil));
+    (Types.fn (function
+      | [T.List   v; m] -> T.List   { v with T.meta = m }
+      | [T.Map    v; m] -> T.Map    { v with T.meta = m }
+      | [T.Vector v; m] -> T.Vector { v with T.meta = m }
+      | [T.Fn     v; m] -> T.Fn     { v with   meta = m }
+      | _ -> T.Nil));
   Env.set env "meta"
-    (Types.fn (function [x] -> Printer.meta x | _ -> T.Nil));
+    (Types.fn (function
+      | [T.List   { T.meta = meta }] -> meta
+      | [T.Map    { T.meta = meta }] -> meta
+      | [T.Vector { T.meta = meta }] -> meta
+      | [T.Fn     {   meta = meta }] -> meta
+      | _ -> T.Nil));
 
   Env.set env "read-string"
     (Types.fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil));
   Env.set env "slurp"
-    (Types.fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil));
+    (Types.fn (function
+      | [T.String x] ->
+         let chan = open_in x in
+         let b = Buffer.create 27 in
+         Buffer.add_channel b chan (in_channel_length chan) ;
+         close_in chan ;
+         T.String (Buffer.contents b)
+      | _ -> T.Nil));
 
   Env.set env "cons"
     (Types.fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil));
@@ -162,14 +178,11 @@ let init env = begin
     (Types.fn (function [T.Int _] -> T.Bool true | _ -> T.Bool false));
   Env.set env "fn?"
     (Types.fn (function
-                | [T.Fn { T.meta = T.Map { T.value = meta } }]
-                  -> mk_bool (not (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta)))
-                | [T.Fn _] -> T.Bool true
+                | [T.Fn { macro = false } ] -> T.Bool true
                 | _ -> T.Bool false));
   Env.set env "macro?"
     (Types.fn (function
-                | [T.Fn { T.meta = T.Map { T.value = meta } }]
-                  -> mk_bool (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta))
+                | [T.Fn { macro = true }] -> T.Bool true
                 | _ -> T.Bool false));
   Env.set env "nil?"
     (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false));
@@ -181,26 +194,27 @@ let init env = begin
     (Types.fn (function [T.List _] | [T.Vector _] -> T.Bool true | _ -> T.Bool false));
   Env.set env "apply"
     (Types.fn (function
-                | (T.Fn { T.value = f } :: apply_args) ->
+                | (T.Fn { 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 "map"
     (Types.fn (function
-                | [T.Fn { T.value = f }; xs] ->
+                | [T.Fn { value = f }; xs] ->
                    Types.list (List.map (fun x -> f [x]) (seq xs))
                 | _ -> T.Nil));
   Env.set env "readline"
     (Types.fn (function
-                | [T.String x] -> print_string x; T.String (read_line ())
+                | [T.String x] -> Format.printf "%s%!" x;
+                                  T.String (read_line ())
                 | _ -> T.String (read_line ())));
 
   Env.set env "map?"
     (Types.fn (function [T.Map _] -> T.Bool true | _ -> T.Bool false));
   Env.set env "hash-map"
-    (Types.fn (function xs -> Types.list_into_map Types.MalMap.empty xs));
+    (Types.fn (Types.list_into_map Types.MalMap.empty));
   Env.set env "assoc" (Types.fn assoc);
   Env.set env "dissoc" (Types.fn dissoc);
   Env.set env "get"
@@ -234,7 +248,7 @@ let init env = begin
   Env.set env "reset!"
           (Types.fn (function [T.Atom x; v] -> x := v; v | _ -> T.Nil));
   Env.set env "swap!"
-          (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args
+          (Types.fn (function T.Atom x :: T.Fn { value = f } :: args
                               -> let v = f (!x :: args) in x := v; v | _ -> T.Nil));
 
   Env.set env "time-ms"

impls/ocaml/env.ml

@@ -13,7 +13,7 @@ let set env key value =
 
 let rec get env key =
   match Data.find_opt key !(env.data) with
-    | Some value -> Some value
+    | Some _ as v -> v
     | None       -> match env.outer with
       | Some outer -> get outer key
       | None       -> None

impls/ocaml/printer.ml

@@ -1,37 +1,39 @@
+open Format
+
 module T = Types.Types
 
-let meta obj =
-  match obj with
-    | T.List   { T.meta = meta } -> meta
-    | T.Map    { T.meta = meta } -> meta
-    | T.Vector { T.meta = meta } -> meta
-    | T.Fn     { T.meta = meta } -> meta
-    | _ -> T.Nil
+(* Compile the regex once and for all *)
+let _pr_escape_re = Str.regexp "\\([\"\\\n]\\)"
+let _pr_escape_chunk out = function
+  | Str.Text s     -> fprintf out "%s" s
+  | Str.Delim "\n" -> fprintf out "\\n"
+  | Str.Delim s    -> fprintf out "\\%s" s
+let _pr_escape_string out s =
+  List.iter (_pr_escape_chunk out) (Str.full_split _pr_escape_re s)
 
-let rec pr_str mal_obj print_readably =
-  let r = print_readably in
+let rec pr_str readably out mal_obj =
     match mal_obj with
-      | T.Int i -> string_of_int i
-      | T.Symbol s -> s
-      | T.Keyword s -> ":" ^ s
-      | T.Nil -> "nil"
-      | T.Bool true -> "true"
-      | T.Bool false -> "false"
-      | T.String s ->
-          if r
-          then  "\"" ^ (Reader.gsub (Str.regexp "\\([\"\\\n]\\)")
-                                    (function
-                                      | "\n" -> "\\n"
-                                      | x -> "\\" ^ x)
-                                    s) ^ "\""
-          else s
+      | T.Int i -> fprintf out "%i" i
+      | T.Keyword s -> fprintf out ":%s" s
+      | T.Nil -> fprintf out "nil"
+      | T.Bool b -> fprintf out "%B" b
+      | T.String s when readably -> fprintf out "\"%a\"" _pr_escape_string s
+      | T.String s | T.Symbol s  -> fprintf out "%s" s
       | T.List { T.value = xs } ->
-          "(" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ ")"
+         fprintf out "(%a)" (pr_list readably true) xs
       | T.Vector { T.value = xs } ->
-          "[" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ "]"
+         fprintf out "[%a]" (pr_list readably true) 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>"
-      | T.Atom x -> "(atom " ^ (pr_str !x r) ^ ")"
+         fprintf out "{%a}" (_pr_map readably) xs
+      | T.Fn _ -> fprintf out "#<fn>"
+      | T.Atom x -> fprintf out "(atom %a)" (pr_str readably) !x
+and pr_list readably spaced out =
+  List.iter (
+    let sep = ref "" in fun x ->
+      fprintf out "%s%a" !sep (pr_str readably) x;
+      if spaced && !sep == "" then sep := " " else ())
+and _pr_map readably out =
+  Types.MalMap.iter (
+    let sep = ref "" in fun k v ->
+      fprintf out "%s%a %a" !sep (pr_str readably) k (pr_str readably) v;
+      if !sep == "" then sep := " " else ())

impls/ocaml/reader.ml

@@ -1,13 +1,6 @@
 module T = Types.Types
         (* ^file ^module *)
 
-let slurp filename =
-  let chan = open_in filename in
-  let b = Buffer.create 27 in
-  Buffer.add_channel b chan (in_channel_length chan) ;
-  close_in chan ;
-  Buffer.contents b
-
 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)
@@ -39,9 +32,7 @@ let unescape_string token =
          (function | "\\n" -> "\n" | x -> String.sub x 1 1)
          without_quotes
   else
-    (output_string stderr ("expected '\"', got EOF\n");
-     flush stderr;
-     raise End_of_file)
+    raise (Invalid_argument "expected '\"', got EOF")
 
 let read_atom token =
   match token with
@@ -60,19 +51,9 @@ let read_atom token =
       | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token)
       | _ -> T.Symbol token
 
-let with_meta obj meta =
-  match obj with
-    | T.List   { T.value = v } -> T.List   { T.value = v; T.meta = meta }
-    | T.Map    { T.value = v } -> T.Map    { T.value = v; T.meta = meta }
-    | T.Vector { T.value = v } -> T.Vector { T.value = v; T.meta = meta }
-    | T.Fn     { T.value = v } -> T.Fn     { T.value = v; T.meta = meta }
-    | _ -> raise (Invalid_argument "metadata not supported on this type")
-
 let rec read_list eol list_reader =
   match list_reader.tokens with
-    | [] -> output_string stderr ("expected '" ^ eol ^ "', got EOF\n");
-            flush stderr;
-            raise End_of_file;
+    | [] -> raise (Invalid_argument (Format.asprintf "expected '%s', got EOF" eol))
     | token :: tokens ->
       if Str.string_match (Str.regexp eol) token 0 then
         {list_form = list_reader.list_form; tokens = tokens}
@@ -89,7 +70,7 @@ and read_quote sym tokens =
      tokens = reader.tokens}
 and read_form all_tokens =
   match all_tokens with
-    | [] -> raise End_of_file;
+    | [] -> raise (Invalid_argument "no form found in the given string")
     | token :: tokens ->
       match token with
         | "'"  -> read_quote "quote" tokens
@@ -100,8 +81,7 @@ and read_form all_tokens =
         | "^"  ->
            let meta = read_form tokens in
            let value = read_form meta.tokens in
-             {(*form = with_meta value.form meta.form;*)
-              form = Types.list [T.Symbol "with-meta"; value.form; meta.form];
+             {form = Types.list [T.Symbol "with-meta"; value.form; meta.form];
               tokens = value.tokens}
         | "(" ->
            let list_reader = read_list ")" {list_form = []; tokens = tokens} in

impls/ocaml/run

@@ -1,2 +1,2 @@
-#!/bin/bash
+#!/bin/sh
 exec $(dirname $0)/${STEP:-stepA_mal} "${@}"

impls/ocaml/step0_repl.ml

@@ -9,15 +9,17 @@
   ocaml step0_repl.ml
 *)
 
+let eval ast = ast
+
 let read str = str
-let eval ast any = ast
 let print exp = exp
-let rep str = print (eval (read str) "")
+let rep str = print (eval (read str))
 
-let rec main =
-  try
-    while true do
-      print_string "user> ";
-      print_endline (rep (read_line ()));
-    done
-  with End_of_file -> ()
+let main =
+      try
+        while true do
+          Format.printf "user> %!";
+          let line = read_line () in
+          Format.printf "%s\n" (rep line)
+        done
+      with End_of_file -> Format.printf "\n"