Support Parse error

lib/ast.ml

@@ -21,7 +21,8 @@ open Types.Ast
 
 let rec assert_unique = function
   | [] -> ()
-  | x :: xs -> if List.mem x xs then raise (Unique_error_exn x) else assert_unique xs
+  | x :: xs ->
+    if List.mem x xs then raise (Parse_error_exn (Unique_error x)) else assert_unique xs
 ;;
 
 let let_kinds = [ "let", LET; "let*", LETSTAR; "letrec", LETREC ]
@@ -47,7 +48,7 @@ let rec build_ast sexpr =
         List.map
           (function
             | Symbol s -> s
-            | _ -> raise (Type_error_exn "(lambda (formals) body)"))
+            | _ -> raise (Parse_error_exn (Type_error "(lambda (formals) body)")))
           (Object.pair_to_list args)
       in
       let () = assert_unique names in
@@ -58,7 +59,7 @@ let rec build_ast sexpr =
         List.map
           (function
             | Symbol s -> s
-            | _ -> raise (Type_error_exn "(defun name (formals) body)"))
+            | _ -> raise (Parse_error_exn (Type_error "(defun name (formals) body)")))
           (Object.pair_to_list args)
       in
       let () = assert_unique names in
@@ -67,20 +68,20 @@ let rec build_ast sexpr =
     | [ Symbol s; bindings; expr ] when Object.is_list bindings && valid_let s ->
       let make_binding = function
         | Pair (Symbol n, Pair (expr, Nil)) -> n, build_ast expr
-        | _ -> raise (Type_error_exn "(let bindings expr)")
+        | _ -> raise (Parse_error_exn (Type_error "(let bindings expr)"))
       in
       let bindings = List.map make_binding (Object.pair_to_list bindings) in
       let () = assert_unique (List.map fst bindings) in
       Let (to_kind s, bindings, build_ast expr)
     | fn_expr :: args -> Call (build_ast fn_expr, List.map build_ast args)
-    | [] -> raise (Parse_error_exn "poorly formed expression"))
+    | [] -> raise (Parse_error_exn Poorly_formed_expression))
   | Pair _ -> Literal sexpr
 
 and cond_to_if = function
   | [] -> Literal (Symbol "error")
   | Pair (cond, Pair (res, Nil)) :: condpairs ->
     If (build_ast cond, build_ast res, cond_to_if condpairs)
-  | _ -> raise (Type_error_exn "(cond conditions)")
+  | _ -> raise (Parse_error_exn (Type_error "(cond conditions)"))
 ;;
 
 let spacesep ns = String.concat " " ns

lib/environment.ml

@@ -17,14 +17,14 @@
 (****************************************************************************)
 
 open Types.Object
-open Types.Environment
+open Types.Eval
 
 let rec lookup = function
-  | n, [] -> raise (Not_found_exn n)
+  | n, [] -> raise (Runtime_error_exn (Not_found n))
   | n, (n', v) :: _ when n = n' ->
     (match !v with
     | Some v' -> v'
-    | None -> raise (Unspecified_value_exn n))
+    | None -> raise (Runtime_error_exn (Unspecified_value n)))
   | n, (_, _) :: bs -> lookup (n, bs)
 ;;
 

lib/error.ml

@@ -0,0 +1,135 @@
+(****************************************************************************)
+(* MLisp                                                                    *)
+(* Copyright (C) 2022 Muqiu Han                                             *)
+(*                                                                          *)
+(* This program is free software: you can redistribute it and/or modify     *)
+(* it under the terms of the GNU Affero General Public License as published *)
+(* by the Free Software Foundation, either version 3 of the License, or     *)
+(* (at your option) any later version.                                      *)
+(*                                                                          *)
+(* This program is distributed in the hope that it will be useful,          *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of           *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the            *)
+(* GNU Affero General Public License for more details.                      *)
+(*                                                                          *)
+(* You should have received a copy of the GNU Affero General Public License *)
+(* along with this program.  If not, see <https://www.gnu.org/licenses/>.   *)
+(****************************************************************************)
+
+open Types.Reader
+open Types.Error
+open Types.Ast
+
+let message = function
+  | Syntax_error_exn e ->
+    "Syntax error -> "
+    ^
+    (match e with
+    | Unexcepted_character c -> "Unexcepted character : '" ^ c ^ "'"
+    | Invalid_boolean_literal b -> "Invalid boolean literal : '" ^ b ^ "'")
+  | Parse_error_exn e ->
+    "Parse error -> "
+    ^
+    (match e with
+    | Unique_error p -> "Unique error : " ^ p
+    | Type_error x -> "Type error : " ^ x
+    | Poorly_formed_expression -> "Poorly formed expression.")
+  | _ -> "None"
+;;
+
+let help = function
+  | Syntax_error_exn e ->
+    (match e with
+    | Unexcepted_character _ ->
+      "Usually triggered by wrong characters, such as extra parentheses, etc."
+    | Invalid_boolean_literal _ -> "Raised by incorrect boolean literals.")
+  | Parse_error_exn e ->
+    (match e with
+    | Unique_error _ -> "A conflict error caused by duplicate parameter names when defining closure."
+    | Type_error _ -> "Possible type error due to a function call with parameters of a type different from that specified in the function definition."
+    | Poorly_formed_expression -> "Syntactically incorrect or redundant elements.")
+  | _ -> "None"
+;;
+
+let repl_error { file_name; line_number; column_number; message; help } =
+  let split_line { file_name; line_number; column_number; message; help } =
+    let char_num =
+      List.fold_left
+        (fun max prev -> if prev > max then prev else max)
+        (String.length
+           (string_of_int line_number ^ string_of_int column_number ^ file_name)
+        + 31)
+        [ String.length message + 9; String.length help + 9 ]
+    in
+    "+" ^ String.make (char_num + 2) '-'
+  in
+  let split_line = split_line { file_name; line_number; column_number; message; help } in
+  Ocolor_format.printf
+    "\n\
+     @{<hi_white>%s@}\n\
+     @{<hi_white>|@} @{<hi_cyan>From : \"%s\" , Line: %d , Column: %d@}\n\
+     @{<hi_white>|@} @{<hi_red>| Error: %s@}\n\
+     @{<hi_white>|@} @{<hi_green>| Help : %s@}\n\
+     @{<hi_white>%s@}\n"
+    split_line
+    file_name
+    line_number
+    column_number
+    message
+    help
+    split_line
+;;
+
+let file_error { file_name; line_number; column_number; message; help } =
+  let split_line { file_name; line_number; column_number; message; help } line_value =
+    let char_num =
+      List.fold_left
+        (fun max prev -> if prev > max then prev else max)
+        (String.length
+           (string_of_int line_number ^ string_of_int column_number ^ file_name)
+        + 31)
+        [ String.length message + 9
+        ; String.length help + 9
+        ; String.length line_value + 8
+        ]
+    in
+    "+" ^ String.make char_num '-'
+  in
+  let line_value = List.nth (Utils.read_lines file_name) (line_number - 1) in
+  let split_line =
+    split_line { file_name; line_number; column_number; message; help } line_value
+  in
+  let tip_mark = "+" ^ String.make (String.length line_value + 5) '-' ^ "^" in
+  Ocolor_format.printf
+    "\n\
+     @{<hi_white>%s@}\n\
+     @{<hi_white>|@} @{<hi_cyan>From : \"%s\" , Line: %d , Column: %d@}\n\
+     @{<hi_white>|@}------> @{<hi_white>%s@}\n\
+     @{<hi_white>|@} @{<hi_red>%s@}\n\
+     @{<hi_white>|@} @{<hi_red>| Error: %s@}\n\
+     @{<hi_white>|@} @{<hi_green>| Help : %s@}\n\
+     @{<hi_white>%s@}\n"
+    split_line
+    file_name
+    line_number
+    column_number
+    line_value
+    tip_mark
+    message
+    help
+    split_line
+;;
+
+let print_error (a_stream : 'a stream) exn =
+  let data =
+    { file_name = a_stream.file_name
+    ; line_number = a_stream.line_num
+    ; column_number = a_stream.column_number
+    ; message = message exn
+    ; help = help exn
+    }
+  in
+  if a_stream.stdin
+  then data |> repl_error |> ignore |> flush_all
+  else data |> file_error |> ignore |> flush_all
+;;

lib/eval.ml

@@ -19,7 +19,6 @@
 include Ast
 open Types.Object
 open Types.Ast
-open Types.Eval
 
 let extend newenv oldenv =
   List.fold_right (fun (b, v) acc -> Environment.bind_local (b, v, acc)) newenv oldenv
@@ -40,15 +39,15 @@ let rec eval_expr expr env =
     | Var n -> Environment.lookup (n, env)
     | If (cond, if_true, _) when eval cond = Boolean true -> eval if_true
     | If (cond, _, if_false) when eval cond = Boolean false -> eval if_false
-    | If _ -> raise (Type_error_exn "(if bool e1 e2)")
+    | If _ -> raise (Parse_error_exn (Type_error "(if bool e1 e2)"))
     | And (cond_x, cond_y) ->
       (match eval cond_x, eval cond_y with
       | Boolean x, Boolean y -> Boolean (x && y)
-      | _ -> raise (Type_error_exn "(and bool bool)"))
+      | _ -> raise (Parse_error_exn (Type_error "(and bool bool)")))
     | Or (cond_x, cond_y) ->
       (match eval cond_x, eval cond_y with
       | Boolean x, Boolean y -> Boolean (x || y)
-      | _ -> raise (Type_error_exn "(or bool bool)"))
+      | _ -> raise (Parse_error_exn (Type_error "(or bool bool)")))
     | Apply (fn, args) -> 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
@@ -69,14 +68,13 @@ let rec eval_expr expr env =
       eval_expr body env'
     | Defexpr _ -> raise This_can't_happen_exn
   in
-  try eval expr with
-  | e -> raise (Eval_error_exn ("Error: " ^ (Printexc.to_string e) ^ " in expression : " ^ string_expr expr ))
+  eval expr
 
 and eval_apply fn_expr args _env =
   match fn_expr with
-  | Primitive (_, fn) -> fn args;
+  | Primitive (_, fn) -> fn args
   | Closure (names, expr, clenv) -> eval_closure names expr args clenv
-  | _ -> raise (Type_error_exn "(apply prim '(args)) or (prim args)")
+  | _ -> raise (Parse_error_exn (Type_error "(apply prim '(args)) or (prim args)"))
 
 and eval_closure names expr args clenv =
   eval_expr expr (Environment.bind_list names args clenv)
@@ -91,7 +89,7 @@ let eval_def def env =
     let formals, body', cl_env =
       match eval_expr (Lambda (args, body)) env with
       | Closure (fs, bod, env) -> fs, bod, env
-      | _ -> raise (Type_error_exn "Expecting closure.")
+      | _ -> 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)) in

lib/primitives.ml

@@ -26,66 +26,66 @@ let rec list = function
 
 let pair = function
   | [ a; b ] -> Pair (a, b)
-  | _ -> raise (Type_error_exn "(pair a b)")
+  | _ -> raise (Parse_error_exn (Type_error "(pair a b)"))
 ;;
 
 let car = function
   | [ Pair (car, _) ] -> car
-  | _ -> raise (Type_error_exn "(car non-nil-pair)")
+  | _ -> raise (Parse_error_exn (Type_error "(car non-nil-pair)"))
 ;;
 
 let cdr = function
   | [ Pair (_, cdr) ] -> cdr
-  | _ -> raise (Type_error_exn "(cdr non-nil-pair)")
+  | _ -> raise (Parse_error_exn (Type_error "(cdr non-nil-pair)"))
 ;;
 
 let atomp = function
   | [ Pair (_, _) ] -> Boolean false
   | [ _ ] -> Boolean true
-  | _ -> raise (Type_error_exn "(atom? something)")
+  | _ -> raise (Parse_error_exn (Type_error "(atom? something)"))
 ;;
 
 let eq = function
   | [ a; b ] -> Boolean (a = b)
-  | _ -> raise (Type_error_exn "(eq a b)")
+  | _ -> raise (Parse_error_exn (Type_error "(eq a b)"))
 ;;
 
 let symp = function
   | [ Symbol _ ] -> Boolean true
   | [ _ ] -> Boolean false
-  | _ -> raise (Type_error_exn "(sym? single-arg)")
+  | _ -> raise (Parse_error_exn (Type_error "(sym? single-arg)"))
 ;;
 
 let getchar = function
   | [] ->
     (try Fixnum (int_of_char @@ input_char stdin) with
     | End_of_file -> Fixnum (-1))
-  | _ -> raise (Type_error_exn "(getchar)")
+  | _ -> raise (Parse_error_exn (Type_error "(getchar)"))
 ;;
 
 let print = function
   | [ v ] ->
     let () = print_string @@ Ast.string_object v in
     Symbol "ok"
-  | _ -> raise (Type_error_exn "(print object)")
+  | _ -> raise (Parse_error_exn (Type_error "(print object)"))
 ;;
 
 let int_to_char = function
   | [ Fixnum i ] -> Symbol (Object.string_of_char @@ char_of_int i)
-  | _ -> raise (Type_error_exn "(int_to_char int)")
+  | _ -> raise (Parse_error_exn (Type_error "(int_to_char int)"))
 ;;
 
 let cat = function
   | [ Symbol a; Symbol b ] -> Symbol (a ^ b)
-  | _ -> raise (Type_error_exn "(cat sym sym)")
+  | _ -> raise (Parse_error_exn (Type_error "(cat sym sym)"))
 ;;
 
 module Num = struct
   let generate name operator =
     ( name
     , function
       | [ Fixnum a; Fixnum b ] -> Fixnum (operator a b)
-      | _ -> raise (Type_error_exn ("(" ^ name ^ " int int)")) )
+      | _ -> raise (Parse_error_exn (Type_error ("(" ^ name ^ " int int)"))))
   ;;
 end
 
@@ -94,6 +94,6 @@ module Cmp = struct
     ( name
     , function
       | [ Fixnum a; Fixnum b ] -> Boolean (operator a b)
-      | _ -> raise (Type_error_exn ("(" ^ name ^ " int int)")) )
+      | _ -> raise (Parse_error_exn (Type_error ("(" ^ name ^ " int int)"))))
   ;;
 end

lib/stdlib.ml

@@ -24,7 +24,7 @@ let stdlib_path = "/usr/include/mlisp/stdlib.mlisp"
 let eval env e =
   match e with
   | Defexpr d -> Eval.eval_def d env
-  | _ -> raise (Type_error_exn "Can only have definitions in stdlib")
+  | _ -> raise (Parse_error_exn (Type_error "Can only have definitions in stdlib"))
 ;;
 
 let rec slurp stm env =

lib/types.ml

@@ -18,9 +18,6 @@
 
 module Environment = struct
   type 'a env = (string * 'a option ref) list
-
-  exception Not_found_exn of string
-  exception Unspecified_value_exn of string
 end
 
 module Object = struct
@@ -64,10 +61,15 @@ module Object = struct
 end
 
 module Ast = struct
-  exception Parse_error_exn of string
-  exception Unique_error_exn of string
+
   exception Undefined_symbol_exn of string
-  exception Type_error_exn of string
+
+  type parse_error = 
+    | Unique_error of string
+    | Type_error of string
+    | Poorly_formed_expression
+
+    exception Parse_error_exn of parse_error
 end
 
 module Reader = struct
@@ -88,7 +90,11 @@ module Reader = struct
 end
 
 module Eval = struct
-  exception Eval_error_exn of string
+  type runtime_error = 
+    | Not_found of string
+    | Unspecified_value of string
+
+  exception Runtime_error_exn of runtime_error
 end
 
 module Error = struct