bikeshed ppx

ppx/dune

@@ -0,0 +1,8 @@
+(library
+ (name xlog_ppx)
+ (public_name xlog.ppx)
+ (synopsis "ppx rewriters for xlog")
+ (preprocess
+  (pps ppxlib.metaquot))
+ (libraries ppxlib)
+ (kind ppx_deriver))

ppx/xlog_ppx.ml

@@ -0,0 +1,55 @@
+open Ppxlib
+
+let log_expander ~ctxt (e : expression) (l : (arg_label * expression) list) : expression =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  let is_exn = begin match e.pexp_desc with
+  | Pexp_ident { txt = Lident "trace"; _ }
+  | Pexp_ident { txt = Lident "debug"; _ }
+  | Pexp_ident { txt = Lident "info"; _ }
+  | Pexp_ident { txt = Lident "warn"; _ }
+  | Pexp_ident { txt = Lident "error"; _ } -> false
+  | Pexp_ident { txt = Lident "exn"; _ } -> true
+  | _ ->
+      raise (Location.Error (Location.Error.make ~loc ~sub:[]
+                              "log type must be one of: trace, debug, info, warn, error, exn"))
+  end in
+  let open (val Ast_builder.make loc) in
+  if is_exn then
+    match l with
+    | [] ->
+      raise (Location.Error (Location.Error.make ~loc ~sub:[]
+                              "must provide exn value"))
+    | (_, v)::l ->
+        let application =
+          eapply (pexp_ident { txt = Lident "m"; loc}) (List.map snd l) in
+        [%expr [%e e] [%e v] (Printexc.get_raw_backtrace ()) ~__POS__ ~__FUNCTION__
+                      (fun m -> [%e application])]
+  else
+    let application =
+      eapply (pexp_ident { txt = Lident "m"; loc}) (List.map snd l) in
+    [%expr [%e e] ~__POS__ ~__FUNCTION__ (fun m -> [%e application])]
+
+let log_extension =
+  let pattern =
+    let open Ast_pattern in
+    pstr (pstr_eval (pexp_apply __ __) nil ^:: nil)
+  in
+  Context_free.Rule.extension
+    (Extension.V3.declare "xlog" Expression pattern log_expander)
+
+let import_expander ~ctxt _e : structure_item =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  [%stri include (val Xlog.logs __FUNCTION__)]
+
+let import_extension =
+  let pattern =
+    let open Ast_pattern in
+    __
+  in
+  Context_free.Rule.extension
+    (Extension.V3.declare "xlog_import" Structure_item pattern import_expander)
+
+let () =
+  Driver.register_transformation
+    ~rules:[ log_extension; import_extension ]
+    "xlog.ppx"

test/dune

@@ -1,3 +1,4 @@
 (test
  (name test_xlog)
+ (preprocess (pps xlog.ppx))
  (libraries xlog))

test/test_xlog.ml

@@ -1,2 +1,13 @@
+[%%xlog_import]
+
 let () =
-  Printf.eprintf "TODO\n%!"
+  Xlog.init_pretty_writer stdout ~min_level:Xlog.DEBUG
+
+let () =
+  [%xlog info "meow meow %s %d" "test string" 1337]
+
+let () =
+  try
+    failwith "meow2"
+  with
+  | e -> [%xlog exn e "oop's %d" 42069]