60 lines
1.7 KiB
OCaml
60 lines
1.7 KiB
OCaml
let pp_timestamp = Fmt.fmt "%09.04f"
|
|
|
|
let pp_header ppf (lvl, h) =
|
|
match h with
|
|
| Some h -> Fmt.pf ppf "[%s]" h
|
|
| None -> (
|
|
match lvl with
|
|
| Logs.App -> ()
|
|
| Info -> Fmt.pf ppf "[INFO]"
|
|
| Debug -> Fmt.pf ppf "[DEBUG]"
|
|
| Warning -> Fmt.pf ppf "[WARNING]"
|
|
| Error -> Fmt.pf ppf "[ERROR]")
|
|
|
|
let log_level_color = function
|
|
| Logs.App -> `White
|
|
| Error -> `Red
|
|
| Warning -> `Yellow
|
|
| Info -> `Blue
|
|
| Debug -> `Magenta
|
|
|
|
let pp_src_name ppf src =
|
|
if Logs.Src.equal Logs.default src then ()
|
|
else Fmt.pf ppf "%s: " (Logs.Src.name src)
|
|
|
|
let create ~t0 : Logs.reporter =
|
|
let report src lvl ~over k msgf =
|
|
let pp_timestamp =
|
|
Fmt.styled `Faint (Fmt.styled (`Fg `White) pp_timestamp)
|
|
in
|
|
let pp_header = Fmt.styled (`Fg (log_level_color lvl)) pp_header in
|
|
let pp_src_name = Fmt.styled `Cyan pp_src_name in
|
|
let ppf =
|
|
match lvl with
|
|
| Logs.App -> Fmt.stdout
|
|
| Error | Warning | Info | Debug -> Fmt.stderr
|
|
in
|
|
let k _ppf = over (); k () in
|
|
let pp h _tags k user_fmt =
|
|
let t1 = Mkernel.clock_monotonic () in
|
|
let dt = Float.of_int (t1 - t0) /. 1_000_000_000. in
|
|
let k ppf = Fmt.kpf k ppf "@." in
|
|
let k ppf = Fmt.kpf k ppf user_fmt in
|
|
Fmt.kpf k ppf "%a %a %a" pp_timestamp dt pp_header (lvl, h) pp_src_name
|
|
src
|
|
in
|
|
msgf @@ fun ?header ?tags user_fmt -> pp header tags k user_fmt
|
|
in
|
|
{ report }
|
|
|
|
let setup ~t0 =
|
|
let reporter = create ~t0 in
|
|
let style_renderer = `Ansi_tty in
|
|
let all = false in
|
|
let level = Some Logs.Info in
|
|
(* - *)
|
|
Fmt.set_style_renderer Fmt.stdout style_renderer;
|
|
Fmt.set_style_renderer Fmt.stderr style_renderer;
|
|
Logs.set_level ~all level;
|
|
Logs.Src.set_level Logs.default level;
|
|
Logs.set_reporter reporter
|