bikeshed source location and exceptions

README.md

@@ -11,12 +11,38 @@ same license
 ```ocaml
 include (val Xlog.logs __FUNCTION__)
 
+(* basic usage *)
 let () =
   info (fun m -> m "meow meow meow")
 
+(* add source location info *)
+let () =
+  info ~__POS__ ~__FUNCTION__ (fun m -> m "meow meow meow")
+
+(* log exception *)
+try
+  fallible_task ()
+with
+| e ->
+  exn e (Printexc.get_raw_backtrace ()) ~__POS__ ~__FUNCTION__
+    (fun m -> m "encountered error")
+
 module Submodule = struct
   include (val Xlog.logs __FUNCTION__)
 
   (* ... *)
 end
+
+(* in the main module *)
+Xlog.init_pretty_writer stdout
+  ~min_level:Xlog.DEBUG
+  (* other options *)
+
+(* if running as a daemon *)
+if Xlog.should_upgrade_to_journald () then
+  Xlog.init_journald_writer ()
+    ~min_level:Xlog.DEBUG
+else
+  Xlog.init_pretty_writer stdout
+    ~min_level:Xlog.DEBUG
 ```

lib/core.ml

@@ -10,10 +10,15 @@ external int_of_level : level -> int = "%identity"
 type writer =
   ts:Time.t ->
   ns:string ->
+  filename:string ->
+  lineno:int ->
+  func:string ->
+  errno:int ->
+  exn:((exn * Printexc.raw_backtrace) option) ->
   lvl:level ->
   string ->
   unit
 
-let ( +++ ) w1 w2 ~ts ~ns ~lvl msg =
+let ( +++ ) w1 w2 ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg =
-  w1 ~ts ~ns ~lvl msg;
+  w1 ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg;
-  w2 ~ts ~ns ~lvl msg
+  w2 ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg

lib/journald.ml

@@ -40,13 +40,30 @@ let syslog_priority = function
   | WARN  -> "4" (* LOG_WARNING *)
   | ERROR -> "3" (* LOG_ERR *)
 
-let writer t ~ts ~ns ~lvl msg =
+let writer t ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg =
   Mutex.lock t.mutex;
   let dgram =
     Buffer.clear t.buf;
     ignore ts;
-    add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
+    let maybe_exn = match exn with
+    | Some (exn, bt) ->
+        Printf.sprintf "\nException: %s\n%s" (Printexc.to_string exn)
+          (Printexc.raw_backtrace_to_string bt)
+    | None -> ""
+    in
+    add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s%s" ns msg maybe_exn);
     add_field t.buf "PRIORITY" (syslog_priority lvl);
+    begin if not (filename = "") then
+      add_field t.buf "CODE_FILE" filename;
+      add_field t.buf "CODE_LINE" (Printf.sprintf "%d" lineno)
+    end;
+    begin if not (func = "") then
+      add_field t.buf "CODE_FUNC" func
+    end;
+    let errno = Util.get_errno errno exn in
+    begin if errno != 0 then
+      add_field t.buf "ERRNO" (Printf.sprintf "%d" errno)
+    end;
     Buffer.to_bytes t.buf
   in
   Mutex.unlock t.mutex;

lib/pretty.ml

@@ -13,12 +13,16 @@ type config = {
   timestamp : bool;
   namespace : bool;
   level : bool;
+  source_loc : bool;
+  backtrace : bool;
 }
 
-let _fl_c = 1 (* color *)
+let _fl_c = 1  (* color *)
-let _fl_t = 2 (* timestamp *)
+let _fl_t = 2  (* timestamp *)
-let _fl_n = 4 (* namespace *)
+let _fl_n = 4  (* namespace *)
-let _fl_l = 8 (* level *)
+let _fl_l = 8  (* level *)
+let _fl_s = 16 (* source_loc *)
+let _fl_b = 32 (* backtrace *)
 let _fl_ct = _fl_c + _fl_t
 let _fl_cl = _fl_c + _fl_l
 
@@ -40,6 +44,10 @@ let ansi_dim  = "\x1b[2m"
 let ansi_bold = "\x1b[1m"
 let ansi_off  = "\x1b[0m"
 
+let box_at    = "└─ "
+let box_exn   = "├─ "
+let box_bt    = "├─── "
+
 let pr_timestamp bp ts =
   Buffer.add_string bp (Time.to_string ts)
 
@@ -65,10 +73,12 @@ let make (out : out_channel) (cfg : config) = {
   bp = Buffer.create 512;
   align_to = 0;
   out;
-  flags = (if cfg.color     then _fl_c else 0) +
+  flags = (if cfg.color      then _fl_c else 0) +
-          (if cfg.timestamp then _fl_t else 0) +
+          (if cfg.timestamp  then _fl_t else 0) +
-          (if cfg.namespace then _fl_n else 0) +
+          (if cfg.namespace  then _fl_n else 0) +
-          (if cfg.level     then _fl_l else 0)
+          (if cfg.level      then _fl_l else 0) +
+          (if cfg.source_loc then _fl_s else 0) +
+          (if cfg.backtrace  then _fl_b else 0)
 }
 
 let pr_msg bp msg ts ns lvl ~align ~indent ~f =
@@ -91,7 +101,8 @@ let pr_msg bp msg ts ns lvl ~align ~indent ~f =
     Buffer.add_string bp "\n";
   end
 
-let writer t ~ts ~ns ~lvl msg =
+let writer t ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg =
+  ignore errno;
   let f mask = t.flags land mask = mask in
   let align bp =
     let n = t.align_to - Buffer.length bp in
@@ -107,6 +118,31 @@ let writer t ~ts ~ns ~lvl msg =
   begin
     Mutex.lock t.mutex;
     pr_msg t.bp msg ts ns lvl ~align ~indent ~f;
+    begin match exn with
+    | Some (exn, bt) ->
+        Buffer.add_string t.bp box_exn;
+        Printf.bprintf t.bp "Exception: %s\n" (Printexc.to_string exn);
+        (* if not called within an exception handler, or backtraces are disabled, we don't get a
+           backtrace and thus empty string will get added *)
+        if f _fl_b then begin
+          let bt_parts = String.split_on_char '\n' (Printexc.raw_backtrace_to_string bt) in
+          List.iter (fun line ->
+            if not (String.trim line = "") then begin
+              Buffer.add_string t.bp box_bt;
+              Buffer.add_string t.bp line;
+              Buffer.add_string t.bp "\n" end) bt_parts
+        end
+    | None -> ()
+    end;
+    if f _fl_s && (not (filename = "") || not (func = "")) then begin
+      Buffer.add_string t.bp box_at;
+      begin match (filename, func) with
+      | ("", _) -> Printf.bprintf t.bp "%s" func
+      | (_, "") -> Printf.bprintf t.bp "%s:%d" filename lineno
+      | _ -> Printf.bprintf t.bp "%s @ %s:%d" func filename lineno
+      end;
+      Buffer.add_string t.bp "\n"
+    end;
     Buffer.output_buffer t.out t.bp;
     flush t.out;
     Buffer.clear t.bp;

lib/util.ml

@@ -7,3 +7,13 @@ let parse_module_name (name : string) : string list =
   | fst::rst ->
     let fst = Str.global_replace dune_exe_rx "[EXE]" fst in
     (Str.split dune_underscore_rx fst) @ rst
+
+external unix_code_of_unix_error : Unix.error -> int = "caml_unix_code_of_unix_error"
+
+let get_errno errno exn =
+  if errno != 0 then
+    errno
+  else
+    match exn with
+    | Some ((Unix.Unix_error (err, _, _)), _) -> unix_code_of_unix_error err
+    | _ -> 0

lib/xlog.ml

@@ -52,37 +52,61 @@ let rec find_or_make_logger parent_logger ns =
 type 'a log_function =
   ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
 
-let write logger lvl msg =
+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 ~lvl msg) logger.writers
+  Option.iter (fun w -> w ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg) logger.writers
 
-let[@inline] logf logger lvl : _ log_function = fun logk ->
+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 ->
-           Format.kasprintf (write logger lvl)
+           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_function
+  val trace : _ log_module_function
-  val debug : _ log_function
+  val debug : _ log_module_function
-  val info  : _ log_function
+  val info  : _ log_module_function
-  val warn  : _ log_function
+  val warn  : _ log_module_function
-  val error : _ log_function
+  val error : _ log_module_function
-  val log   : level -> _ log_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 k = logf logger TRACE k
+    let[@inline] trace
-    let[@inline] debug k = logf logger DEBUG k
+      ?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
-    let[@inline] info  k = logf logger INFO  k
+      k = logf logger TRACE ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
-    let[@inline] warn  k = logf logger WARN  k
+    let[@inline] debug
-    let[@inline] error k = logf logger ERROR k
+      ?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
-    let[@inline] log level k = logf logger level k
+      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)
@@ -111,9 +135,11 @@ let init_pretty_writer
       ?(timestamp = true)
       ?(namespace = true)
       ?(level = true)
+      ?(source_loc = true)
+      ?(backtrace = true)
       out
   =
-  Pretty.make out { color; timestamp; namespace; level } |>
+  Pretty.make out { color; timestamp; namespace; level; source_loc; backtrace } |>
   Pretty.writer |>
   add_writer ?min_level
 

lib/xlog.mli

@@ -11,14 +11,21 @@ type level =
 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)
+
 module type Logs = sig
   val logger : logger
-  val trace : _ log_function
+  val trace : _ log_module_function
-  val debug : _ log_function
+  val debug : _ log_module_function
-  val info  : _ log_function
+  val info  : _ log_module_function
-  val warn  : _ log_function
+  val warn  : _ log_module_function
-  val error : _ log_function
+  val error : _ log_module_function
-  val log   : level -> _ log_function
+  val exn   : exn -> Printexc.raw_backtrace -> _ log_module_function
+  val log   : level -> ?exn:((exn * Printexc.raw_backtrace) option) -> _ log_module_function
 end
 
 val logs : string -> (module Logs)
@@ -30,6 +37,8 @@ val init_pretty_writer :
   ?timestamp:bool ->
   ?namespace:bool ->
   ?level:bool ->
+  ?source_loc:bool ->
+  ?backtrace:bool ->
   out_channel -> unit
 
 val init_journald_writer :