Source file make_logging.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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
open Logging_types
open CalendarLib
module MakeLogging (H : HandlersT) =
struct
type level = Logging_types.level =
| Debug
| Trace
| Info
| Warning
| Error
| Flash
| NoLevel
let show_level = Logging_types.show_level
let pp_level = Logging_types.pp_level
let debug = ref false
class logger
?parent:(parent=None)
(name: string)
=
object(self)
val name = name
val mutable level : level option = None
val mutable handlers : H.t list = []
val parent : logger option = parent
val mutable propagate = true
val mutable tag_generators : (unit -> string) list = []
method set_level new_level =
level <- Some new_level
method add_handler h = handlers <- h::handlers
method get_handlers = handlers
method set_handlers hs = handlers <- hs
method set_propagate p = propagate <- p
method effective_level : level =
match level, parent with
| None, None -> NoLevel
| None, Some p -> p#effective_level
| Some l,_ -> l
method get_handlers_propagate =
if !debug
then
print_endline (Printf.sprintf "[%s] returning (%i) handlers" name
(List.length handlers));
match propagate, parent with
| true, Some p -> handlers @ p#get_handlers_propagate
| _ -> handlers
method add_tag_generator t =
tag_generators <- t :: tag_generators
method private treat_msg : 'a. ('a -> string) -> string list -> level -> 'a -> unit
= fun unwrap_fun tags msg_level msg ->
if !debug
then
print_endline ( Printf.sprintf "[%s]/%s -- Treating msg \"%s\" at level %s"
name (match level with
| None -> "None"
| Some lvl -> (show_level lvl))
(unwrap_fun msg) (show_level msg_level));
let generated_tags = List.map (fun x -> x ()) tag_generators in
let item : log_item= {
level = msg_level;
logger_name = name;
msg = unwrap_fun msg;
tags=generated_tags @ tags;
timestamp = Fcalendar.to_unixfloat @@ Fcalendar.now ()
} in
List.iter (fun handler ->
H.apply handler item)
self#get_handlers_propagate
method private _log_msg : 'a. ('a -> string) -> string list -> level -> 'a -> unit
= fun unwrap_fun tags msg_level msg ->
if msg_level >= self#effective_level
then
self#treat_msg unwrap_fun tags msg_level msg
else
()
method private _flog_msg : 'a. string list -> level -> ('a, unit, string, unit) format4 -> 'a
= fun tags msg_level ->
if msg_level >= self#effective_level
then
Printf.ksprintf (
self#treat_msg (fun x -> x) tags msg_level)
else Printf.ifprintf ()
method flash : 'a. ?tags:string list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Flash
method error : 'a. ?tags:string list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Error
method warning : 'a. ?tags:string list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Warning
method info : 'a. ?tags:string list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Info
method trace : 'a. ?tags:string list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Trace
method debug : 'a. ?tags:string list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Debug
method lflash ?tags:(tags=[]) = self#_log_msg Lazy.force tags Flash
method lerror ?tags:(tags=[]) = self#_log_msg Lazy.force tags Error
method lwarning ?tags:(tags=[]) = self#_log_msg Lazy.force tags Warning
method linfo ?tags:(tags=[]) = self#_log_msg Lazy.force tags Info
method ltrace ?tags:(tags=[]) = self#_log_msg Lazy.force tags Trace
method ldebug ?tags:(tags=[]) = self#_log_msg Lazy.force tags Debug
method sflash ?tags:(tags=[]) = self#_log_msg (fun x -> x) tags Flash
method serror ?tags:(tags=[]) = self#_log_msg (fun x -> x) tags Error
method swarning ?tags:(tags=[]) = self#_log_msg (fun x -> x) tags Warning
method sinfo ?tags:(tags=[]) = self#_log_msg (fun x -> x) tags Info
method strace ?tags:(tags=[]) = self#_log_msg (fun x -> x) tags Trace
method sdebug ?tags:(tags=[]) = self#_log_msg (fun x -> x) tags Debug
end
let root_logger = new logger "root"
module Infra =
Logging_infra.MakeTree(
struct
type t = logger
let make (n:string) parent = new logger ~parent n
let root = root_logger
end)
let handlers_config = ref H.default_config
let set_handlers_config c = handlers_config := c
let get_logger name =
Infra.get name
let make_logger ?propagate:(propagate=true) name lvl hdescs =
let l = Infra.get name in
l#set_level lvl;
l#set_propagate propagate;
List.iter (fun hdesc -> l#add_handler (H.make ~config:(!handlers_config) hdesc)) hdescs;
l
end