Fixes #39: new %log_entry functionality

lukstafi · Mar 10, 2024 · cbf5d67 · cbf5d67
1 parent 918f114
commit cbf5d67
Show file tree

Hide file tree

Showing 5 changed files with 183 additions and 29 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -1,3 +1,9 @@
+## [1.5.0] -- current
+
+### Added
+
+- An API function `Debug_runtime.open_log_no_source` for log entries without associated source code locations, and a corresponding `[%log_entry]` extension point.
+
 ## [1.4.0] -- 2024-03-08
 
 ### Added

diff --git a/minidebug_runtime.ml b/minidebug_runtime.ml
@@ -165,6 +165,8 @@ module type Debug_runtime = sig
     entry_id:int ->
     unit
 
+  val open_log_no_source : message:string -> entry_id:int -> unit
+
   val log_value_sexp :
     ?descr:string -> entry_id:int -> is_result:bool -> Sexplib0.Sexp.t -> unit
 
@@ -255,13 +257,13 @@ module Flushing (Log_to : Shared_config) : Debug_runtime = struct
     | { message; elapsed; time_tag; entry_id = open_entry_id; _ } :: tl -> (
         stack := tl;
         (if open_entry_id <> entry_id then
-         let log_loc =
-           Printf.sprintf "%s\"%s\":%d: open entry_id=%d, close entry_id=%d" global_prefix
-             fname start_lnum open_entry_id entry_id
-         in
-         failwith
-         @@ "ppx_minidebug: lexical scope of close_log not matching its dynamic scope; "
-         ^ log_loc);
+           let log_loc =
+             Printf.sprintf "%s\"%s\":%d: open entry_id=%d, close entry_id=%d"
+               global_prefix fname start_lnum open_entry_id entry_id
+           in
+           failwith
+           @@ "ppx_minidebug: lexical scope of close_log not matching its dynamic scope; "
+           ^ log_loc);
         Printf.fprintf !debug_ch "%s%!" (indent ());
         (match Log_to.time_tagged with
         | Not_tagged -> ()
@@ -314,6 +316,22 @@ module Flushing (Log_to : Shared_config) : Debug_runtime = struct
       { message; elapsed = time_elapsed (); time_tag; num_children = 0; entry_id }
       :: !stack
 
+  let open_log_no_source ~message ~entry_id =
+    Printf.fprintf !debug_ch "%s%s%s%s begin %!" (indent ()) global_prefix
+      (opt_entry_id ~print_entry_ids ~entry_id)
+      message;
+    let message = opt_verbose_entry_id ~verbose_entry_ids ~entry_id ^ message in
+    let time_tag =
+      match Log_to.time_tagged with
+      | Not_tagged -> ""
+      | Clock -> " " ^ timestamp_to_string ()
+      | Elapsed -> Format.asprintf " %a" pp_elapsed ()
+    in
+    Printf.fprintf !debug_ch "%s\n%!" time_tag;
+    stack :=
+      { message; elapsed = time_elapsed (); time_tag; num_children = 0; entry_id }
+      :: !stack
+
   let bump_stack_entry entry_id =
     match !stack with
     | ({ num_children; _ } as entry) :: tl ->
@@ -541,14 +559,19 @@ module PrintBox (Log_to : Shared_config) = struct
     in
     let colon a b = if a = "" || b = "" then a ^ b else a ^ ": " ^ b in
     let b_path =
-      let inner =
-        B.line
-        @@
+      if uri = "" then
         if config.values_first_mode then
-          if entry_id = -1 then colon path entry_message else path
-        else colon path entry_message ^ span
-      in
-      hyperlink_path ~uri ~inner
+          if entry_id = -1 then B.line entry_message else B.empty
+        else B.line @@ entry_message ^ span
+      else
+        let inner =
+          B.line
+          @@
+          if config.values_first_mode then
+            if entry_id = -1 then colon path entry_message else path
+          else colon path entry_message ^ span
+        in
+        hyperlink_path ~uri ~inner
     in
     let is_pure_text = config.backend = `Text in
     let anchor_id = anchor_entry_id ~is_pure_text ~entry_id in
@@ -688,7 +711,7 @@ module PrintBox (Log_to : Shared_config) = struct
     | _ -> ());
     (* Note: we treat a tree under a box as part of that box. *)
     stack :=
-      (* Design choice: exclude does not apply to its own entry -- its about propagating children. *)
+      (* Design choice: exclude does not apply to its own entry -- it's about propagating children. *)
       match !stack with
       | { highlight = false; _ } :: bs when config.prune_upto >= List.length !stack -> bs
       | { body = []; _ } :: bs when config.log_level <> Everything -> bs
@@ -895,6 +918,37 @@ module PrintBox (Log_to : Shared_config) = struct
       }
       :: !stack
 
+  let open_log_no_source ~message ~entry_id =
+    let time_tag =
+      match time_tagged with
+      | Not_tagged -> ""
+      | Clock -> Format.asprintf " at time %a" pp_timestamp ()
+      | Elapsed -> Format.asprintf " at elapsed %a" pp_elapsed ()
+    in
+    let exclude =
+      match config.exclude_on_path with Some r -> Re.execp r message | None -> false
+    in
+    let highlight =
+      match config.highlight_terms with Some r -> Re.execp r message | None -> false
+    in
+    let entry_message = global_prefix ^ message in
+    stack :=
+      {
+        cond = true;
+        highlight;
+        exclude;
+        uri = "";
+        path = "";
+        elapsed = time_elapsed ();
+        time_tag;
+        entry_message;
+        entry_id;
+        body = [];
+        depth = 0;
+        size = 1;
+      }
+      :: !stack
+
   let sexp_size sexp =
     let open Sexplib0.Sexp in
     let rec loop = function
@@ -989,15 +1043,15 @@ module PrintBox (Log_to : Shared_config) = struct
       | _ -> true
     in
     (if config.boxify_sexp_from_size >= 0 then
-     stack_next ~entry_id ~is_result ~prefixed ~result_depth:0 ~result_size:1
-     @@ boxify ?descr sexp
-    else
-      stack_next ~entry_id ~is_result ~prefixed ~result_depth:0 ~result_size:1
-      @@ highlight_box
-      @@
-      match descr with
-      | None -> B.asprintf_with_style B.Style.preformatted "%a" pp_sexp sexp
-      | Some d -> B.asprintf_with_style B.Style.preformatted "%s = %a" d pp_sexp sexp);
+       stack_next ~entry_id ~is_result ~prefixed ~result_depth:0 ~result_size:1
+       @@ boxify ?descr sexp
+     else
+       stack_next ~entry_id ~is_result ~prefixed ~result_depth:0 ~result_size:1
+       @@ highlight_box
+       @@
+       match descr with
+       | None -> B.asprintf_with_style B.Style.preformatted "%a" pp_sexp sexp
+       | Some d -> B.asprintf_with_style B.Style.preformatted "%s = %a" d pp_sexp sexp);
     opt_auto_snapshot ()
 
   let skip_parens s =

diff --git a/minidebug_runtime.mli b/minidebug_runtime.mli
@@ -106,6 +106,11 @@ module type Debug_runtime = sig
     entry_id:int ->
     unit
 
+  val open_log_no_source :
+    message:string ->
+    entry_id:int ->
+    unit
+
   val log_value_sexp :
     ?descr:string -> entry_id:int -> is_result:bool -> Sexplib0.Sexp.t -> unit
 

diff --git a/ppx_minidebug.ml b/ppx_minidebug.ml
@@ -176,6 +176,9 @@ let open_log ?(message = "") ~loc () =
         ~end_colnum:[%e A.eint ~loc (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)]
         ~message:[%e A.estring ~loc message] ~entry_id:__entry_id]
 
+let open_log_no_source ~message ~loc () =
+  [%expr Debug_runtime.open_log_no_source ~message:[%e message] ~entry_id:__entry_id]
+
 let close_log ~loc =
   [%expr
     Debug_runtime.close_log
@@ -321,6 +324,11 @@ let log_string ~loc ~descr_loc s =
         ~descr:[%e A.estring ~loc:descr_loc.loc descr_loc.txt]
         ~entry_id:__entry_id ~is_result:false [%e A.estring ~loc s]]
 
+let log_string_with_descr ~loc ~message s =
+  [%expr
+    Debug_runtime.log_value_show ~descr:[%e message] ~entry_id:__entry_id ~is_result:false
+      [%e A.estring ~loc s]]
+
 type fun_arg =
   | Pexp_fun_arg of
       arg_label * expression option * pattern * location * location_stack * attributes
@@ -497,22 +505,32 @@ let bound_patterns ~alt_typ pat =
   let loc = pat.ppat_loc in
   (A.ppat_alias ~loc bind_pat { txt = "__res"; loc }, bound)
 
-let entry_with_interrupts context ~loc ~descr_loc ~log_count_before ?header ~preamble
-    ~entry ~result ~log_result () =
-  if context.log_level <> Everything && log_count_before = !global_log_count then entry
+let entry_with_interrupts context ~loc ?descr_loc ?message ~log_count_before ?header
+    ~preamble ~entry ~result ~log_result () =
+  let log_string =
+    match (descr_loc, message) with
+    | Some descr_loc, None -> log_string ~loc ~descr_loc
+    | None, Some message -> log_string_with_descr ~loc ~message
+    | _ -> assert false
+  in
+  if
+    context.log_level <> Everything
+    && log_count_before = !global_log_count
+    && message = None
+  then entry
   else
     let header = match header with Some h -> h | None -> [%expr ()] in
     if context.interrupts then
       [%expr
         let __entry_id = Debug_runtime.get_entry_id () in
         [%e header];
         if Debug_runtime.exceeds_max_children () then (
-          [%e log_string ~loc ~descr_loc "<max_num_children exceeded>"];
+          [%e log_string "<max_num_children exceeded>"];
           failwith "ppx_minidebug: max_num_children exceeded")
         else (
           [%e preamble];
           if Debug_runtime.exceeds_max_nesting () then (
-            [%e log_string ~loc ~descr_loc "<max_nesting_depth exceeded>"];
+            [%e log_string "<max_nesting_depth exceeded>"];
             [%e close_log ~loc];
             failwith "ppx_minidebug: max_nesting_depth exceeded")
           else
@@ -1098,6 +1116,24 @@ let traverse_expression =
             log_value context ~loc ~typ ~is_explicit:true ~is_result:true body
         | Pexp_extension ({ loc = _; txt = "log_printbox" }, PStr [%str [%e? body]]) ->
             log_value_printbox context ~loc body
+        | Pexp_extension
+            ( { loc = _; txt = "log_entry" },
+              PStr
+                [%str
+                  [%e? message];
+                  [%e? entry]] ) ->
+            let log_count_before = !global_log_count in
+            let preamble = open_log_no_source ~message ~loc () in
+            let result = A.ppat_var ~loc { loc; txt = "__res" } in
+            let entry = callback { context with toplevel_opt_arg = Nested } entry in
+            let log_result = [%expr ()] in
+            entry_with_interrupts context ~loc ~message ~log_count_before ~preamble ~entry
+              ~result ~log_result ()
+        | Pexp_extension ({ loc = _; txt = "log_entry" }, PStr [%str [%e? _entry]]) ->
+            A.pexp_extension ~loc
+            @@ Location.error_extensionf ~loc
+                 "ppx_minidebug: bad syntax, expacted [%%log_entry <HEADER MESSAGE>; \
+                  <BODY>]"
         | (Pexp_newtype _ | Pexp_fun _)
           when context.toplevel_opt_arg <> Nested || not restrict_to_explicit ->
             debug_fun context callback ?typ:ret_typ exp

diff --git a/test/test_expect_test.ml b/test/test_expect_test.ml
@@ -3501,3 +3501,56 @@ let%expect_test "%log_printbox flushing" =
        bar end
        foo = ()
       foo end |}]
+
+let%expect_test "%log_entry" =
+  let module Debug_runtime = (val Minidebug_runtime.debug ()) in
+  let%diagn_show _logging_logic : unit =
+    let rec loop logs =
+      match logs with
+      | "start" :: header :: tl ->
+          let more =
+            [%log_entry
+              header;
+              loop tl]
+          in
+          loop more
+      | "end" :: tl -> tl
+      | msg :: tl ->
+          [%log msg];
+          loop tl
+      | [] -> []
+    in
+    ignore
+    @@ loop
+         [
+           "preamble";
+           "start";
+           "header 1";
+           "log 1";
+           "start";
+           "nested header";
+           "log 2";
+           "end";
+           "log 3";
+           "end";
+           "start";
+           "header 2";
+           "log 4";
+           "end";
+           "postscript";
+         ]
+  in
+  [%expect
+    {|
+      BEGIN DEBUG SESSION
+      "test/test_expect_test.ml":3507:17: _logging_logic
+      ├─"preamble"
+      ├─header 1
+      │ ├─"log 1"
+      │ ├─nested header
+      │ │ └─"log 2"
+      │ └─"log 3"
+      ├─header 2
+      │ └─"log 4"
+      └─"postscript"
+    |}]