From 7ff42d43a6107dff984676902943ec32f187c40d Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 13 Oct 2016 13:44:35 +0200 Subject: [pp] Add tagging function to all low-level printing calls. The current tag system in `Pp` is generic, which implies we must choose a tagging function when calling a printer. For console printing there is a single choice, thus this commits adds it a few missing cases. --- parsing/cLexer.ml4 | 2 +- plugins/ssrmatching/ssrmatching.ml4 | 2 +- toplevel/coqloop.ml | 2 +- toplevel/vernac.ml | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 31025075cd..ff69bce886 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -96,7 +96,7 @@ module Error = struct Printf.sprintf "Unsupported Unicode character (0x%x)" x) (* Require to fix the Camlp4 signature *) - let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) + let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x)) end open Error diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index a34fa4cae7..4d1ac71394 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -112,7 +112,7 @@ let guard_term ch1 s i = match s.[i] with (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) let pr_guarded guard prc c = - msg_with Format.str_formatter (prc c); + msg_with ~pp_tag:Ppstyle.pp_tag Format.str_formatter (prc c); let s = Format.flush_str_formatter () ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index f0f8f18641..e9771cfa40 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,7 +13,7 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with !Pp_control.err_ft x +let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index b453dbc469..de45090bfc 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -143,7 +143,7 @@ let pr_new_syntax_in_context loc chan_beautify ocom = | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)) + Pp.msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (hov 0 (before ++ com ++ after)) else Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; @@ -181,7 +181,7 @@ let pp_cmd_header loc com = and take control of the console. *) let print_cmd_header loc com = - Pp.pp_with !Pp_control.std_ft (pp_cmd_header loc com); + Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com); Format.pp_print_flush !Pp_control.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = -- cgit v1.2.3 From 5ac6c86ad8e18161151d53687da1e2825f0a6b46 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 13 Oct 2016 13:49:04 +0200 Subject: [pp] Try to properly tag error messages in cError. In order to get proper coloring, we must tag the headers of error messages in `CError`. This should fix bug https://coq.inria.fr/bugs/show_bug.cgi?id=5135 However, note that this could interact badly with the richpp printing used by the IDE. At this level, we have no clue which tag we'd like to apply, as we know (and shouldn't) nothing about the top level backend. Thus, for now I've selected the console printer, hoping that the `Richpp` won't crash the IDE. --- lib/cErrors.ml | 14 ++++++++++++-- test-suite/output/Arguments_renaming.out | 6 ++++-- test-suite/output/ltac.out | 3 ++- 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/lib/cErrors.ml b/lib/cErrors.ml index c69c7e4001..5c56192fc5 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -16,6 +16,16 @@ let push = Backtrace.add_backtrace exception Anomaly of string option * std_ppcmds (* System errors *) +(* XXX: To move to common tagging functions in Pp, blocked on tag + * system cleanup as we cannot define generic error tags now. + * + * Anyways, tagging should not happen here, but in the specific + * listener to the msg_* stuff. + *) +let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc () +let err_str = tag_err_str "Error:" +let ann_str = tag_err_str "Anomaly:" + let _ = let pr = function | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"") @@ -93,7 +103,7 @@ let print_backtrace e = match Backtrace.get_backtrace e with let print_anomaly askreport e = if askreport then - hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ + hov 0 (ann_str ++ raw_anomaly e ++ spc () ++ strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".") else @@ -115,7 +125,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (str "Error: " ++ where (Some s) ++ pps) + hov 0 (err_str ++ where (Some s) ++ pps) | _ -> raise Unhandled end diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 1633ad9765..e665db47d5 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -2,7 +2,8 @@ File "stdin", line 1, characters 0-36: Warning: Ignoring rename of x into y. Only implicit arguments can be renamed. [arguments-ignore-rename-nonimpl,vernacular] The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +Error: +To rename arguments the "rename" flag must be specified. Argument A renamed to B. File "stdin", line 2, characters 0-25: Warning: Ignoring rename of A into T. Only implicit arguments can be renamed. @@ -125,5 +126,6 @@ File "stdin", line 53, characters 0-26: Warning: Ignoring rename of x into s. Only implicit arguments can be renamed. [arguments-ignore-rename-nonimpl,vernacular] The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +Error: +To rename arguments the "rename" flag must be specified. Argument A renamed to R. diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index f4254e4e2f..a2d545202d 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,5 +1,6 @@ The command has indeed failed with message: -Error: Ltac variable y depends on pattern variable name z which is not bound in current context. +Error: +Ltac variable y depends on pattern variable name z which is not bound in current context. Ltac f x y z := symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize dependent z -- cgit v1.2.3 From cb5f55380875bb3029b051eb3acfbb912d83454b Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 13 Oct 2016 14:21:22 +0200 Subject: [pp] Use more convenient pp API in ssrmatching --- plugins/ssrmatching/ssrmatching.ml4 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 4d1ac71394..21606b2d65 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -112,8 +112,7 @@ let guard_term ch1 s i = match s.[i] with (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) let pr_guarded guard prc c = - msg_with ~pp_tag:Ppstyle.pp_tag Format.str_formatter (prc c); - let s = Format.flush_str_formatter () ^ "$" in + let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) let pr_constr = pr_constr -- cgit v1.2.3