diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index c3bd0998d6b2e93e81fb65e633518a3ccdc74f3d..c45775806959bc2e7d005246c43a36e9d4a32d8f 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -25,9 +25,9 @@ let json_pp id encoding ppf x = let set_error_encoding_cache_dirty = ref (fun () -> ()) -module Make(Prefix : sig val id : string end) = struct +module PreMake(Prefix : sig val id : string type error = .. end) = struct - type error = .. + include Prefix module type Wrapped_error_monad = sig type unwrapped = .. @@ -576,7 +576,11 @@ module Make(Prefix : sig val id : string end) = struct end -include Make(struct let id = "" end) +module Make(Prefix : sig val id : string end) = struct + include PreMake(struct include Prefix type error = .. end) +end + +include PreMake(struct let id = "" type error = Logging.error = .. end) let generic_error fmt = Format.kasprintf (fun s -> error (Unclassified s)) fmt diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index ad7e65201eda73e00c55d4e25ceadfda8196514d..ea0d418f809e4b02400a4549ea1af8695520eec7 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -16,7 +16,7 @@ type error_category = | `Permanent (** Errors that will happen no matter the context *) ] -include Error_monad_sig.S +include Error_monad_sig.S with type error = Logging.error module type Wrapped_error_monad = sig type unwrapped = .. diff --git a/src/lib_stdlib/logging.ml b/src/lib_stdlib/logging.ml index 7cd74a9381b1fc76d1f0879836c523bb0cc9bdfb..17d55c1962837d68af8b8898365c5222d36b7f2f 100644 --- a/src/lib_stdlib/logging.ml +++ b/src/lib_stdlib/logging.ml @@ -7,40 +7,46 @@ (* *) (**************************************************************************) +type error = .. + module type LOG = sig - val debug: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a - val warn: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a - val fatal_error: ('a, Format.formatter, unit, unit) format4 -> 'a + val debug: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val log_info: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val log_notice: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val warn: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val log_error: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val fatal_error: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a - val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_fatal_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_debug: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_info: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_notice: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_warn: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_error: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_fatal_error: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a end +let log_sink = ref (fun ?errs:_ ?exn:_ ~section:_ ?location:_ ?logger:_ ~level:_ _ -> ()) + let log_f - ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = + ?errs ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = if level < Lwt_log_core.Section.level section then Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format else Format.kasprintf - (fun msg -> Lwt_log_core.log ?exn ~section ?location ?logger ~level msg) + (fun msg -> !log_sink ?errs ?exn ~section ?location ?logger ~level msg; + Lwt_log_core.log ?exn ~section ?location ?logger ~level msg) format let ign_log_f - ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = + ?errs ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = if level < Lwt_log_core.Section.level section then Format.ikfprintf (fun _ -> ()) Format.std_formatter format else Format.kasprintf - (fun msg -> Lwt_log_core.ign_log ?exn ~section ?location ?logger ~level msg) + (fun msg -> !log_sink ?errs ?exn ~section ?location ?logger ~level msg; + Lwt_log_core.ign_log ?exn ~section ?location ?logger ~level msg) format let sections = ref [] @@ -50,19 +56,19 @@ module Make(S : sig val name: string end) : LOG = struct let () = sections := S.name :: !sections let section = Lwt_log_core.Section.make S.name - let debug fmt = ign_log_f ~section ~level:Lwt_log_core.Debug fmt - let log_info fmt = ign_log_f ~section ~level:Lwt_log_core.Info fmt - let log_notice fmt = ign_log_f ~section ~level:Lwt_log_core.Notice fmt - let warn fmt = ign_log_f ~section ~level:Lwt_log_core.Warning fmt - let log_error fmt = ign_log_f ~section ~level:Lwt_log_core.Error fmt - let fatal_error fmt = ign_log_f ~section ~level:Lwt_log_core.Fatal fmt + let debug ?errs fmt = ign_log_f ?errs ~section ~level:Lwt_log_core.Debug fmt + let log_info ?errs fmt = ign_log_f ?errs ~section ~level:Lwt_log_core.Info fmt + let log_notice ?errs fmt = ign_log_f ?errs ~section ~level:Lwt_log_core.Notice fmt + let warn ?errs fmt = ign_log_f ?errs ~section ~level:Lwt_log_core.Warning fmt + let log_error ?errs fmt = ign_log_f ?errs ~section ~level:Lwt_log_core.Error fmt + let fatal_error ?errs fmt = ign_log_f ?errs ~section ~level:Lwt_log_core.Fatal fmt - let lwt_debug fmt = log_f ~section ~level:Lwt_log_core.Debug fmt - let lwt_log_info fmt = log_f ~section ~level:Lwt_log_core.Info fmt - let lwt_log_notice fmt = log_f ~section ~level:Lwt_log_core.Notice fmt - let lwt_warn fmt = log_f ~section ~level:Lwt_log_core.Warning fmt - let lwt_log_error fmt = log_f ~section ~level:Lwt_log_core.Error fmt - let lwt_fatal_error fmt = log_f ~section ~level:Lwt_log_core.Fatal fmt + let lwt_debug ?errs fmt = log_f ?errs ~section ~level:Lwt_log_core.Debug fmt + let lwt_log_info ?errs fmt = log_f ?errs ~section ~level:Lwt_log_core.Info fmt + let lwt_log_notice ?errs fmt = log_f ?errs ~section ~level:Lwt_log_core.Notice fmt + let lwt_warn ?errs fmt = log_f ?errs ~section ~level:Lwt_log_core.Warning fmt + let lwt_log_error ?errs fmt = log_f ?errs ~section ~level:Lwt_log_core.Error fmt + let lwt_fatal_error ?errs fmt = log_f ?errs ~section ~level:Lwt_log_core.Fatal fmt end @@ -103,5 +109,17 @@ type level = Lwt_log_core.level = program. *) | Fatal +type log_sink = + ?errs:error list -> + ?exn:exn -> + section:Lwt_log.section -> + ?location:string * int * int -> + ?logger:Lwt_log.logger -> + level:level -> + string -> + unit + +let set_log_sink (es : log_sink) = log_sink := es + type template = Lwt_log_core.template let default_template = "$(date) - $(section): $(message)" diff --git a/src/lib_stdlib/logging.mli b/src/lib_stdlib/logging.mli index 0410bda70e9c263b463685017a8ac80da5d3881c..1f0cf63b1c747f008005ea62e8732f0bdcc935c0 100644 --- a/src/lib_stdlib/logging.mli +++ b/src/lib_stdlib/logging.mli @@ -7,21 +7,23 @@ (* *) (**************************************************************************) +type error = .. + module type LOG = sig - val debug: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a - val warn: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a - val fatal_error: ('a, Format.formatter, unit, unit) format4 -> 'a + val debug: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val log_info: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val log_notice: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val warn: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val log_error: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a + val fatal_error: ?errs:error list -> ('a, Format.formatter, unit, unit) format4 -> 'a - val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_fatal_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_debug: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_info: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_notice: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_warn: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_error: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_fatal_error: ?errs:error list -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a end @@ -68,3 +70,15 @@ type template = Lwt_log.template val default_template : template val sections: string list ref + +type log_sink = + ?errs:error list -> + ?exn:exn -> + section:Lwt_log.section -> + ?location:string * int * int -> + ?logger:Lwt_log.logger -> + level:level -> + string -> + unit + +val set_log_sink : log_sink -> unit