Commit 028f2979 authored by Sylvain Dailler's avatar Sylvain Dailler Committed by MARCHE Claude

fix #219 Use snapshot of printers to display messages. Improve error.

The snapshots using duplicate_ident_printer are there to avoid editing the
printer during display of error.
This also improves the error messages for transformation apply by adding
an error exception.
parent ec84bc97
......@@ -254,6 +254,12 @@ let create_ident_printer ?(sanitizer = same) sl =
sanitizer = sanitizer;
blacklist = sl }
let duplicate_ident_printer id_printer =
{id_printer with
indices = Hstr.copy id_printer.indices;
values = Hid.copy id_printer.values;
}
let known_id printer id =
try
(let _ = Hid.find printer.values id in true)
......
......@@ -115,6 +115,13 @@ val create_ident_printer :
?sanitizer : (string -> string) -> string list -> ident_printer
(** start a new printer with a sanitizing function and a blacklist *)
val duplicate_ident_printer: ident_printer -> ident_printer
(** This is used to avoid editing the current (mutable) printer when raising
exception or printing information messages for the user.
This should be avoided for any other usage including display of the whole
task.
*)
val id_unique :
ident_printer -> ?sanitizer : (string -> string) -> ident -> string
(** use ident_printer to generate a unique name for ident
......
......@@ -743,7 +743,7 @@ let schedule_transformation c id name args ~callback ~notification =
| NoProgress ->
(* if result is same as input task, consider it as a failure *)
callback (TSfailed (id, NoProgress))
| (Arg_trans _ | Arg_trans_decl _
| (Arg_trans _ | Arg_trans_decl _ | Arg_trans_missing _
| Arg_trans_term _ | Arg_trans_term2 _
| Arg_trans_pattern _ | Arg_trans_type _ | Arg_bad_hypothesis _
| Cannot_infer_type _ | Unnecessary_terms _ | Parse_error _
......
This diff is collapsed.
......@@ -151,8 +151,11 @@ let print_id s tables =
let d = (* Not_found should not happend *)
Ident.Mid.find (symbol_name table_id) km
in
let pr = tables.Trans.printer in
let apr = tables.Trans.aprinter in
(* We use snapshots of printers to avoid registering new value insides it only
to print info messages to the user.
*)
let pr = Ident.duplicate_ident_printer tables.Trans.printer in
let apr = Ident.duplicate_ident_printer tables.Trans.aprinter in
let module P = (val Pretty.create pr apr pr pr false) in
(* Different constructs are printed differently *)
match d.Decl.d_node, table_id with
......@@ -217,11 +220,15 @@ let search ~search_both s tables =
(List.length ids)
(Pp.print_list Pp.space (fun fmt id -> Pp.string fmt id.Ident.id_string))
ids
else let l = Decl.Sdecl.elements l in
let pr = tables.Trans.printer in
let apr = tables.Trans.aprinter in
let module P = (val Pretty.create pr apr pr pr false) in
Pp.string_of (Pp.print_list Pp.newline2 P.print_decl) l
else
let l = Decl.Sdecl.elements l in
(* We use snapshots of printers to avoid registering new value insides it
only to print info messages to the user.
*)
let pr = Ident.duplicate_ident_printer tables.Trans.printer in
let apr = Ident.duplicate_ident_printer tables.Trans.aprinter in
let module P = (val Pretty.create pr apr pr pr false) in
Pp.string_of (Pp.print_list Pp.newline2 P.print_decl) l
let print_id _cont task args =
match args with
......
......@@ -84,9 +84,9 @@ let with_terms ~trans_name subst_ty subst lv withed_terms =
^ " terms in with are useless"))
| _ when diff > 0 ->
Debug.dprintf debug_matching "Not enough withed terms@.";
raise (Arg_trans (trans_name ^ ": there are " ^
raise (Arg_trans_missing (trans_name ^ ": there are " ^
string_of_int diff
^ " terms missing"))
^ " terms missing:", slv))
| _ (* when diff = 0 *) ->
let new_subst_ty, new_subst =
try first_order_matching slv lv withed_terms with
......
......@@ -19,6 +19,7 @@ exception Arg_trans_term of (string * term)
exception Arg_trans_term2 of (string * term * term)
exception Arg_trans_pattern of (string * pattern * pattern)
exception Arg_trans_type of (string * Ty.ty * Ty.ty)
exception Arg_trans_missing of (string * Svs.t)
exception Arg_bad_hypothesis of (string * term)
exception Cannot_infer_type of string
exception Unnecessary_terms of term list
......
......@@ -17,6 +17,7 @@ exception Arg_trans_term of (string * term)
exception Arg_trans_term2 of (string * term * term)
exception Arg_trans_pattern of (string * pattern * pattern)
exception Arg_trans_type of (string * Ty.ty * Ty.ty)
exception Arg_trans_missing of (string * Svs.t)
exception Arg_bad_hypothesis of (string * term)
exception Cannot_infer_type of string
exception Unnecessary_terms of term list
......
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