diff options
| -rw-r--r-- | checker/checker.ml | 37 | ||||
| -rw-r--r-- | lib/feedback.ml | 38 | ||||
| -rw-r--r-- | lib/feedback.mli | 8 |
3 files changed, 47 insertions, 36 deletions
diff --git a/checker/checker.ml b/checker/checker.ml index 247a98e63e..e960a55fd2 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -367,46 +367,11 @@ let initialized = ref false (* XXX: At some point we need to either port the checker to use the feedback system or to remove its use completely. *) -let init_feedback_listener () = - let open Format in - let pp_lvl fmt lvl = let open Feedback in match lvl with - | Error -> fprintf fmt "Error: " - | Info -> fprintf fmt "Info: " - | Debug -> fprintf fmt "Debug: " - | Warning -> fprintf fmt "Warning: " - | Notice -> fprintf fmt "" - in - let pp_loc fmt loc = let open Loc in match loc with - | None -> fprintf fmt "" - | Some loc -> - let where = - match loc.fname with InFile f -> f | ToplevelInput -> "Toplevel input" in - fprintf fmt "\"%s\", line %d, characters %d-%d:@\n" - where loc.line_nb (loc.bp-loc.bol_pos) (loc.ep-loc.bol_pos) in - let checker_feed (fb : Feedback.feedback) = let open Feedback in - match fb.contents with - | Processed -> () - | Incomplete -> () - | Complete -> () - | ProcessingIn _ -> () - | InProgress _ -> () - | WorkerStatus (_,_) -> () - | AddedAxiom -> () - | GlobRef (_,_,_,_,_) -> () - | GlobDef (_,_,_,_) -> () - | FileDependency (_,_) -> () - | FileLoaded (_,_) -> () - | Custom (_,_,_) -> () - (* Re-enable when we switch back to feedback-based error printing *) - | Message (lvl,loc,msg) -> - Format.eprintf "@[%a@]%a@[%a@]\n%!" pp_loc loc pp_lvl lvl Pp.pp_with msg - in ignore(Feedback.add_feeder checker_feed) - let init_with_argv argv = if not !initialized then begin initialized := true; Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - init_feedback_listener (); + let _fhandle = Feedback.(add_feeder (console_feedback_listener Format.err_formatter)) in try parse_args argv; if !Flags.debug then Printexc.record_backtrace true; diff --git a/lib/feedback.ml b/lib/feedback.ml index 7a126363cc..1007582e08 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -63,6 +63,7 @@ let set_id_for_feedback ?(route=default_route) d i = span_id := i; feedback_route := route +let warn_no_listeners = ref true let feedback ?did ?id ?route what = let m = { contents = what; @@ -70,6 +71,8 @@ let feedback ?did ?id ?route what = doc_id = Option.default !doc_id did; span_id = Option.default !span_id id; } in + if !warn_no_listeners && Hashtbl.length feeders = 0 then + Format.eprintf "Warning, feedback message received but no listener to handle it!@\n%!"; Hashtbl.iter (fun _ f -> f m) feeders (* Logging messages *) @@ -81,3 +84,38 @@ let msg_notice ?loc x = feedback_logger ?loc Notice x let msg_warning ?loc x = feedback_logger ?loc Warning x let msg_error ?loc x = feedback_logger ?loc Error x let msg_debug ?loc x = feedback_logger ?loc Debug x + +(* Helper for tools willing to understand only the messages *) +let console_feedback_listener fmt = + let open Format in + let pp_lvl fmt lvl = match lvl with + | Error -> fprintf fmt "Error: " + | Info -> fprintf fmt "Info: " + | Debug -> fprintf fmt "Debug: " + | Warning -> fprintf fmt "Warning: " + | Notice -> fprintf fmt "" + in + let pp_loc fmt loc = let open Loc in match loc with + | None -> fprintf fmt "" + | Some loc -> + let where = + match loc.fname with InFile f -> f | ToplevelInput -> "Toplevel input" in + fprintf fmt "\"%s\", line %d, characters %d-%d:@\n" + where loc.line_nb (loc.bp-loc.bol_pos) (loc.ep-loc.bol_pos) in + let checker_feed (fb : feedback) = + match fb.contents with + | Processed -> () + | Incomplete -> () + | Complete -> () + | ProcessingIn _ -> () + | InProgress _ -> () + | WorkerStatus (_,_) -> () + | AddedAxiom -> () + | GlobRef (_,_,_,_,_) -> () + | GlobDef (_,_,_,_) -> () + | FileDependency (_,_) -> () + | FileLoaded (_,_) -> () + | Custom (_,_,_) -> () + | Message (lvl,loc,msg) -> + fprintf fmt "@[%a@]%a@[%a@]\n%!" pp_loc loc pp_lvl lvl Pp.pp_with msg + in checker_feed diff --git a/lib/feedback.mli b/lib/feedback.mli index 73b84614f1..62b909516f 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -99,3 +99,11 @@ val msg_error : ?loc:Loc.t -> Pp.t -> unit val msg_debug : ?loc:Loc.t -> Pp.t -> unit (** For debugging purposes *) + +val console_feedback_listener : Format.formatter -> feedback -> unit +(** Helper for tools willing to print to the feedback system *) + +val warn_no_listeners : bool ref +(** The library will print a warning to the console if no listener is + available by default; ML-clients willing to use Coq without a + feedback handler should set this to false. *) |