xlog/lib/xlog.ml

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