xlog/lib/xlog.ml

165 lines
5.2 KiB
OCaml

include Core
type logger = {
namespace : string;
pnamespace : string list;
mutable child : logger;
sibling : logger;
mutable min_level : int;
mutable writers : writer option;
}
let rec root_logger = {
namespace = "";
pnamespace = [];
min_level = Int.max_int;
child = root_logger;
sibling = root_logger;
writers = None;
}
let rec find_logger parent_logger child_logger ns =
if child_logger == parent_logger then
None
else if List.nth_opt child_logger.pnamespace 0 = Some ns then
Some child_logger
else
find_logger parent_logger child_logger.sibling ns
let make_logger parent_logger ns =
let pnamespace = ns::parent_logger.pnamespace in
let rec logger = {
namespace = String.concat "." (List.rev pnamespace);
pnamespace = pnamespace;
min_level = parent_logger.min_level;
child = logger;
sibling = parent_logger.child;
writers = parent_logger.writers;
} in
parent_logger.child <- logger;
logger
let rec find_or_make_logger parent_logger ns =
match ns with
| [] -> parent_logger
| [""] -> parent_logger
| fst::rst -> begin
match find_logger parent_logger parent_logger.child fst with
| Some logger -> find_or_make_logger logger rst
| None -> find_or_make_logger (make_logger parent_logger fst) rst
end
type 'a log_function =
((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
type 'a log_module_function =
?__POS__:(string * int * int * int)
-> ?__FUNCTION__:string
-> ?errno:int
-> ('a log_function)
let write logger filename lineno func errno exn lvl msg =
let ts = Time.stamp () in
let ns = logger.namespace in
Option.iter (fun w -> w ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg) logger.writers
let[@inline] logf logger lvl ~__POS__ ~__FUNCTION__ ~errno ~exn : _ log_function = fun logk ->
if int_of_level lvl >= logger.min_level then
logk (fun fmt ->
let (filename, lineno, _, _) = __POS__ in
let func = Util.parse_module_name __FUNCTION__ |> String.concat "." in
Format.kasprintf (write logger filename lineno func errno exn lvl)
("@[<hov>" ^^ fmt))
module type Logs = sig
val logger : logger
val trace : _ log_module_function
val debug : _ log_module_function
val info : _ log_module_function
val warn : _ log_module_function
val error : _ log_module_function
val exn : exn -> Printexc.raw_backtrace -> _ log_module_function
val log : level -> ?exn:((exn * Printexc.raw_backtrace) option) -> _ log_module_function
end
let make_logs parent_logger ns =
(module struct
let logger = find_or_make_logger parent_logger ns
let[@inline] trace
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger TRACE ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] debug
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger DEBUG ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] info
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger INFO ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] warn
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger WARN ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] error
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger ERROR ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] exn exn bt
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger ERROR ~__POS__ ~__FUNCTION__ ~errno ~exn:(Some (exn, bt)) k
let[@inline] log level ?(exn=None)
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger level ~__POS__ ~__FUNCTION__ ~errno ~exn k
end : Logs)
let logs ns = make_logs root_logger (Util.parse_module_name 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[@inline] add_writer ?(min_level = WARN) writer =
add_writer_rec (int_of_level min_level) writer root_logger root_logger.child
let init_pretty_writer
?min_level
?(color = true)
?(timestamp = true)
?(namespace = true)
?(level = true)
?(source_loc = true)
?(backtrace = true)
out
=
Pretty.make out { color; timestamp; namespace; level; source_loc; backtrace } |>
Pretty.writer |>
add_writer ?min_level
let dump_tree () =
let rec dt (parent : logger) (child : logger) (ts : string) : unit =
Printf.eprintf "%slogger: %s\n%!" ts child.namespace;
if child.child == child then
()
else
dt child child.child (String.concat "" [ts; ">"]);
if child.sibling == parent then
()
else
dt parent child.sibling ts
in
Printf.eprintf "logger: <root>\n%!";
if root_logger.child == root_logger then
()
else
dt root_logger root_logger.child ">"
let _dump_tree = dump_tree