mte/src/log_reporter.ml

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