Source file logger.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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
open Runtime
type opts = { print_source : bool; print_time : bool; color_output : bool }
type ('a, 'b) logger_format =
(('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b
type namespace = string list
type level = Debug | Error | Info | Trace | Warn
module Level = struct
let to_int = function
| Trace -> 5
| Debug -> 4
| Info -> 2
| Warn -> 1
| Error -> 0
let should_log current x =
match current with
| None -> false
| Some log_level -> to_int x <= to_int log_level
let to_color_string t =
match t with
| Error -> "\x1b[31m"
| Warn -> "\x1b[33m"
| Debug -> "\x1b[36m"
| Info -> ""
| Trace -> "\x1b[35m"
let pp ppf t =
match t with
| Error -> Format.fprintf ppf "error"
| Warn -> Format.fprintf ppf "warn"
| Debug -> Format.fprintf ppf "debug"
| Info -> Format.fprintf ppf "info"
| Trace -> Format.fprintf ppf "trace"
end
type log = {
level : level;
ts : Ptime.t;
src : Scheduler_uid.t * Pid.t;
ns : namespace;
message : string;
}
let __on_log__ : (log -> unit) ref = ref (fun _ -> ())
let set_on_log log = __on_log__ := log
let on_log log = !__on_log__ log
let write : type a. level -> namespace -> (a, unit) logger_format -> unit =
fun level ns msgf ->
let ts = Ptime_clock.now () in
let sch = Scheduler.get_current_scheduler () in
let pid = self () in
let src = (sch.uid, pid) in
let buf = Buffer.create 128 in
msgf @@ fun fmt ->
Format.kfprintf
(fun _ ->
let message = Buffer.contents buf in
on_log { ts; level; ns; src; message };
())
(Format.formatter_of_buffer buf)
(fmt ^^ "%!")
module type Intf = sig
val set_log_level : level option -> unit
val debug : ('a, unit) logger_format -> unit
val error : ('a, unit) logger_format -> unit
val info : ('a, unit) logger_format -> unit
val trace : ('a, unit) logger_format -> unit
val warn : ('a, unit) logger_format -> unit
end
module type Namespace = sig
val namespace : namespace
end
module Make (B : Namespace) : Intf = struct
let log_level = ref None
let set_log_level x = log_level := x
let debug msgf =
if Level.should_log !log_level Debug then write Debug B.namespace msgf
let info msgf =
if Level.should_log !log_level Info then write Info B.namespace msgf
let trace msgf =
if Level.should_log !log_level Trace then write Trace B.namespace msgf
let warn msgf =
if Level.should_log !log_level Warn then write Warn B.namespace msgf
let error msgf =
if Level.should_log !log_level Error then write Error B.namespace msgf
end
include Make (struct
let namespace = []
end)