From 9e21876a283a56d976976a8ea905a2200ecbdd1f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Feb 2016 16:39:12 +0100 Subject: [PATCH] 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 | 3 +++ parsing/location.ml | 25 ++++++++++--------- parsing/location.mli | 5 ---- parsing/syntaxerr.ml | 18 ++++++------- .../tests/parsing/extensions.ml.reference | 2 +- testsuite/tests/parsing/pr6865.ml.reference | 2 +- .../parsing/shortcut_ext_attr.ml.reference | 2 +- testsuite/tools/expect_test.ml | 2 +- 8 files changed, 29 insertions(+), 30 deletions(-) diff --git a/Changes b/Changes index 7a3a3d0dd9a7..ca14b077558d 100644 --- a/Changes +++ b/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: diff --git a/parsing/location.ml b/parsing/location.ml index 65e9fa7cb3ce..4f7ebc53da45 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -359,14 +359,14 @@ let pp_ksprintf ?before k fmt = k msg) ppf fmt -let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt = - pp_ksprintf - (fun msg -> {loc; msg; sub; if_highlight}) - 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_prefixed ?(loc=none) ?(sub=[]) ?(if_highlight="") fmt = +let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt = pp_ksprintf - ~before:(fun ppf -> fprintf ppf "%a " print_error_prefix ()) + ~before:print_phanton_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; - Format.pp_print_string ppf msg; + fprintf ppf "%a%a %s" print loc print_error_prefix () 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}))) diff --git a/parsing/location.mli b/parsing/location.mli index 356a69de3219..4a7ac9596075 100644 --- a/parsing/location.mli +++ b/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 diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index 96ec79e20585..0bb55ab6769e 100644 --- a/parsing/syntaxerr.ml +++ b/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 diff --git a/testsuite/tests/parsing/extensions.ml.reference b/testsuite/tests/parsing/extensions.ml.reference index bd14c5d32ade..e904d7e9a77f 100644 --- a/testsuite/tests/parsing/extensions.ml.reference +++ b/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'. diff --git a/testsuite/tests/parsing/pr6865.ml.reference b/testsuite/tests/parsing/pr6865.ml.reference index 55a541fbc2ed..72abd40e11fc 100644 --- a/testsuite/tests/parsing/pr6865.ml.reference +++ b/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'. diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference index 27c32e16c143..f29a3b5b2dc1 100644 --- a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference +++ b/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'. diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml index 35c6b856592e..f8e288de9d2a 100644 --- a/testsuite/tools/expect_test.ml +++ b/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)