Source file xlog.ml

module type MyLOG = sig
  include Logs.LOG

  val src : Logs.src
end

let stamp_tag : Mtime.span Logs.Tag.def =
  Logs.Tag.def "stamp" ~doc:"Relative monotonic time stamp" Mtime.Span.pp

let stamp c = Logs.Tag.(empty |> add stamp_tag (Mtime_clock.count c))

let log_pairs ~src level f =
  Logs.msg ~src level (fun m ->
      f (fun fmt (f1, arg1) (f2, arg2) -> m fmt (f1 arg1) (f2 arg2)))

let my_reporter ~app ppf =
  let new_report src level ~over k msgf =
    let k _ =
      over ();
      k ()
    in
    match level with
    | Logs.App ->
        msgf @@ fun ?header ?tags fmt ->
        let _ = tags in
        (* in order to get rid of the tags unused variable warning *)
        Fmt.kpf k ppf
          ("%a@[" ^^ fmt ^^ "@]@.")
          Logs_fmt.pp_header (level, header)
    | Logs.Error 
    | Logs.Warning ->
        msgf @@ fun ?header ?tags fmt ->
        let _ = tags in
        (* in order to get rid of the tags unused variable warning *)
        Fmt.kpf k ppf
          ("%a @[" ^^ fmt ^^ "@]@.")
          Logs_fmt.pp_header (level, header)
    | _ ->
        let p1, p2 =
          if (src = Logs.default) || (String.trim (Logs.Src.name src) = "") then (app, "")
          else (app ^ "/", Logs.Src.name src)
        in
        let with_src h tags k ppf fmt =
          let stamp =
            match tags with
            | None -> None
            | Some tags -> Logs.Tag.find stamp_tag tags
          in
          match stamp with
          | None ->
              Fmt.kpf k ppf
                ("%a%a: %a @[" ^^ fmt ^^ "@]@.")
                Fmt.(styled `Magenta string)
                p1
                Fmt.(styled `Magenta string)
                p2
                Logs_fmt.pp_header (level, h)
          | Some s ->
              Fmt.kpf k ppf
                ("%a%a: %a[%a] @[" ^^ fmt ^^ "@]@.")
                Fmt.(styled `Magenta string)
                p1
                Fmt.(styled `Magenta string)
                p2 Logs_fmt.pp_header (level, h) Mtime.Span.pp s
        in
        msgf @@ fun ?header ?tags fmt -> with_src header tags k ppf fmt
  in
  { Logs.report = new_report }

let setup_log ~app style_renderer level =
  Fmt_tty.setup_std_outputs ~utf_8:true ~style_renderer ();
  Logs.set_level level;
  Logs.set_reporter (my_reporter ~app Format.std_formatter);
  ()

let set_level ~app ?(colored = true) l =
  let tt = match colored with true -> `Ansi_tty | false -> `None in
  setup_log ~app tt (Some l)

module Make (I : sig
  val name : string
end) =
struct
  let doc = Printf.sprintf "logs ACGtkLib %s events" I.name
  let src = Logs.Src.create ~doc I.name

  module Log = (val Logs.src_log src)
  include Log
end