ohlog/lib/ohlog.ml

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)