Source file easy_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
type log_level = Easy_logging_types.level
let show_log_level = Easy_logging_types.show_level
let pp_log_level fmt lvl = Format.pp_print_string fmt (show_log_level lvl)
module type HandlersT = Easy_logging_types.HandlersT
module MakeLogging (H : HandlersT) =
struct
class logger
?parent:(parent=None)
(name: string)
=
object(self)
val name = name
val mutable level : log_level option = None
val mutable handlers : H.t list = []
val parent : logger option = parent
val mutable propagate = true
method set_level new_level =
level <- Some new_level
method add_handler h = handlers <- h::handlers
method set_propagate p = propagate <- p
method effective_level : log_level =
match level, parent with
| None, None -> NoLevel
| None, Some p -> p#effective_level
| Some l,_ -> l
method get_handlers =
match propagate, parent with
| true, Some p -> handlers @ p#get_handlers
| _ -> handlers
method private treat_msg : 'a. ('a -> string) -> H.tag list -> log_level -> 'a -> unit
= fun unwrap_fun tags msg_level msg ->
let item : H.log_item= {
level = msg_level;
logger_name = name;
msg = unwrap_fun msg;
tags=tags} in
List.iter (fun handler ->
H.apply handler item)
self#get_handlers
method private _log_msg : 'a. ('a -> string) -> H.tag list -> log_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. H.tag list -> log_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:H.tag list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Flash
method error : 'a. ?tags:H.tag list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Error
method warning : 'a. ?tags:H.tag list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Warning
method info : 'a. ?tags:H.tag list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg tags Info
method debug : 'a. ?tags:H.tag list -> ('a, unit, string, unit) format4 -> 'a
= fun ?tags:(tags=[]) -> self#_flog_msg 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 sdebug ?tags:(tags=[]) = self#_log_msg (fun x->x) 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 ldebug ?tags:(tags=[]) = self#_log_msg Lazy.force 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 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 hdesc)) hdescs;
l
end
module Default_handlers = Default_handlers
module Logging = MakeLogging(Default_handlers)