Commit eda0779c authored by Pietro Abate's avatar Pietro Abate
Browse files

Better error handling for astprinter

parent 94aec9e0
......@@ -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\
......
Printexc.record_backtrace true;;
let verbose = ref false
let typed = ref false
......
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)
......@@ -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 _ =
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment