Better type annotation

bin/dune

@@ -6,6 +6,8 @@
 
 (env
  (dev
-  (flags (:standard -w +42)))
+  (flags
+   (:standard -w +42)))
  (release
-  (ocamlopt_flags (:standard -O3))))
+  (ocamlopt_flags
+   (:standard -O3))))

bin/main.ml

@@ -27,8 +27,7 @@ let () =
   let input_channel = get_input_channel () in
   let stream =
     if input_channel = stdin then (
-      print_endline
-        "MLisp v0.1.5 (main, 2023-01-02 8:47 PM) [OCaml 5.0.0]\n";
+      print_endline "MLisp v0.1.6 (main, 2023-01-02 9:19 PM) [OCaml 5.0.0]\n";
       make_filestream input_channel)
     else make_filestream input_channel ~file_name:Sys.argv.(1)
   in

lib/ast.ml

@@ -82,10 +82,11 @@ and if_expr cond if_true if_false =
 and record_expr name fields =
   Defexpr (Defrecord (name, assert_unique_args fields))
 
-and lambda_expr args body = Lambda (assert_unique_args args, build_ast body)
+and lambda_expr args body =
+  Lambda ("lambda", assert_unique_args args, build_ast body)
 
 and defun_expr fn_name args body =
-  let lam = Lambda (assert_unique_args args, build_ast body) in
+  let lam = Lambda (fn_name, assert_unique_args args, build_ast body) in
   Defexpr (Setq (fn_name, Let (LETREC, [ (fn_name, lam) ], Var fn_name)))
 
 and apply_expr fn_expr args = Apply (build_ast fn_expr, build_ast args)
@@ -121,7 +122,7 @@ let rec string_expr =
   | Call (f, es) ->
       if List.length es == 0 then "(" ^ string_expr f ^ spacesep_exp es ^ ")"
       else "(" ^ string_expr f ^ " " ^ spacesep_exp es ^ ")"
-  | Lambda (args, body) ->
+  | Lambda (_, args, body) ->
       "(lambda (" ^ Utils.spacesep args ^ ") " ^ string_expr body ^ ")"
   | Defexpr (Setq (n, e)) -> "(setq " ^ n ^ " " ^ string_expr e ^ ")"
   | Defexpr (Defun (n, ns, e)) ->

lib/eval.ml

@@ -52,7 +52,7 @@ let rec eval_expr expr env =
         eval_apply (eval fn) (Object.pair_to_list (eval args)) env
     | Call (Var "env", []) -> Environment.env_to_val env
     | Call (fn, args) -> eval_apply (eval fn) (List.map eval args) env
-    | Lambda (args, body) -> Closure (args, body, env)
+    | Lambda (name, args, body) -> Closure (name, args, body, env)
     | Let (LET, bindings, body) ->
         let eval_binding (n, e) = (n, ref (Some (eval e))) in
         eval_expr body (extend (List.map eval_binding bindings) env)
@@ -81,7 +81,7 @@ let rec eval_expr expr env =
 and eval_apply fn_expr args env =
   match fn_expr with
   | Primitive (_, fn) -> fn args
-  | Closure (names, expr, clenv) -> eval_closure names expr args clenv env
+  | Closure (_, names, expr, clenv) -> eval_closure names expr args clenv env
   | _ ->
       raise (Parse_error_exn (Type_error "(apply prim '(args)) or (prim args)"))
 
@@ -95,13 +95,14 @@ and eval_def def env =
       (v, Environment.bind (name, v, env))
   | Defun (name, args, body) ->
       let formals, body', cl_env =
-        match eval_expr (Lambda (args, body)) env with
-        | Closure (fs, bod, env) -> (fs, bod, env)
+        match eval_expr (Lambda (name, args, body)) env with
+        | Closure (_, fs, bod, env) -> (fs, bod, env)
         | _ -> raise (Parse_error_exn (Type_error "Expecting closure."))
       in
       let loc = Environment.make_local () in
       let clo =
-        Closure (formals, body', Environment.bind_local (name, loc, cl_env))
+        Closure
+          (name, formals, body', Environment.bind_local (name, loc, cl_env))
       in
       let () = loc := Some clo in
       (clo, Environment.bind_local (name, loc, env))

lib/object.ml

@@ -90,8 +90,8 @@ let rec string_object e =
   | Pair _ -> "(" ^ (if is_list e then string_list e else string_pair e) ^ ")\n"
   | Primitive (name, _) -> "#<primitive:" ^ name ^ ">"
   | Quote expr -> "'" ^ string_object expr
-  | Closure (name_list, _, _) ->
-      "#<closure:(" ^ String.concat " " name_list ^ ")>"
+  | Closure (name, name_list, _, _) ->
+      "#<" ^ name ^ ":(" ^ String.concat " " name_list ^ ")>"
   | Record (name, fields) ->
       let fields_string =
         let to_string field = object_type field ^ " : " ^ string_object field in

lib/reader.ml

@@ -50,39 +50,34 @@ let read_char stream =
       ch
 
 let unread_char stream ch = stream.chrs <- ch :: stream.chrs
-let is_whitespace ch = match ch with ' ' | '\t' | '\n' -> true | _ -> false
 
 let rec eat_whitespace stream =
   let ch = read_char stream in
-  if is_whitespace ch then eat_whitespace stream else unread_char stream ch
+  if Core.Char.is_whitespace ch then eat_whitespace stream
+  else unread_char stream ch
 
 let rec eat_comment stream =
   if read_char stream = '\n' then () else eat_comment stream
 
-let is_digit ch =
-  let code = Char.code ch in
-  code >= Char.code '0' && code <= Char.code '9'
-
 let read_fixnum stream acc =
   let rec loop acc =
     let num_char = read_char stream in
-    if is_digit num_char then num_char |> Char.escaped |> ( ^ ) acc |> loop
+    if Core.Char.is_digit num_char then
+      num_char |> Char.escaped |> ( ^ ) acc |> loop
     else
       let _ = unread_char stream num_char in
       Fixnum (int_of_string acc)
   in
   loop acc
 
-let is_symbol_start_char =
-  let is_alpha = function 'A' .. 'Z' | 'a' .. 'z' -> true | _ -> false in
-  function
+let is_symbol_start_char = function
   | '*' | '/' | '>' | '<' | '=' | '?' | '!' | '-' | '+' -> true
-  | ch -> is_alpha ch
+  | ch -> Core.Char.is_alpha ch
 
 let rec read_symbol stream =
   let is_delimiter = function
     | '(' | ')' | '{' | '}' | ';' -> true
-    | ch -> is_whitespace ch
+    | ch -> Core.Char.is_whitespace ch
   in
   let next_char = read_char stream in
   if is_delimiter next_char then
@@ -115,7 +110,7 @@ let rec read_sexpr stream =
     read_sexpr stream)
   else if is_symbol_start_char ch then
     Symbol (Object.string_of_char ch ^ read_symbol stream)
-  else if is_digit ch || Char.equal ch '~' then
+  else if Core.Char.is_digit ch || Char.equal ch '~' then
     (if Char.equal '~' ch then '-' else ch)
     |> Char.escaped |> read_fixnum stream
   else if Char.equal ch '(' then read_list stream

lib/stdlib.ml

@@ -31,4 +31,4 @@ let rec slurp stm env =
 
 let stdlib =
   let stm = Reader.make_stringstream Mlisp_stdlib.Stdlib.stdlib_string in
-  slurp stm Environment.basis
+  slurp stm Environment.basis

lib/stdlib/dune

@@ -1,3 +1,3 @@
 (library
  (name mlisp_stdlib)
- (libraries core))
+ (libraries core))

lib/stdlib/stdlib.ml

@@ -187,4 +187,4 @@ let stdlib_string =
   \             (half (/ size 2))\n\
   \             (first (take half ls))\n\
   \             (second (drop half ls)))\n\
-  \        (merge (mergesort first) (mergesort second))))))\n\n"
+  \        (merge (mergesort first) (mergesort second))))))\n\n"

lib/types.ml

@@ -33,7 +33,7 @@ module Object = struct
     | Record of name * lobject list
     | Primitive of string * (lobject list -> lobject)
     | Quote of value
-    | Closure of name list * expr * value Environment.env
+    | Closure of name * name list * expr * value Environment.env
 
   and value = lobject
   and name = string
@@ -49,7 +49,7 @@ module Object = struct
     | Call of expr * expr list
     | Defexpr of def
     | Consexpr of cons
-    | Lambda of name list * expr
+    | Lambda of name * name list * expr
     | Let of let_kind * (name * expr) list * expr
 
   and def =

lib/utils.ml

@@ -31,4 +31,4 @@ let read_lines filename =
     close_in chan;
     List.rev !lines
 
-let spacesep ns = String.concat " " ns
+let spacesep ns = String.concat " " ns

test/05_mutually_recursive_functions.mlisp

@@ -26,4 +26,4 @@
       3
       (f (- x 2))))
 
-(println (f 10))
+(f 10)

test/dune

@@ -1,4 +1,5 @@
 (test
  (name mlisp)
- (flags (:standard -w -32))
+ (flags
+  (:standard -w -32))
  (libraries mlisp))

test/mlisp.ml

@@ -23,21 +23,16 @@ let is_mlisp_file file_name =
   match String.split_on_char '.' file_name with
   | _ :: [ "mlisp" ] -> true
   | _ -> false
-;;
 
 let test_mlisp_file file_name =
   Sys.command (exec_path ^ " " ^ test_path ^ file_name) |> ignore
-;;
 
 let test_files =
-  test_path
-  |> Sys.readdir
+  test_path |> Sys.readdir
   |> Array.iter (fun file_name ->
-         if is_mlisp_file file_name
-         then (
+         if is_mlisp_file file_name then (
            flush_all ();
            Printf.printf "Test %s ..." file_name;
            test_mlisp_file file_name;
            print_endline "done!")
          else ())
-;;