Source file xlog.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
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_sem.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_sem.pp_header (level, header)
    | Logs.Info
    | Logs.Debug ->
        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
                ("%s%s: %a @[" ^^ fmt ^^ "@]@.")
                p1 p2 Logs_sem.pp_header (level, h)
          | Some s ->
              Fmt.kpf k ppf
                ("%s%s: %a[%a] @[" ^^ fmt ^^ "@]@.")
                p1 p2 Logs_sem.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 ~render_mark ?(colored = true) level formatter =
  if colored then
    Tags.add_marking ~render_mark formatter;
  Logs.set_level (Some level);
  Logs.set_reporter (my_reporter ~app formatter);
  ()

let setup_log_std ~app ~render_mark ?(colored = true) level =
  Fmt_tty.setup_std_outputs ~utf_8:true (); 
  setup_log ~app ~render_mark ~colored level Format.std_formatter

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