feat(Logger): remember the last location (#64)

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.

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

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))

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.