Better error handling for astprinter

tests/lambda/Makefile

@@ -13,7 +13,7 @@ INEXTFILES  = misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
  schema/schema_common.ml runtime/eval.mli runtime/eval.ml\
  compile/compile.ml types/compunit.mli types/compunit.ml types/var.ml\
  types/boolVar.ml misc/imap.ml types/atoms.ml types/intervals.ml\
- types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli\
+ types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli types/sample.ml\
  misc/stats.mli misc/stats.ml types/normal.mli types/normal.ml misc/pretty.mli\
  misc/pretty.ml types/types.ml compile/auto_pat.mli runtime/value.mli\
  runtime/value.ml schema/schema_types.mli schema/schema_validator.mli\

tests/lambda/src/astprinter.ml

-Printexc.record_backtrace true;;
 
 let verbose = ref false
 let typed = ref false

tests/lambda/src/testlib.ml

 open Camlp4.PreCast
 
+Printexc.record_backtrace true;;
+
 module BIN = struct
   open Builtin_defs
 
@@ -40,22 +42,114 @@ module BIN = struct
       types
 end
 
-let wrap f s =
-  try f s
-  with
-    | Compute.Error -> exit 3
-    | Loc.Exc_located (loc, exn) ->
-      let l = Loc.start_line loc in
-      let cbegin = Loc.start_off loc - Loc.start_bol loc in
-      let cend = Loc.stop_off loc - Loc.start_bol loc in
-      Printf.eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
-        cbegin cend; raise exn
-    | e -> Printf.eprintf "Runtime error.\n"; raise e
+let print_norm ppf d =
+  Types.Print.print ppf ((*Types.normalize*) d)
+
+let print_sample ppf s =
+  Sample.print ppf s
+
+let print_protect ppf s =
+  Format.fprintf ppf "%s" s
+
+let print_value ppf v =
+  Value.print ppf v
+
+let rec print_exn ppf = function
+  | Cduce_loc.Location (loc, w, exn) ->
+      Cduce_loc.print_loc ppf (loc,w);
+      Cduce_loc.html_hilight (loc,w);
+      print_exn ppf exn
+  | Value.CDuceExn v ->
+      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
+        print_value v
+  | Typer.WrongLabel (t,l) ->
+      Format.fprintf ppf "Wrong record selection; field %a "
+        Ns.Label.print_attr l;
+      Format.fprintf ppf "not present in an expression of type:@.%a@."
+        print_norm t
+  | Typer.ShouldHave (t,msg) ->
+      Format.fprintf ppf "This expression should have type:@.%a@.%a@."
+        print_norm t
+        print_protect msg
+  | Typer.ShouldHave2 (t1,msg,t2) ->
+      Format.fprintf ppf "This expression should have type:@.%a@.%a %a@."
+        print_norm t1
+        print_protect msg
+        print_norm t2
+  | Typer.Error s ->
+      Format.fprintf ppf "%a@." print_protect s
+  | Typer.Constraint (s,t) ->
+      Format.fprintf ppf "This expression should have type:@.%a@."
+        print_norm t;
+      Format.fprintf ppf "but its inferred type is:@.%a@."
+        print_norm s;
+      Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@."
+      print_sample (Sample.get (Types.diff s t))
+  | Typer.NonExhaustive t ->
+      Format.fprintf ppf "This pattern matching is not exhaustive@.";
+      Format.fprintf ppf "Residual type:@.%a@."
+      print_norm t;
+      Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
+  | Typer.UnboundId (x,tn) ->
+      Format.fprintf ppf "Unbound identifier %a%s@." Ident.print x
+        (if tn then " (it is a type name)" else "")
+  | Ulexer.Error (i,j,s) ->
+      let loc = Cduce_loc.loc_of_pos (i,j), `Full in
+      Cduce_loc.print_loc ppf loc;
+      Cduce_loc.html_hilight loc;
+      Format.fprintf ppf "%s" s
+  | Parser.Error s | Stream.Error s ->
+      Format.fprintf ppf "Parsing error: %a@." print_protect s
+  | Cduce_loc.Generic s ->
+      Format.fprintf ppf "%a@." print_protect s
+  | Ns.Label.Not_unique ((ns1,s1),(ns2,s2)) ->
+      Format.fprintf ppf "Collision on label hash: {%a}:%a, {%a}:%a"
+      Ns.U.print (Ns.Uri.value ns1)
+      Ns.U.print s1
+      Ns.U.print (Ns.Uri.value ns2)
+      Ns.U.print s2
+  | Ns.Uri.Not_unique (ns1,ns2) ->
+      Format.fprintf ppf "Collision on namespaces hash: %a, %a"
+      Ns.U.print ns1
+      Ns.U.print ns2
+  | Sequence.Error (Sequence.CopyTag (t,expect)) ->
+      Format.fprintf ppf "Tags in %a will be copied, but only %a are allowed.@.Counter-example:%a@."
+      Types.Print.print t
+      Types.Print.print expect
+      Sample.print (Sample.get (Types.diff t expect))
+  | Sequence.Error (Sequence.CopyAttr (t,expect)) ->
+      Format.fprintf ppf "Attributes in %a will be copied, but only %a are allowed.@.Counter-example:%a@."
+      Types.Print.print t
+      Types.Print.print expect
+      Sample.print (Sample.get (Types.diff t expect))
+  | Sequence.Error (Sequence.UnderTag (t,exn)) ->
+      Format.fprintf ppf "Under tag %a:@." Types.Print.print t;
+      print_exn ppf exn
+
+  | exn ->
+      Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
+
+let catch_exn ppf_err exn =
+  match exn with
+  | (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
+      as e ->
+      raise e
+  | exn ->
+      print_exn ppf_err exn;
+      Format.fprintf ppf_err "@.";
+      raise exn
+;;
 
 (* Cduce program -> Typed *)
 let parse_cduce ?(verbose=false) s =
-  let astexpr = Parser.expr (Stream.of_string s) in
-  let texpr = fst (Typer.type_expr BIN.env astexpr) in
+  let astexpr = 
+    try Parser.expr (Stream.of_string s)
+    with exn -> catch_exn Format.err_formatter exn
+  in
+  let texpr = 
+    try fst (Typer.type_expr BIN.env astexpr)
+    with exn -> catch_exn Format.err_formatter exn
+  in
   if verbose then
     Format.printf "Cduce Typed %s ====> \n %s\n%!@." s (Typed.Print.typed_to_string texpr);
   texpr
@@ -70,36 +164,42 @@ let parse_texpr ?(verbose=false) s =
 
 (* --> Lambda *)
 let parse_lexpr ?(verbose=false) texpr =
-  let lambdaexpr,lsize = Compile.compile_expr Compile.empty_toplevel texpr in
+  let lambdaexpr,lsize =
+    try Compile.compile_expr Compile.empty_toplevel texpr 
+    with exn -> catch_exn Format.err_formatter exn
+  in
   if verbose then 
-    Format.printf "Lambda : %s\n" (Lambda.Print.lambda_to_string lambdaexpr);
+    Format.printf "Lambda : %s\n%!@." (Lambda.Print.lambda_to_string lambdaexpr);
   lambdaexpr, lsize
 
 (* --> Value *)
 let parse_vexpr ?(verbose=false) (lambdaexpr,lsize) =
-  let evalexpr = Eval.expr lambdaexpr lsize in
+  let evalexpr = 
+    try Eval.expr lambdaexpr lsize
+    with exn -> catch_exn Format.err_formatter exn
+  in
   if verbose then 
-    Format.printf "Value : %s\n" (Value.value_to_string evalexpr);
+    Format.printf "Value : %s\n%!@." (Value.value_to_string evalexpr);
   evalexpr
 
 (* Cduce program -> Lambda *)
 let parse_cduce_lexpr ?(verbose=false) s = 
-  let texpr = wrap (parse_cduce ~verbose) s in
+  let texpr = parse_cduce ~verbose s in
   parse_lexpr ~verbose:true texpr
 
 (* Cduce program -> Value *)
 let parse_cduce_vexpr ?(verbose=false) s = 
-  let texpr = wrap (parse_cduce ~verbose) s in
+  let texpr = parse_cduce ~verbose s in
   let lambdaexpr, lsize = parse_lexpr ~verbose texpr in
   parse_vexpr ~verbose:true (lambdaexpr,lsize)
 
 (* Typed AST -> Lambda *)
 let parse_texpr_lexpr ?(verbose=false) s =
-  let texpr = wrap (parse_texpr ~verbose) s in
+  let texpr = parse_texpr ~verbose s in
   parse_lexpr ~verbose:true texpr
 
 (* Typed AST -> Value *)
 let parse_texpr_vexpr ?(verbose=false) s =
-  let texpr = wrap (parse_texpr ~verbose) s in
+  let texpr = parse_texpr ~verbose s in
   let lambdaexpr, lsize = parse_lexpr ~verbose texpr in
   parse_vexpr ~verbose:true (lambdaexpr,lsize)

tests/lambda/src/typedTests.ml

@@ -2,8 +2,8 @@ open OUnit2
 open Testlib
 
 let run_test_typer msg expected totest _ =
-  let expected = wrap parse_texpr expected in
-  let totest = wrap parse_cduce totest in
+  let expected = parse_texpr expected in
+  let totest = parse_cduce totest in
   assert_equal ~msg:msg ~printer:(fun x -> Typed.Print.typed_to_string x) expected totest
 
 let run_test_compile msg expected totest _ =