From 501da880cb65f26ed3a140278b342be5d2b61100 Mon Sep 17 00:00:00 2001
From: xenia <xenia@awoo.systems>
Date: Tue, 23 Apr 2024 03:33:56 -0400
Subject: [PATCH] bikeshed ppx

---
 ppx/dune          |  8 +++++++
 ppx/xlog_ppx.ml   | 55 +++++++++++++++++++++++++++++++++++++++++++++++
 test/dune         |  1 +
 test/test_xlog.ml | 13 ++++++++++-
 4 files changed, 76 insertions(+), 1 deletion(-)
 create mode 100644 ppx/dune
 create mode 100644 ppx/xlog_ppx.ml

diff --git a/ppx/dune b/ppx/dune
new file mode 100644
index 0000000..3acdc68
--- /dev/null
+++ b/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))
diff --git a/ppx/xlog_ppx.ml b/ppx/xlog_ppx.ml
new file mode 100644
index 0000000..0bf9e1e
--- /dev/null
+++ b/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"
diff --git a/test/dune b/test/dune
index 5e417ce..fd04fa1 100644
--- a/test/dune
+++ b/test/dune
@@ -1,3 +1,4 @@
 (test
  (name test_xlog)
+ (preprocess (pps xlog.ppx))
  (libraries xlog))
diff --git a/test/test_xlog.ml b/test/test_xlog.ml
index 202558c..3ea0f34 100644
--- a/test/test_xlog.ml
+++ b/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]