add proper error handling and error message

Author: bobzhang

jscomp/bin/all_ounit_tests.i.ml

@@ -22,9 +22,16 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+type error_info
+
+exception Error of error_info
+
+val pp_error : Format.formatter -> error_info -> unit 
 
 val parse_json : Lexing.lexbuf -> Ext_json_types.t 
 val parse_json_from_string : string -> Ext_json_types.t 
+
 val parse_json_from_chan : in_channel -> Ext_json_types.t 
+
 val parse_json_from_file  : string -> Ext_json_types.t
 

jscomp/bin/all_ounit_tests.ml

@@ -43,20 +43,36 @@ let report_error ppf = function
     -> fprintf ppf "Unterminated_comment"
 
 
+type  error_info  = 
+  { error : error ;
+    loc_start : Lexing.position; 
+    loc_end :Lexing.position;
+  }
+
+let pp_error fmt {error; loc_start ; loc_end } = 
+  Format.fprintf fmt "@[%a:@ %a@ -@ %a)@]" 
+    report_error error
+    Ext_position.print loc_start
+    Ext_position.print loc_end
+
+exception Error of error_info
+
+
 
 let () = 
   Printexc.register_printer
     (function x -> 
      match x with 
-     | Error (e , a, b) -> 
-       Some (Format.asprintf "@[%a:@ %a@ -@ %a)@]" report_error e 
-               Ext_position.print a Ext_position.print b)
+     | Error error_info -> 
+       Some (Format.asprintf "%a" pp_error error_info)
+
      | _ -> None
     )
 
 
 
 
+
 type token = 
   | Comma
   | Eof
@@ -71,9 +87,11 @@ type token =
   | String of string
   | True   
 
-
 let error  (lexbuf : Lexing.lexbuf) e = 
-  raise (Error (e, lexbuf.lex_start_p, lexbuf.lex_curr_p))
+  raise (Error { error =  e; 
+                 loc_start =  lexbuf.lex_start_p; 
+                 loc_end = lexbuf.lex_curr_p})
+
 
 let lexeme_len (x : Lexing.lexbuf) =
   x.lex_curr_pos - x.lex_start_pos

jscomp/bin/bsb.ml

@@ -155,8 +155,23 @@ external ff :
          ( [`a | `b ] [@bs.string] ) 
          (* auto-convert to ocaml poly-variant *)
       *)
-    end
+    end;
 
+    __LOC__ >:: begin fun _ -> 
+      let should_err = bsc_eval {|
+      type t 
+      external mk : int -> (_ [@bs.as {json| { x : 3 } |json}]) ->  t = "" [@@bs.val]
+      |} in 
+      OUnit.assert_bool __LOC__ (Ext_string.contain_substring should_err.stderr "Invalid json literal")
+    end
+    ;
+    __LOC__ >:: begin fun _ -> 
+      let should_err = bsc_eval {|
+      type t 
+      external mk : int -> (_ [@bs.as {json| { "x" : 3 } |json}]) ->  t = "" [@@bs.val]
+      |} in 
+      OUnit.assert_bool __LOC__ (Ext_string.is_empty should_err.stderr)
+    end
 
 
   ]

jscomp/bin/bsdep.ml

@@ -56,12 +56,30 @@ type kind =
     arg_label : label
   }
 
-let cst_json s : cst  =
+type invalid_json = Ext_json_parse.error_info
+
+let pp_invaild_json fmt err = 
+  Format.fprintf fmt "@[Invalid json literal:  %a@]@." 
+    Ext_json_parse.pp_error err 
+exception Error of Location.t * invalid_json
+
+let () = 
+  Location.register_error_of_exn (function 
+    | Error (loc,err) -> 
+      Some (Location.error_of_printer loc pp_invaild_json err)
+    | _ -> None
+    )
+
+
+let cst_json loc s : cst  =
   match Ext_json_parse.parse_json (Lexing.from_string s) with 
   | True _ -> Arg_js_true
   | False _ -> Arg_js_false 
   | Null _ -> Arg_js_null 
   | _ -> Arg_js_json s 
+  | exception Ext_json_parse.Error error_info
+    -> raise (Error (loc , error_info))
+
 let cst_int i = Arg_int_lit i 
 let cst_string s = Arg_string_lit s 
 let empty_label = Empty None 

jscomp/bin/bsppx.ml

@@ -55,7 +55,7 @@ type kind =
     arg_label :label
   }
 
-val cst_json : string -> cst 
+val cst_json : Location.t -> string -> cst 
 val cst_int : int -> cst 
 val cst_string : string -> cst 
 

jscomp/bin/whole_compiler.ml

@@ -44,7 +44,8 @@ let get_arg_type ~nolabel optional
   if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
     if optional then 
       Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
-    else begin match Ast_attributes.process_bs_string_or_int_as ptyp.Parsetree.ptyp_attributes with 
+    else begin
+      match Ast_attributes.process_bs_string_or_int_as ptyp.Parsetree.ptyp_attributes with 
       |  None, _ -> 
         Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
 
@@ -56,7 +57,8 @@ let get_arg_type ~nolabel optional
         Arg_cst (Ast_arg.cst_string i), Ast_literal.type_string ~loc:ptyp.ptyp_loc () 
       | Some (`Json_str s), others ->
         Ast_attributes.warn_unused_attributes others;
-        Arg_cst (Ast_arg.cst_json s), Ast_literal.type_string ~loc:ptyp.ptyp_loc () 
+        Arg_cst (Ast_arg.cst_json ptyp.ptyp_loc s),
+        Ast_literal.type_string ~loc:ptyp.ptyp_loc () 
 
     end 
   else (* ([`a|`b] [@bs.string]) *)

jscomp/ext/ext_json_parse.ml

@@ -30,19 +30,19 @@ process.on(function (i) {
 xx(3, 3, "xxx", "a", "b");
 
 function f(x) {
-  x.xx(109, /* int array */[
+  x.xx(110, /* int array */[
         1,
         2,
         3
       ]);
-  x.xx(110, 3, "xxx", /* int array */[
+  x.xx(111, 3, "xxx", /* int array */[
         1,
         2,
         3
       ]);
-  x.xx(111, 3, "xxx", 1, 2, 3);
-  x.xx(112, 3, "xxx", 0, "b", 1, 2, 3, 4, 5);
-  x.xx(113, 3, true, false, ("你好"), ( ["你好",1,2,3] ), ( [{ "arr" : ["你好",1,2,3], "encoding" : "utf8"}] ), "xxx", 0, "yyy", "b", 1, 2, 3, 4, 5);
+  x.xx(112, 3, "xxx", 1, 2, 3);
+  x.xx(113, 3, "xxx", 0, "b", 1, 2, 3, 4, 5);
+  x.xx(114, 3, true, false, ("你好"), ( ["你好",1,2,3] ), ( [{ "arr" : ["你好",1,2,3], "encoding" : "utf8"}] ), ( [{ "arr" : ["你好",1,2,3], "encoding" : "utf8"}] ), "xxx", 0, "yyy", "b", 1, 2, 3, 4, 5);
   return /* () */0;
 }
 

jscomp/ext/ext_json_parse.mli

@@ -92,6 +92,7 @@ external on_exit_slice5 :
     -> (_ [@bs.as {json|"你好"|json}])
     -> (_ [@bs.as {json| ["你好",1,2,3] |json}])
     -> (_ [@bs.as {json| [{ "arr" : ["你好",1,2,3], "encoding" : "utf8"}] |json}])
+    -> (_ [@bs.as {json| [{ "arr" : ["你好",1,2,3], "encoding" : "utf8"}] |json}])
     -> (_ [@bs.as "xxx"]) 
     -> ([`a|`b|`c] [@bs.int])
     -> (_ [@bs.as "yyy"])