diff --git a/docs/quickstart.mld b/docs/quickstart.mld index 233b082..ceb7419 100644 --- a/docs/quickstart.mld +++ b/docs/quickstart.mld @@ -97,4 +97,11 @@ let () = {1 Add Location Information} -Lots of functions in your [Logger] is taking the optional argument [loc], including {{!val:Asai.Logger.S.trace}trace}. It is expecting an argument of type {!type:Asai.Span.t}. If you are using OCamllex, perhaps you will find {{!val:Asai.Span.of_lex}of_lex} handy. Please take a look at {!module:Asai.Span} to learn how to work with spans. +Lots of functions in your [Logger] is taking the optional argument [loc], including {{!val:Asai.Logger.S.trace}trace}. It is taking an argument of type {!type:Asai.Span.t}. If you are using OCamllex, perhaps you will find {{!val:Asai.Span.of_lex}of_lex} handy. Please take a look at {!module:Asai.Span} to learn how to work with spans. + +Note that [Logger] will remember the last location, and thus you do not have to explicitly pass locations all the times. For example, in the following code +{[ +Logger.trace ~loc "When checking this code ..." @@ fun () -> +Logger.emit "Wow!" +]} +the inner message will inherit the location [loc] of the trace. Check out {{!val:Asai.Logger.S.get_loc}get_loc}, {{!val:Asai.Logger.S.with_loc}with_loc} and {{!val:Asai.Logger.S.merge_loc}merge_loc} to learn how to manipulate the current location. diff --git a/src/Diagnostic.ml b/src/Diagnostic.ml index e91f363..24fd7d7 100644 --- a/src/Diagnostic.ml +++ b/src/Diagnostic.ml @@ -26,15 +26,18 @@ let of_message ?(backtrace=Bwd.Emp) ?(additional_messages=[]) severity code mess ; additional_messages } +let of_text ?loc ?backtrace ?additional_messages severity code text : _ t = + of_message ?backtrace ?additional_messages severity code {loc; value = text} + let make ?loc ?backtrace ?additional_messages severity code str = - of_message ?backtrace ?additional_messages severity code @@ message ?loc str + of_text ?loc ?backtrace ?additional_messages severity code @@ text str let kmakef ?loc ?backtrace ?additional_messages k severity code = - kmessagef ?loc @@ fun message -> - k @@ of_message ?backtrace ?additional_messages severity code message + ktextf @@ fun text -> + k @@ of_text ?loc ?backtrace ?additional_messages severity code text let makef ?loc ?backtrace ?additional_messages severity code = - kmessagef ?loc @@ of_message ?backtrace ?additional_messages severity code + ktextf @@ of_text ?loc ?backtrace ?additional_messages severity code let string_of_severity = function diff --git a/src/Logger.ml b/src/Logger.ml index 27a2720..270d3ed 100644 --- a/src/Logger.ml +++ b/src/Logger.ml @@ -8,27 +8,42 @@ struct (* Backtraces *) - module Traces = Algaeff.Reader.Make (struct type nonrec env = Diagnostic.backtrace end) + module Traces = Algaeff.Reader.Make (struct type nonrec env = Span.t option * Diagnostic.backtrace end) - let get_backtrace = Traces.read + let get_loc() = fst @@ Traces.read() - let with_backtrace bt = Traces.run ~env:bt + let with_loc loc = Traces.scope @@ fun (_, bt) -> loc, bt - let trace_message msg = Traces.scope @@ fun bt -> bt <: msg + let merge_loc loc f = + match loc with + | None -> f() + | loc -> with_loc loc f - let trace ?loc str = trace_message @@ Diagnostic.message ?loc str + let get_backtrace() = snd @@ Traces.read() + + let with_backtrace bt = Traces.scope @@ fun (loc, _) -> loc, bt + + let trace_text ?loc text = Traces.scope @@ fun (l, bt) -> + let loc = match loc with None -> l | Some _ -> loc in + loc, bt <: {loc; value = text} + + let trace_message (msg : Diagnostic.message) = + trace_text ?loc:msg.loc msg.value + + let trace ?loc str = trace_text ?loc @@ Diagnostic.text str let tracef ?loc = Diagnostic.kmessagef trace_message ?loc (* Building messages *) let get_severity code = function None -> Code.default_severity code | Some severity -> severity + let get_merged_loc = function None -> get_loc() | loc -> loc let diagnostic ?severity ?loc ?(backtrace=get_backtrace()) ?additional_messages code str = - Diagnostic.make ?loc ~backtrace ?additional_messages (get_severity code severity) code str + Diagnostic.make ?loc:(get_merged_loc loc) ~backtrace ?additional_messages (get_severity code severity) code str let kdiagnosticf ?severity ?loc ?(backtrace=get_backtrace()) ?additional_messages k code = - Diagnostic.kmakef ?loc ~backtrace ?additional_messages k (get_severity code severity) code + Diagnostic.kmakef ?loc:(get_merged_loc loc) ~backtrace ?additional_messages k (get_severity code severity) code let diagnosticf ?severity ?loc ?backtrace ?additional_messages code = kdiagnosticf Fun.id ?severity ?loc ?backtrace ?additional_messages code @@ -52,8 +67,8 @@ struct (* Runners *) - let run ?(init_backtrace=Emp) ~emit ~fatal f = - Traces.run ~env:init_backtrace @@ fun () -> + let run ?init_loc ?(init_backtrace=Emp) ~emit ~fatal f = + Traces.run ~env:(init_loc, init_backtrace) @@ fun () -> Effect.Deep.match_with f () @@ handler ~emit ~fatal let try_with ?(emit=emit_diagnostic) ?(fatal=fatal_diagnostic) f = @@ -73,8 +88,9 @@ struct let fatalf ?severity ?loc ?backtrace ?additional_messages code = kdiagnosticf fatal_diagnostic ?severity ?loc ?backtrace ?additional_messages code - let adopt m (run : ?init_backtrace:_ -> emit:_ -> fatal:_ -> _) f = + let adopt m (run : ?init_loc:_ -> ?init_backtrace:_ -> emit:_ -> fatal:_ -> _) f = run f + ?init_loc:(get_loc()) ~init_backtrace:(get_backtrace()) ~emit:(fun d -> emit_diagnostic (m d)) ~fatal:(fun d -> fatal_diagnostic (m d)) diff --git a/src/LoggerSigs.ml b/src/LoggerSigs.ml index 5b78b43..8617723 100644 --- a/src/LoggerSigs.ml +++ b/src/LoggerSigs.ml @@ -2,7 +2,7 @@ module type S = sig module Code : Diagnostic.Code - (** {2 Sending Diagnostics} *) + (** {2 Sending Messages} *) (** [emit code str] emits a string and continues the computation. @@ -71,7 +71,7 @@ sig (** [get_backtrace()] returns the current backtrace. *) val get_backtrace : unit -> Diagnostic.backtrace - (** [with_backtrace bt f] runs the thunk [f] with the backtrace [bt]. + (** [with_backtrace bt f] runs the thunk [f] with [bt] as the initial backtrace. Example: {[ @@ -93,10 +93,28 @@ sig *) val tracef : ?loc:Span.t -> ('a, Format.formatter, unit, (unit -> 'b) -> 'b) format4 -> 'a + (** [trace_text text f] records the message [text] and runs the thunk [f] with the new backtrace. + + @param loc The location of the text (usually the code) to highlight. *) + val trace_text : ?loc:Span.t -> Diagnostic.text -> (unit -> 'a) -> 'a + (** [trace_message msg f] records the message [msg] and runs the thunk [f] with the new backtrace. *) val trace_message : Diagnostic.message -> (unit -> 'a) -> 'a - (** {2 Constructing Diagnostics with Current Backtraces} *) + (** {2 Locations} *) + + (** [get_loc()] returns the current location. *) + val get_loc : unit -> Span.t option + + (** [with_loc loc f] runs the thunk [f] with [loc] as the initial location [loc]. Note that [with_loc None] will clear the current location, while [merge_loc None] will keep it. See {!val:merge_loc}. *) + val with_loc : Span.t option -> (unit -> 'a) -> 'a + + (** [merge_loc loc f] "merges" [loc] into the current location and runs the thunk [f]. By "merge", it means that if [loc] is [None], then the current location is kept; otherwise, it is overwritten. Note that [with_loc None] will clear the current location, while [merge_loc None] will keep it. See {!val:with_loc}. *) + val merge_loc : Span.t option -> (unit -> 'a) -> 'a + + (** {2 Constructing Diagnostics} *) + + (** Functions in this section differ from the ones in {!module:Diagnostic} (for example, {!val:Diagnostic.make}) in that they fill out the current location, the current backtrace, and the severity automatically. (One can still overwrite them with optional arguments.) *) (** [diagnostic code str] constructs a diagnostic with the message [str] along with the backtrace frames recorded via {!val:tracef}. @@ -142,14 +160,16 @@ sig @param init_backtrace The initial backtrace to start with. The default value is the empty backtrace. @param emit The handler of non-fatal diagnostics. @param fatal The handler of fatal diagnostics. *) - val run : ?init_backtrace:Diagnostic.backtrace -> emit:(Code.t Diagnostic.t -> unit) -> fatal:(Code.t Diagnostic.t -> 'a) -> (unit -> 'a) -> 'a + val run : ?init_loc:Span.t -> ?init_backtrace:Diagnostic.backtrace -> emit:(Code.t Diagnostic.t -> unit) -> fatal:(Code.t Diagnostic.t -> 'a) -> (unit -> 'a) -> 'a (** [adopt m run f] runs the thunk [f] that uses a different [Logger] instance, with the help of the runner [run] from that [Logger] instance, and then uses [m] to map the diagnostics generated by [f] into the ones in the current [Logger] instance. The backtrace within [f] will include the backtrace that leads to [adopt]. The intended use case is to integrate diagnostics from a library into those in the main application. [adopt] is a convenience function that can be implemented as follows: {[ let adopt m f run = - run ?init_backtrace:(Some (get_backtrace())) + run + ?init_loc:(get_loc()) + ?init_backtrace:(Some (get_backtrace())) ~emit:(fun d -> emit_diagnostic (m d)) ~fatal:(fun d -> fatal_diagnostic (m d)) f @@ -166,7 +186,7 @@ sig @param init_backtrace The initial backtrace to start with. The default value is the empty backtrace. *) - val adopt : ('code Diagnostic.t -> Code.t Diagnostic.t) -> (?init_backtrace:Diagnostic.backtrace -> emit:('code Diagnostic.t -> unit) -> fatal:('code Diagnostic.t -> 'a) -> (unit -> 'a) -> 'a) -> (unit -> 'a) -> 'a + val adopt : ('code Diagnostic.t -> Code.t Diagnostic.t) -> (?init_loc:Span.t -> ?init_backtrace:Diagnostic.backtrace -> emit:('code Diagnostic.t -> unit) -> fatal:('code Diagnostic.t -> 'a) -> (unit -> 'a) -> 'a) -> (unit -> 'a) -> 'a (** [try_with ~emit ~fatal f] runs the thunk [f], using [emit] to intercept non-fatal diagnostics before continuing the computation (see {!val:emit} and {!val:emitf}), and [fatal] to intercept fatal diagnostics that have aborted the computation (see {!val:fatal} and {!val:fatalf}). The default interceptors re-emit or re-raise the intercepted diagnostics.