PR#7147: add colors to errors generated by ppx rewriters

The default error printer now adds the maybe colored "Error" prefixed
itself.

None of the convenience functions (`Location.errorf`,
`Location.error_of_printer`, ...) insert the "Error" prefix
anymore. To handle the formatting correctly, a phantom prefix is added
using `Format.pp_print_as`.

Updated the testsuite.

Changes

@@ -41,6 +41,9 @@ OCaml 4.04.0:
   (Non-exhaustivity warning for pattern matching)
   (Florian Angeletti, review and report by Gabriel Scherer)
 
+* PR#7147, GPR#475: add colors when reporting errors generated by ppx rewriters.
+  Remove the `Location.errorf_prefixed` function which is no longer relevant
+  (Simon Cruanes, Jérémie Dimino)
 
 ### Standard library:
 

parsing/location.ml

@@ -359,14 +359,14 @@ let pp_ksprintf ?before k fmt =
       k msg)
     ppf fmt
 
+(* Shift the formatter's offset by the length of the error prefix, which
+   is always added by the compiler after the message has been formatted *)
+let print_phanton_error_prefix ppf =
+  Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""
+
 let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
   pp_ksprintf
-    (fun msg -> {loc; msg; sub; if_highlight})
+    ~before:print_phanton_error_prefix
-    fmt
-
-let errorf_prefixed ?(loc=none) ?(sub=[]) ?(if_highlight="") fmt =
-  pp_ksprintf
-    ~before:(fun ppf -> fprintf ppf "%a " print_error_prefix ())
     (fun msg -> {loc; msg; sub; if_highlight})
     fmt
 
@@ -401,8 +401,7 @@ let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
   if highlighted then
     Format.pp_print_string ppf if_highlight
   else begin
-    print ppf loc;
+    fprintf ppf "%a%a %s" print loc print_error_prefix () msg;
-    Format.pp_print_string ppf msg;
     List.iter (Format.fprintf ppf "@\n@[<2>%a@]" default_error_reporter) sub
   end
 
@@ -413,7 +412,7 @@ let report_error ppf err =
 ;;
 
 let error_of_printer loc print x =
-  errorf_prefixed ~loc "%a@?" print x
+  errorf ~loc "%a@?" print x
 
 let error_of_printer_file print x =
   error_of_printer (in_file !input_name) print x
@@ -422,11 +421,11 @@ let () =
   register_error_of_exn
     (function
       | Sys_error msg ->
-          Some (errorf_prefixed ~loc:(in_file !input_name)
+          Some (errorf ~loc:(in_file !input_name)
                 "I/O error: %s" msg)
       | Warnings.Errors n ->
           Some
-            (errorf_prefixed ~loc:(in_file !input_name)
+            (errorf ~loc:(in_file !input_name)
              "Some fatal warnings were triggered (%d occurrences)" n)
       | _ ->
           None
@@ -456,4 +455,6 @@ let () =
     )
 
 let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
-  pp_ksprintf (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
+  pp_ksprintf
+    ~before:print_phanton_error_prefix
+    (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))

parsing/location.mli

@@ -112,11 +112,6 @@ val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
 val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
             -> ('a, Format.formatter, unit, error) format4 -> 'a
 
-val errorf_prefixed : ?loc:t -> ?sub:error list -> ?if_highlight:string
-                    -> ('a, Format.formatter, unit, error) format4 -> 'a
-  (* same as {!errorf}, but prints the error prefix "Error:" before yielding
-   * to the format string *)
-
 val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
             -> ('a, Format.formatter, unit, 'b) format4 -> 'a
 

parsing/syntaxerr.ml

@@ -30,9 +30,9 @@ exception Escape_error
 
 let prepare_error = function
   | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      Location.errorf_prefixed ~loc:closing_loc
+      Location.errorf ~loc:closing_loc
         ~sub:[
-          Location.errorf_prefixed ~loc:opening_loc
+          Location.errorf ~loc:opening_loc
             "This '%s' might be unmatched" opening
         ]
         ~if_highlight:
@@ -42,24 +42,24 @@ let prepare_error = function
         "Syntax error: '%s' expected" closing
 
   | Expecting (loc, nonterm) ->
-      Location.errorf_prefixed ~loc "Syntax error: %s expected." nonterm
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
   | Not_expecting (loc, nonterm) ->
-      Location.errorf_prefixed ~loc "Syntax error: %s not expected." nonterm
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
   | Applicative_path loc ->
-      Location.errorf_prefixed ~loc
+      Location.errorf ~loc
         "Syntax error: applicative paths of the form F(X).t \
          are not supported when the option -no-app-func is set."
   | Variable_in_scope (loc, var) ->
-      Location.errorf_prefixed ~loc
+      Location.errorf ~loc
         "In this scoped type, variable '%s \
          is reserved for the local type %s."
          var var
   | Other loc ->
-      Location.errorf_prefixed ~loc "Syntax error"
+      Location.errorf ~loc "Syntax error"
   | Ill_formed_ast (loc, s) ->
-      Location.errorf_prefixed ~loc "broken invariant in parsetree: %s" s
+      Location.errorf ~loc "broken invariant in parsetree: %s" s
   | Invalid_package_type (loc, s) ->
-      Location.errorf_prefixed ~loc "invalid package type: %s" s
+      Location.errorf ~loc "invalid package type: %s" s
 
 let () =
   Location.register_error_of_exn

testsuite/tests/parsing/extensions.ml.reference

@@ -323,4 +323,4 @@
 ]
 
 File "extensions.ml", line 2, characters 3-6:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.

testsuite/tests/parsing/pr6865.ml.reference

@@ -49,4 +49,4 @@
 ]
 
 File "pr6865.ml", line 1, characters 4-7:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.

testsuite/tests/parsing/shortcut_ext_attr.ml.reference

@@ -959,4 +959,4 @@
 ]
 
 File "shortcut_ext_attr.ml", line 4, characters 6-9:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.

testsuite/tools/expect_test.ml

@@ -139,7 +139,7 @@ module Compiler_messages = struct
 
   let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error) =
     print_loc ppf loc;
-    Format.pp_print_string ppf msg;
+    Format.fprintf ppf "%a %s" Location.print_error_prefix () msg;
     List.iter sub ~f:(fun err ->
       Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err)