Cleanup: updated [signal], [warning] and [grammar_warning] to also take a format.

src/error.ml

 open Printf
 
-(* TEMPORARY Vrifier que les messages d'erreur sont standardiss au
-   maximum, localiss au maximum. Supprimer autant de fonctions que
-   possible dans ce module. *)
-
-(* TEMPORARY reprendre compl`etement implementation et interface
-   de ce module *)
-
 (* ---------------------------------------------------------------------------- *)
 
 (* Global state. *)
@@ -72,46 +65,39 @@ let logC =
 let errors =
   ref false
 
-let print_positions positions =
+let display continuation header positions format =
   List.iter (fun position -> 
     fprintf stderr "%s:\n" (Positions.string_of_pos position)
-  ) positions
-
-let printN positions message = (* TEMPORARY *)
-  print_positions positions;
-  fprintf stderr "%s\n%!" message
-
-let error_message message =
-  "Error: " ^ message
-
-let error positions format =
-  print_positions positions;
+  ) positions;
   Printf.kfprintf
-    (fun _ -> exit 1)
+    continuation
     stderr
-    ("Error: " ^^ format ^^ "\n%!")
+    (header ^^ format ^^ "\n%!")
 
-let errorp v =
-  error [ Positions.position v ]
+let error positions format =
+  display
+    (fun _ -> exit 1)
+    "Error: "
+    positions format 
 
-let signal positions message =
-  printN positions message;
-  errors := true
+let signal positions format =
+  display
+    (fun _ -> errors := true)
+    "Error: "
+    positions format 
 
-let warning positions message =
-  printN positions (Printf.sprintf "Warning: %s" message)
+let warning positions format =
+  display
+    (fun _ -> ())
+    "Warning: "
+    positions format 
 
 let errors () =
   !errors
 
-(* Certain warnings about the grammar can optionally be treated as errors.
-   The following function emits a warning or error message, via [warning] or
-   [signal]. It does not stop the program; the client must at some point call
-   [errors] and stop the program if any errors have been reported. *)
+let errorp v =
+  error [ Positions.position v ]
 
-let grammar_warning positions message =
-  if Settings.strict then
-    signal positions (error_message message)
-  else
-    warning positions message
+let grammar_warning =
+  if Settings.strict then signal else warning
 

src/error.mli

@@ -34,34 +34,32 @@ val logC: int -> (out_channel -> unit) -> unit
 (* [error ps format ...] displays the list of positions [ps], followed with the
    error message [format ...], and exits. The strings "Error: " and "\n" are
    automatically added at the beginning and end of the error message. The
-   message should begin with a lowercase letter. *)
+   message should begin with a lowercase letter and end with a dot. *)
 
 val error: Positions.positions -> ('a, out_channel, unit, 'b) format4 -> 'a
 
-(* [errorp v msg] displays the error message [msg], referring to the
-   position range carried by [v], and exits. *)
+(* [errorp] is like [error], but uses the position range carried by [v]. *)
 
 val errorp: _ Positions.located -> ('a, out_channel, unit, 'b) format4 -> 'a
 
-(* [warning ps msg] displays the warning message [msg], referring to
-   the positions [ps]. *)
+(* [signal] is like [error], except it does not exit immediately. It sets a
+   flag which can be tested using [errors]. *)
 
-val warning: Positions.positions -> string -> unit
-
-(* [signal ps msg] displays the error message [msg], referring to the
-   positions [ps], and does not exit immediately. *)
-
-val signal: Positions.positions -> string -> unit
+val signal: Positions.positions -> ('a, out_channel, unit, unit) format4 -> 'a
 
 (* [errors] returns [true] if [signal] was previously called. Together
    [signal] and [errors] allow reporting multiple errors before aborting. *)
 
 val errors: unit -> bool
 
+(* [warning] is like [signal], except it does not set a flag. *)
+
+val warning: Positions.positions -> ('a, out_channel, unit, unit) format4 -> 'a
+
 (* Certain warnings about the grammar can optionally be treated as errors.
    The following function emits a warning or error message, via [warning] or
    [signal]. It does not stop the program; the client must at some point call
    [errors] and stop the program if any errors have been reported. *)
 
-val grammar_warning: Positions.positions -> string -> unit
+val grammar_warning: Positions.positions -> ('a, out_channel, unit, unit) format4 -> 'a
 

src/front.ml

@@ -134,7 +134,7 @@ let grammar =
     in
     if not Settings.infer && inlined && not skipping_parser_generation then
       Error.warning []
-	"you are using the standard library and/or the %inline keyword. We\n\
+	"you are using the standard library and/or the %%inline keyword. We\n\
 	 recommend switching on --infer in order to avoid obscure type error messages.";
     Time.tick "Inlining";
     grammar

src/grammar.ml

@@ -48,7 +48,7 @@ module TokPrecedence = struct
 	    ()
 	| PrecedenceLevel (_, _, pos1, pos2) ->
 	    Error.grammar_warning (Positions.two pos1 pos2)
-	      (Printf.sprintf "the precedence level assigned to %s is never useful." id)
+	      "the precedence level assigned to %s is never useful." id
     ) Front.grammar.tokens
 
 end
@@ -737,7 +737,7 @@ module Production = struct
         (* Check whether this %prec declaration was useless. *)
         let pos = Positions.position sym in
         if not (Hashtbl.mem ever_useful pos) then begin
-          Error.grammar_warning [pos] "this %prec declaration is never useful.";
+          Error.grammar_warning [pos] "this %%prec declaration is never useful.";
           Hashtbl.add ever_useful pos () (* hack: avoid two warnings at the same position *)
         end
       ) osym
@@ -1116,7 +1116,7 @@ let () =
     if not (NONEMPTY.nonterminal nt) then
       Error.grammar_warning
 	(Nonterminal.positions nt)
-	(Printf.sprintf "%s generates the empty language." (Nonterminal.print false nt));
+	"%s generates the empty language." (Nonterminal.print false nt);
   done
 
 (* ------------------------------------------------------------------------ *)

src/interpret.ml

@@ -337,16 +337,18 @@ let interpret_error sentence =
    an error, computes the state in which the error is obtained, and constructs
    a targeted sentence. *)
 
-let target_sentence signal : located_sentence -> maybe_targeted_sentence =
+let target_sentence
+    (signal : Positions.positions -> ('a, out_channel, unit, unit) format4 -> 'a)
+  : located_sentence -> maybe_targeted_sentence =
   fun (poss, sentence) ->
     (poss, sentence),
     interpret_error_aux poss sentence
       (* failure: *)
       (fun msg ->
-        signal poss (Printf.sprintf
-          "This sentence does not end with a syntax error, as it should.\n%s"
+        signal poss
+          "this sentence does not end with a syntax error, as it should.\n%s"
           msg
-        );
+        ;
         None
       )
       (* success: *)
@@ -537,9 +539,8 @@ let message_table (detect_redundancy : bool) (runs : filtered_targeted_run list)
         | sentence1, _ ->
             if detect_redundancy then
               Error.signal (fst sentence1 @ fst sentence2)
-                (Printf.sprintf
-                   "Redundancy: these sentences both cause an error in state %d."
-                   (Lr1.number s));
+                   "these sentences both cause an error in state %d."
+                   (Lr1.number s);
             table
         | exception Not_found ->
             Lr1.NodeMap.add s (sentence2, message) table
@@ -668,11 +669,10 @@ let () =
     (* Check that the domain of [table1] is a subset of the domain of [table2]. *)
     table1 |> Lr1.NodeMap.iter (fun s ((poss1, _), _) ->
       if not (Lr1.NodeMap.mem s table2) then
-        Error.signal poss1 (Printf.sprintf
-          "This sentence leads to an error in state %d.\n\
+        Error.signal poss1
+          "this sentence leads to an error in state %d.\n\
            No sentence that leads to this state exists in \"%s\"."
           (Lr1.number s) filename2
-        )
     );
 
     (* Check that [table1] is a subset of [table2], that is, for every state
@@ -687,11 +687,10 @@ let () =
         try
           let (poss2, _), message2 = Lr1.NodeMap.find s table2 in
           if message1 <> message2 then
-            Error.warning (poss1 @ poss2) (Printf.sprintf
-              "These sentences lead to an error in state %d.\n\
+            Error.warning (poss1 @ poss2)
+              "these sentences lead to an error in state %d.\n\
                The corresponding messages in \"%s\" and \"%s\" differ."
               (Lr1.number s) filename1 filename2
-            )
         with Not_found ->
           ()
     );

src/invariant.ml

@@ -269,16 +269,16 @@ let () =
 	  incr count;
 	  Error.grammar_warning
 	    (Nonterminal.positions nt)
-	    (Printf.sprintf "symbol %s is never accepted." (Nonterminal.print false nt))
+	    "symbol %s is never accepted." (Nonterminal.print false nt)
       | None ->
 	  incr count;
 	  Error.grammar_warning
 	    (Production.positions prod)
-	    (Printf.sprintf "production %sis never reduced." (Production.print prod))
+	    "production %sis never reduced." (Production.print prod)
   );
   if !count > 0 then
     Error.grammar_warning []
-      (Printf.sprintf "in total, %d productions are never reduced." !count)
+      "in total, %d productions are never reduced." !count
 
 (* ------------------------------------------------------------------------ *)
 (* From the above information, deduce, for each production, the states that

src/lr1.ml

@@ -892,11 +892,11 @@ let () =
   if !shift_reduce = 1 then
     Error.grammar_warning [] "one state has shift/reduce conflicts."
   else if !shift_reduce > 1 then
-    Error.grammar_warning [] (Printf.sprintf "%d states have shift/reduce conflicts." !shift_reduce);
+    Error.grammar_warning [] "%d states have shift/reduce conflicts." !shift_reduce;
   if !reduce_reduce = 1 then
     Error.grammar_warning [] "one state has reduce/reduce conflicts."
   else if !reduce_reduce > 1 then
-    Error.grammar_warning [] (Printf.sprintf "%d states have reduce/reduce conflicts." !reduce_reduce)
+    Error.grammar_warning [] "%d states have reduce/reduce conflicts." !reduce_reduce
 
 (* There is a global check for errors at the end of [Invariant], so we do
    not need to check & stop here. *)
@@ -922,11 +922,10 @@ let rec best choice = function
              2- they are derived, via inlining, from the same production. *) 
 	  Error.signal
 	    (Production.positions choice @ Production.positions prod)
-	    (Printf.sprintf
 	       "do not know how to resolve a reduce/reduce conflict\n\
                 between the following two productions:\n%s\n%s"
                   (Production.print choice)
-                  (Production.print prod));
+                  (Production.print prod);
 	  choice (* dummy *)
 
 (* Go ahead. *)
@@ -976,11 +975,11 @@ let default_conflict_resolution () =
   if !shift_reduce = 1 then
     Error.warning [] "one shift/reduce conflict was arbitrarily resolved."
   else if !shift_reduce > 1 then
-    Error.warning [] (Printf.sprintf "%d shift/reduce conflicts were arbitrarily resolved." !shift_reduce);
+    Error.warning [] "%d shift/reduce conflicts were arbitrarily resolved." !shift_reduce;
   if !reduce_reduce = 1 then
     Error.warning [] "one reduce/reduce conflict was arbitrarily resolved."
   else if !reduce_reduce > 1 then
-    Error.warning [] (Printf.sprintf "%d reduce/reduce conflicts were arbitrarily resolved." !reduce_reduce);
+    Error.warning [] "%d reduce/reduce conflicts were arbitrarily resolved." !reduce_reduce;
 
   (* Now, ensure that states that have a reduce action at the
      pseudo-token "#" have no other action. *)
@@ -1052,7 +1051,7 @@ let default_conflict_resolution () =
   if !ambiguities = 1 then
     Error.grammar_warning [] "one state has an end-of-stream conflict."
   else if !ambiguities > 1 then
-    Error.grammar_warning [] (Printf.sprintf "%d states have an end-of-stream conflict." !ambiguities)
+    Error.grammar_warning [] "%d states have an end-of-stream conflict." !ambiguities
 
 (* ------------------------------------------------------------------------ *)
 (* Extra reductions. 2015/10/19 *)
@@ -1134,7 +1133,7 @@ let extra_reductions () =
   StringSet.iter (fun nt ->
     if not (StringSet.mem nt !extra_nts) then
       Error.grammar_warning []
-        (Printf.sprintf "the declaration %%on_error_reduce %s is never useful." nt)
+        "the declaration %%on_error_reduce %s is never useful." nt
   ) OnErrorReduce.declarations
 
 (* ------------------------------------------------------------------------ *)

src/parserAux.ml

@@ -64,7 +64,7 @@ let normalize_producers producers =
 let override pos o1 o2 =
   match o1, o2 with
   | Some _, Some _ ->
-      Error.signal [ pos ] "This production carries two %prec declarations.";
+      Error.signal [ pos ] "this production carries two %%prec declarations.";
       o2
   | None, Some _ ->
       o2

src/partialGrammar.ml

@@ -734,7 +734,7 @@ let check_parameterized_grammar_is_well_defined grammar =
           if not (StringSet.mem token !used_tokens
                || StringSet.mem token Settings.ignored_unused_tokens) then
             Error.warning [p] 
-              (Printf.sprintf "the token %s is unused." token)
+              "the token %s is unused." token
         ) grammar.p_tokens
   end;
     

src/reachability.ml

@@ -32,9 +32,8 @@ let trim grammar =
       if not (StringSet.mem symbol reachable) then
 	Error.grammar_warning
 	  rule.positions
-	  (Printf.sprintf
 	     "symbol %s is unreachable from any of the start symbol(s)."
-	       symbol)
+	       symbol
     ) grammar.rules;
     { grammar with rules = StringMap.restrict reachable grammar.rules }