111 lines
3.0 KiB
OCaml
111 lines
3.0 KiB
OCaml
|
include Core
|
||
|
|
|
||
|
|
type logger = {
|
||
|
|
namespace : string;
|
||
|
|
mutable child : logger;
|
||
|
|
sibling : logger;
|
||
|
|
mutable min_level : int;
|
||
|
|
mutable writers : writer option;
|
||
|
|
}
|
||
|
|
|
||
|
|
let rec root_logger = {
|
||
|
|
namespace = "";
|
||
|
|
min_level = 0;
|
||
|
|
child = root_logger;
|
||
|
|
sibling = root_logger;
|
||
|
|
writers = None;
|
||
|
|
}
|
||
|
|
|
||
|
|
let make_logger parent_logger ns =
|
||
|
|
let namespace =
|
||
|
|
if parent_logger == root_logger then ns
|
||
|
|
else String.concat "." [parent_logger.namespace; ns];
|
||
|
|
in
|
||
|
|
let rec logger = {
|
||
|
|
namespace;
|
||
|
|
min_level = Int.max_int;
|
||
|
|
child = logger;
|
||
|
|
sibling = parent_logger.child;
|
||
|
|
writers = None;
|
||
|
|
} in
|
||
|
|
parent_logger.child <- logger;
|
||
|
|
logger
|
||
|
|
|
||
|
|
let write logger level msg =
|
||
|
|
let timestamp = Unix.gettimeofday () in
|
||
|
|
let namespace = logger.namespace in
|
||
|
|
Option.iter (fun w -> w ~timestamp ~namespace ~level msg) logger.writers
|
||
|
|
|
||
|
|
let writef logger level msgk =
|
||
|
|
msgk (fun f -> Format.kasprintf (write logger level) ("@[<hov>" ^^ f))
|
||
|
|
|
||
|
|
type 'a log_function =
|
||
|
|
((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
|
||
|
|
|
||
|
|
module type Logs = sig
|
||
|
|
val logger : logger
|
||
|
|
val trace : _ log_function
|
||
|
|
val debug : _ log_function
|
||
|
|
val info : _ log_function
|
||
|
|
val warn : _ log_function
|
||
|
|
val error : _ log_function
|
||
|
|
val log : level -> _ log_function
|
||
|
|
end
|
||
|
|
|
||
|
|
let make_logs parent_logger ns =
|
||
|
|
(module struct
|
||
|
|
let logger = make_logger parent_logger ns
|
||
|
|
let[@inline] trace k =
|
||
|
|
if logger.min_level <= 0 then writef logger TRACE k
|
||
|
|
let[@inline] debug k =
|
||
|
|
if logger.min_level <= 1 then writef logger DEBUG k
|
||
|
|
let[@inline] info k =
|
||
|
|
if logger.min_level <= 2 then writef logger INFO k
|
||
|
|
let[@inline] warn k =
|
||
|
|
if logger.min_level <= 3 then writef logger WARN k
|
||
|
|
let[@inline] error k =
|
||
|
|
if logger.min_level <= 4 then writef logger ERROR k
|
||
|
|
let[@inline] log level k =
|
||
|
|
if logger.min_level <= int_of_level level then
|
||
|
|
writef logger level k
|
||
|
|
end : Logs)
|
||
|
|
|
||
|
|
let logs ns = make_logs root_logger ns
|
||
|
|
let sublogs logger ns = make_logs logger ns
|
||
|
|
|
||
|
|
(* TODO: filters: namespace[*] => min_level *)
|
||
|
|
|
||
|
|
let rec add_writer_rec min_level writer parent_logger logger =
|
||
|
|
if parent_logger != logger then
|
||
|
|
begin
|
||
|
|
logger.min_level <- min min_level logger.min_level;
|
||
|
|
logger.writers <-
|
||
|
|
(match logger.writers with
|
||
|
|
| None -> Some writer
|
||
|
|
| Some writer' -> Some (writer' +++ writer));
|
||
|
|
add_writer_rec min_level writer logger logger.child;
|
||
|
|
add_writer_rec min_level writer parent_logger logger.sibling
|
||
|
|
end
|
||
|
|
|
||
|
|
let add_writer ?(min_level = WARN) writer =
|
||
|
|
add_writer_rec (int_of_level min_level) writer root_logger root_logger.child
|
||
|
|
|
||
|
|
let pretty_print_writer
|
||
|
|
?timestamp
|
||
|
|
?namespace
|
||
|
|
?colorize
|
||
|
|
?(mutex = true)
|
||
|
|
out =
|
||
|
|
let _ = timestamp, namespace, colorize in
|
||
|
|
let mutex = if mutex then Some (Mutex.create ()) else None in
|
||
|
|
Pretty_print.writer (Pretty_print.make mutex out)
|
||
|
|
|
||
|
|
let init
|
||
|
|
?min_level
|
||
|
|
?timestamp
|
||
|
|
?namespace
|
||
|
|
?colorize
|
||
|
|
?mutex
|
||
|
|
?(out = stderr) () =
|
||
|
|
add_writer ?min_level (pretty_print_writer ?timestamp ?namespace ?colorize ?mutex out)
|