initial upload with some missing features

.gitignore

@@ -0,0 +1 @@
+/_build

bin/dune

@@ -0,0 +1,3 @@
+(executable
+ (name example)
+ (libraries ohlog))

bin/example.ml

@@ -0,0 +1,35 @@
+include (val Ohlog.logs "Ex")
+
+module A = struct
+  include (val Ohlog.sublogs logger "A")
+
+  module B = struct
+    include (val Ohlog.sublogs logger "B")
+
+    let init () =
+      trace (fun m -> m "hello from B");
+      error (fun m -> m "bye from B")
+  end
+
+  let init () =
+    info (fun m -> m "hello from A");
+    B.init ();
+    debug (fun m -> m "bye from A")
+end
+
+module C = struct
+  include (val Ohlog.sublogs logger "C")
+
+  let init () =
+    warn (fun m -> m "hello from C");
+    A.init ();
+    warn (fun m -> m "bye from C");
+end
+
+;;
+
+Ohlog.init ()
+  ~min_level:TRACE
+;;
+
+C.init ()

dune-project

@@ -0,0 +1,17 @@
+(lang dune 3.12)
+(name ohlog)
+(generate_opam_files true)
+; (source (github username/reponame))
+; (authors "Author Name")
+; (maintainers "Maintainer Name")
+; (license LICENSE)
+; (documentation https://url/to/documentation)
+
+(package
+ (name ohlog)
+ ; (synopsis "A short synopsis")
+ ; (description "A longer description")
+ ; (tags (topics "to describe" your project))
+ (depends
+   ocaml
+   dune))

lib/ansi.ml

@@ -0,0 +1,33 @@
+type ctl =
+  | Bold of bool
+  | Fg of color option
+
+and color = R | G | Y | U | C
+
+type t = ctl list
+
+external int_of_color : color -> int = "%identity"
+
+let string_of_ctl = function
+  | Bold true   -> "1"
+  | Bold false  -> "22"
+  (* | Fg (Some B) -> "30" *)
+  | Fg (Some R) -> "31"
+  | Fg (Some G) -> "32"
+  | Fg (Some Y) -> "33"
+  | Fg (Some U) -> "34"
+  (* | Fg (Some M) -> "35" *)
+  | Fg (Some C) -> "36"
+  (* | Fg (Some W) -> "37" *)
+  | Fg None     -> "39"
+
+let rec pr_rec pb pre suf = function
+  | [] ->
+    Buffer.add_string pb suf
+  | ctl :: ctls ->
+    Buffer.add_string pb pre;
+    Buffer.add_string pb (string_of_ctl ctl);
+    pr_rec pb ";" "m" ctls
+    
+let pr pb ctls =
+  pr_rec pb "\x1b[" "" ctls

lib/core.ml

@@ -0,0 +1,18 @@
+type level =
+  | TRACE (* 0 *)
+  | DEBUG (* 1 *)
+  | INFO  (* 2 *)
+  | WARN  (* 3 *)
+  | ERROR (* 4 *)
+
+external int_of_level : level -> int = "%identity"
+
+type writer =
+  timestamp:float ->
+  namespace:string ->
+  level:level ->
+  string -> unit
+
+let ( +++ ) w1 w2 ~timestamp ~namespace ~level msg =
+  w1 ~timestamp ~namespace ~level msg;
+  w2 ~timestamp ~namespace ~level msg

lib/dune

@@ -0,0 +1,4 @@
+(library
+ (name ohlog)
+ (public_name ohlog)
+ (libraries unix))

lib/ohlog.ml

@@ -0,0 +1,110 @@
+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)

lib/ohlog.mli

@@ -0,0 +1,34 @@
+type logger
+
+type level =
+  | TRACE
+  | DEBUG
+  | INFO
+  | WARN
+  | ERROR
+
+(* log_function (fun m -> m "<fmt>" <args>); *)
+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
+
+val logs : string -> (module Logs)
+val sublogs : logger -> string -> (module Logs)
+
+val init :
+  ?min_level:level ->
+  ?timestamp:[< `full | `time_only | `none] ->
+  ?namespace:[< `full | `abbrev | `none] ->
+  ?colorize:[< `full | `bold | `none] ->
+  ?mutex:bool ->
+  ?out:out_channel ->
+  unit -> unit

lib/pretty_print.ml

@@ -0,0 +1,87 @@
+open Core
+
+type t = {
+  mutex : Mutex.t option;
+  out : out_channel;
+  bp : Buffer.t;
+  mutable align_to : int;
+}
+
+let make mutex out = {
+  mutex;
+  out;
+  bp = Buffer.create 512;
+  align_to = 0;
+}
+
+(* TODO: config colors *)
+(* TODO: config timestamp *)
+(* TODO: config namespace *)
+
+let level_header = function
+  | TRACE -> "TRACE"
+  | DEBUG -> "DEBUG"
+  | INFO  -> "INFO"
+  | WARN  -> "WARN"
+  | ERROR -> "ERROR"
+
+let level_ansi = function
+  | TRACE -> [Ansi.Fg (Some U)]
+  | DEBUG -> [Ansi.Fg (Some C)]
+  | INFO  -> [Ansi.Fg (Some G)]
+  | WARN  -> [Ansi.Fg (Some Y)]
+  | ERROR -> [Ansi.Fg (Some R)]
+
+let pr_timestamp bp ts =
+  (* TODO: timestamp format options *)
+  let ts_ms = int_of_float (ts *. 1000.0) mod 1000 in
+  let tm = Unix.localtime ts in
+  Printf.bprintf bp "%04d-%02d-%02d %02d:%02d:%02d.%03d"
+    (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
+    tm.tm_hour tm.tm_min tm.tm_sec ts_ms
+
+let pr_spaces bp n =
+  for _ = 1 to n do
+    Buffer.add_char bp ' '
+  done
+
+let rec pr_lines_rec indent bp s i =
+  match String.index_from s i '\n' with
+  | exception Not_found ->
+    Buffer.add_substring bp s i (String.length s - i)
+  | k ->
+    Buffer.add_substring bp s i (k + 1 - i);
+    pr_spaces bp indent;
+    pr_lines_rec indent bp s (k + 1)
+
+let pr_lines ~indent bp s =
+  pr_lines_rec indent bp s 0
+
+let writer t ~timestamp ~namespace ~level msg =
+  begin
+    Option.iter Mutex.lock t.mutex;
+
+    Printf.bprintf t.bp "%a%a%a %s "
+      Ansi.pr [Bold true]
+      pr_timestamp timestamp
+      Ansi.pr [Bold false]
+      namespace;
+
+    pr_spaces t.bp (t.align_to - Buffer.length t.bp);
+    t.align_to <- Buffer.length t.bp;
+
+    Printf.bprintf t.bp "%a%-5s%a "
+      Ansi.pr (level_ansi level)
+      (level_header level)
+      Ansi.pr [Bold true; Fg None];
+
+    pr_lines t.bp msg ~indent:(0 (*t.align_to - 3*));
+    Printf.bprintf t.bp "%a\n"
+      Ansi.pr [Bold false];
+
+    Buffer.output_buffer t.out t.bp;
+    flush t.out;
+    Buffer.clear t.bp;
+    Option.iter Mutex.unlock t.mutex
+  end
+

ohlog.opam

@@ -0,0 +1,21 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+depends: [
+  "ocaml"
+  "dune" {>= "3.12"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]