log reporter style renderer

src/log_reporter.ml

@@ -1,69 +1,60 @@
-let detail_tag : string Logs.Tag.def =
-  Logs.Tag.def "Detail tag" ~doc:"" Fmt.string
+let pp_timestamp = Fmt.fmt "%09.04f"
 
-let detail s = Logs.Tag.(empty |> add detail_tag s)
-let time_anchor = Mirage_ptime.now () |> Ptime.to_span
+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 color_of_log_level = function
+let log_level_color = function
   | Logs.App -> `White
   | Error -> `Red
   | Warning -> `Yellow
   | Info -> `Blue
   | Debug -> `Magenta
 
-let reporter : Logs.reporter =
-  let open Fmt in
-  let pp_timestamp = styled `Faint (styled (`Fg `White) (fmt "%09.04f")) in
-  let pp_header ppf v =
-    let color = color_of_log_level (fst v) in
-    let pp = styled (`Fg color) Logs.pp_header in
-    pf ppf "%a" pp v
-  in
-  let pp_src_name =
-    let pp = using Logs.Src.name (styled `Cyan (fmt "%s: ")) in
-    fun ppf v -> if not @@ Logs.Src.equal Logs.default v then pp ppf v
-  in
-  let pp_detail = option (styled `Green (fmt " (%s)")) in
+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 -> stdout
-      | Error | Warning | Info | Debug -> stderr
+      | Logs.App -> Fmt.stdout
+      | Error | Warning | Info | Debug -> Fmt.stderr
     in
     let k _ppf = over (); k () in
-    let with_detail h tags k user_fmt =
-      let detail = Option.bind tags (Logs.Tag.find detail_tag) in
-      let timestamp =
-        Ptime.sub_span (Mirage_ptime.now ()) time_anchor
-        |> Option.map Ptime.to_float_s
-        |> Option.value ~default:0.
-      in
-      let k ppf = kpf k ppf "%a@." pp_detail detail in
-      let k ppf = kpf k ppf user_fmt in
-      kpf k ppf "%a %a %a" pp_timestamp timestamp pp_header (lvl, h) pp_src_name
+    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 fmt -> with_detail header tags k fmt
+    msgf @@ fun ?header ?tags user_fmt -> pp header tags k user_fmt
   in
   { report }
 
-(*
-let set_level_secmods lvl =
-  let secmod_srcs = [ Secmod_rsa.src; Secmod_eddsa.src ] in
-  List.iter (fun src -> Logs.Src.set_level src lvl) secmod_srcs;
-  ()
-*)
-
-let setup level =
-  (*     set_level_secmods level; *)
-  (*
-  let l = Logs.Src.list () in
-  let l =
-    List.filter (fun src -> Logs.Src.name src = "mnet.happy_eyeballs") l
-  in
-  List.iter (fun src -> Logs.Src.set_level src None) l;
-*)
-  Logs.set_level ~all:false level;
+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;
-  ()
+  Logs.set_reporter reporter