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
(** Low-level mutex-coordinated logs for the Riot engine.
These are super slow, and are intended for usage within the engine alone.
If you're looking for logs for your application, look into
{!module:Riot.Logger} instead.
*)
type level = Debug | Error | Info | Trace | Warn
let level_to_int = function
| Trace -> 5
| Debug -> 4
| Info -> 2
| Warn -> 1
| Error -> 0
let level_to_color_string t =
match t with
| Error -> "\x1b[31m"
| Warn -> "\x1b[33m"
| Debug -> "\x1b[36m"
| Info -> ""
| Trace -> ""
let log_level = ref (Some Error)
let set_log_level x = log_level := x
let should_log x =
match !log_level with
| None -> false
| Some log_level -> level_to_int x <= level_to_int log_level
let pp_level 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 "
type ('a, 'b) message_format =
(('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b
let log_lock = Mutex.create ()
let stdout =
Format.make_formatter (output_substring stdout) (fun () -> flush stdout)
let msg : type a. level -> (a, unit) message_format -> unit =
fun level msgf ->
msgf @@ fun fmt ->
Mutex.lock log_lock;
let domain = (Domain.self () :> int) in
Format.kfprintf
(fun _ -> Mutex.unlock log_lock)
stdout
("%s%a %a[thread=%d] @[" ^^ fmt ^^ "@]@.\x1b[0m%!")
(level_to_color_string level)
(Ptime.pp_rfc3339 ~frac_s:5 ~space:true ~tz_offset_s:0 ())
(Ptime_clock.now ()) pp_level level domain
let trace msgf = if should_log Trace then msg Trace msgf
let debug msgf = if should_log Debug then msg Debug msgf
let info msgf = if should_log Info then msg Info msgf
let warn msgf = if should_log Warn then msg Warn msgf
let error msgf = if should_log Error then msg Error msgf