Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

feat(Logger): remember the last location #64

Merged
merged 4 commits into from
Sep 24, 2023
Merged

feat(Logger): remember the last location #64

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
6ba631e
feat(Logger): remember the last location
favonia Sep 24, 2023
c637afe
docs: add a note about remembering locations
favonia Sep 24, 2023
f1b5531
docs(Logger): tweaks
favonia Sep 24, 2023
4a2d21a
docs(Logger): fix the documentation of adopt
favonia Sep 24, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
9 changes: 8 additions & 1 deletion docs/quickstart.mld
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
11 changes: 7 additions & 4 deletions src/Diagnostic.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
36 changes: 26 additions & 10 deletions src/Logger.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 =
Expand All @@ -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))
Expand Down
32 changes: 26 additions & 6 deletions src/LoggerSigs.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.

Expand Down Expand Up @@ -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:
{[
Expand All @@ -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}.

Expand Down Expand Up @@ -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
Expand All @@ -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.

Expand Down