diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/feedback.ml | 26 | ||||
| -rw-r--r-- | lib/feedback.mli | 12 |
2 files changed, 19 insertions, 19 deletions
diff --git a/lib/feedback.ml b/lib/feedback.ml index 74a18df6f8..12b8b27ff4 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -51,7 +51,7 @@ let default_route = 0 open Pp open Pp_control -type logger = level -> std_ppcmds -> unit +type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit let msgnl_with fmt strm = msg_with fmt (strm ++ fnl ()) let msgnl strm = msgnl_with !std_ft strm @@ -84,7 +84,7 @@ let err_str = str "Error:" ++ spc () let make_body quoter info s = quoter (hov 0 (info ++ s)) (* Generic logger *) -let gen_logger dbg err level msg = match level with +let gen_logger dbg err ?loc level msg = match level with | Debug -> msgnl (make_body dbg dbg_str msg) | Info -> msgnl (make_body dbg info_str msg) | Notice -> msgnl msg @@ -93,10 +93,10 @@ let gen_logger dbg err level msg = match level with | Error -> msgnl_with !err_ft (make_body err err_str msg) (** Standard loggers *) -let std_logger = gen_logger (fun x -> x) (fun x -> x) +let std_logger = gen_logger (fun x -> x) (fun x -> x) (* Color logger *) -let color_terminal_logger level strm = +let color_terminal_logger ?loc level strm = let msg = Ppstyle.color_msg in match level with | Debug -> msg ~header:("Debug", Ppstyle.debug_tag) !std_ft strm @@ -117,11 +117,11 @@ let emacs_logger = gen_logger emacs_quote_info emacs_quote_err let logger = ref std_logger let set_logger l = logger := l -let msg_info x = !logger Info x -let msg_notice x = !logger Notice x -let msg_warning x = !logger Warning x -let msg_error x = !logger Error x -let msg_debug x = !logger Debug x +let msg_info ?loc x = !logger Info x +let msg_notice ?loc x = !logger Notice x +let msg_warning ?loc x = !logger Warning x +let msg_error ?loc x = !logger Error x +let msg_debug ?loc x = !logger Debug x (** Feeders *) let feeder = ref ignore @@ -140,19 +140,19 @@ let feedback ?id ?route what = id = Option.default !feedback_id id; } -let feedback_logger lvl msg = +let feedback_logger ?loc lvl msg = feedback ~route:!feedback_route ~id:!feedback_id (Message (lvl, Richpp.richpp_of_pp msg)) (* Output to file *) -let ft_logger old_logger ft level mesg = +let ft_logger old_logger ft ?loc level mesg = let id x = x in match level with | Debug -> msgnl_with ft (make_body id dbg_str mesg) | Info -> msgnl_with ft (make_body id info_str mesg) | Notice -> msgnl_with ft mesg - | Warning -> old_logger level mesg - | Error -> old_logger level mesg + | Warning -> old_logger ?loc level mesg + | Error -> old_logger ?loc level mesg let with_output_to_file fname func input = let old_logger = !logger in diff --git a/lib/feedback.mli b/lib/feedback.mli index 690877897e..7b293ae30b 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -65,7 +65,7 @@ type feedback = { * Only one among state_id and edit_id can be provided. *) (** A [logger] takes a level plus a pretty printing doc and logs it *) -type logger = level -> Pp.std_ppcmds -> unit +type logger = ?loc:Loc.t -> level -> Pp.std_ppcmds -> unit (** [set_logger l] makes the [msg_*] to use [l] for logging *) val set_logger : logger -> unit @@ -110,22 +110,22 @@ relaxed. *) (* Should we advertise these functions more? Should they be the ONLY allowed way to output something? *) -val msg_info : Pp.std_ppcmds -> unit +val msg_info : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** Message that displays information, usually in verbose mode, such as [Foobar is defined] *) -val msg_notice : Pp.std_ppcmds -> unit +val msg_notice : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** Message that should be displayed, such as [Print Foo] or [Show Bar]. *) -val msg_warning : Pp.std_ppcmds -> unit +val msg_warning : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** Message indicating that something went wrong, but without serious consequences. *) -val msg_error : Pp.std_ppcmds -> unit +val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** Message indicating that something went really wrong, though still recoverable; otherwise an exception would have been raised. *) -val msg_debug : Pp.std_ppcmds -> unit +val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** For debugging purposes *) |