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.

src/core/ident.ml

@@ -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)

src/core/ident.mli

@@ -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

src/session/controller_itp.ml

@@ -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 _

src/session/server_utils.ml

@@ -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

src/transform/apply.ml

@@ -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

src/transform/generic_arg_trans_utils.ml

@@ -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

src/transform/generic_arg_trans_utils.mli

@@ -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