Make the extension entry point type available to the runtime; remove …

…empty subtrees for `%diagn`
lukstafi · Aug 24, 2024 · 9643191 · 9643191
1 parent 1f43a04
commit 9643191
Show file tree

Hide file tree

Showing 17 changed files with 353 additions and 5,468 deletions.
diff --git a/minidebug_runtime.ml b/minidebug_runtime.ml
@@ -171,9 +171,15 @@ module type Debug_runtime = sig
     message:string ->
     entry_id:int ->
     log_level:int ->
+    [ `Diagn | `Debug | `Track ] ->
     unit
 
-  val open_log_no_source : message:string -> entry_id:int -> log_level:int -> unit
+  val open_log_no_source :
+    message:string ->
+    entry_id:int ->
+    log_level:int ->
+    [ `Diagn | `Debug | `Track ] ->
+    unit
 
   val log_value_sexp :
     ?descr:string ->
@@ -321,7 +327,7 @@ module Flushing (Log_to : Shared_config) : Debug_runtime = struct
             depth_stack := (max depth (cur_depth + 1), cur_size + size) :: tl)
 
   let open_log ~fname ~start_lnum ~start_colnum ~end_lnum ~end_colnum ~message ~entry_id
-      ~log_level =
+      ~log_level _track_or_explicit =
     if check_log_level log_level then (
       let message = opt_verbose_entry_id ~verbose_entry_ids ~entry_id ^ message in
       let time_tag =
@@ -349,7 +355,7 @@ module Flushing (Log_to : Shared_config) : Debug_runtime = struct
       Printf.fprintf !debug_ch "%s\n%!" time_tag)
     else hidden_entries := entry_id :: !hidden_entries
 
-  let open_log_no_source ~message ~entry_id ~log_level =
+  let open_log_no_source ~message ~entry_id ~log_level _track_or_explicit =
     if check_log_level log_level then (
       let message = opt_verbose_entry_id ~verbose_entry_ids ~entry_id ^ message in
       let time_tag =
@@ -526,6 +532,7 @@ module PrintBox (Log_to : Shared_config) = struct
 
   type entry = {
     no_debug_if : bool;
+    track_or_explicit : [ `Diagn | `Debug | `Track ];
     highlight : bool;
     exclude : bool;
     elapsed : Mtime.span;
@@ -594,6 +601,7 @@ module PrintBox (Log_to : Shared_config) = struct
   let stack_to_tree ~elapsed_on_close
       {
         no_debug_if;
+        track_or_explicit = _;
         highlight;
         exclude = _;
         elapsed;
@@ -900,11 +908,9 @@ module PrintBox (Log_to : Shared_config) = struct
       match !stack with
       | { no_debug_if = true; _ } :: bs -> bs
       | { highlight = false; _ } :: bs when config.prune_upto >= List.length !stack -> bs
-      (* FIXME: rethink and explain this in the README: log level 3 for empty bodies, log
-         level 2 for non-explicit-content-only bodies. *)
-      | { body = []; _ } :: bs when !log_level < 3 -> bs
-      | { body; _ } :: bs when !log_level < 2 && List.for_all (fun e -> e.is_result) body
-        ->
+      | { body = []; track_or_explicit = `Diagn; _ } :: bs -> bs
+      | { body; track_or_explicit = `Diagn; _ } :: bs
+        when List.for_all (fun e -> e.is_result) body ->
           bs
       | ({
            highlight = hl;
@@ -917,6 +923,7 @@ module PrintBox (Log_to : Shared_config) = struct
          } as entry)
         :: {
              no_debug_if;
+             track_or_explicit;
              highlight;
              exclude;
              uri;
@@ -942,6 +949,7 @@ module PrintBox (Log_to : Shared_config) = struct
           in
           {
             no_debug_if;
+            track_or_explicit;
             highlight = highlight || ((not exclude) && hl);
             exclude;
             uri;
@@ -1065,6 +1073,7 @@ module PrintBox (Log_to : Shared_config) = struct
           [
             {
               no_debug_if = false;
+              track_or_explicit = `Debug;
               highlight = hl;
               exclude = false;
               elapsed;
@@ -1082,7 +1091,7 @@ module PrintBox (Log_to : Shared_config) = struct
         close_log ~fname:"orphaned" ~start_lnum:entry_id ~entry_id:(-1)
 
   let open_log ~fname ~start_lnum ~start_colnum ~end_lnum ~end_colnum ~message ~entry_id
-      ~log_level =
+      ~log_level track_or_explicit =
     if check_log_level log_level then
       let elapsed = time_elapsed () in
       let uri =
@@ -1124,6 +1133,7 @@ module PrintBox (Log_to : Shared_config) = struct
       stack :=
         {
           no_debug_if = false;
+          track_or_explicit;
           highlight;
           exclude;
           uri;
@@ -1140,7 +1150,7 @@ module PrintBox (Log_to : Shared_config) = struct
         :: !stack
     else hidden_entries := entry_id :: !hidden_entries
 
-  let open_log_no_source ~message ~entry_id ~log_level =
+  let open_log_no_source ~message ~entry_id ~log_level track_or_explicit =
     if check_log_level log_level then
       let time_tag =
         match time_tagged with
@@ -1158,6 +1168,7 @@ module PrintBox (Log_to : Shared_config) = struct
       stack :=
         {
           no_debug_if = false;
+          track_or_explicit;
           highlight;
           exclude;
           uri = "";

diff --git a/minidebug_runtime.mli b/minidebug_runtime.mli
@@ -96,9 +96,15 @@ module type Debug_runtime = sig
     message:string ->
     entry_id:int ->
     log_level:int ->
+    [ `Diagn | `Debug | `Track ] ->
     unit
 
-  val open_log_no_source : message:string -> entry_id:int -> log_level:int -> unit
+  val open_log_no_source :
+    message:string ->
+    entry_id:int ->
+    log_level:int ->
+    [ `Diagn | `Debug | `Track ] ->
+    unit
 
   val log_value_sexp :
     ?descr:string ->

diff --git a/ppx_minidebug.ml b/ppx_minidebug.ml
@@ -133,7 +133,12 @@ let rec pat2expr pat =
       @@ Location.error_extensionf ~loc
            "ppx_minidebug requires a pattern identifier here: try using an `as` alias."
 
-let open_log ?(message = "") ~loc ~log_level () =
+let lift_track_or_explicit ~loc = function
+  | `Diagn -> [%expr `Diagn]
+  | `Debug -> [%expr `Debug]
+  | `Track -> [%expr `Track]
+
+let open_log ?(message = "") ~loc ~log_level track_or_explicit =
   if String.contains message '\n' then
     A.pexp_extension ~loc
     @@ Location.error_extensionf ~loc
@@ -148,12 +153,14 @@ let open_log ?(message = "") ~loc ~log_level () =
         ~end_lnum:[%e A.eint ~loc loc.loc_end.pos_lnum]
         ~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
-        ~log_level:[%e A.eint ~loc log_level]]
+        ~log_level:[%e A.eint ~loc log_level]
+        [%e lift_track_or_explicit ~loc track_or_explicit]]
 
-let open_log_no_source ~message ~loc ~log_level () =
+let open_log_no_source ~message ~loc ~log_level track_or_explicit =
   [%expr
     Debug_runtime.open_log_no_source ~message:[%e message] ~entry_id:__entry_id
-      ~log_level:[%e A.eint ~loc log_level]]
+      ~log_level:[%e A.eint ~loc log_level]
+      [%e lift_track_or_explicit ~loc track_or_explicit]]
 
 let close_log ~loc =
   [%expr
@@ -541,7 +548,9 @@ let debug_body context callback ~loc ~message ~descr_loc ~log_count_before ~arg_
     | Some t when context.output_type_info -> message ^ " : " ^ typ2str t
     | _ -> message
   in
-  let preamble = open_log ~message ~loc ~log_level:context.entry_log_level () in
+  let preamble =
+    open_log ~message ~loc ~log_level:context.entry_log_level context.track_or_explicit
+  in
   let preamble =
     List.fold_left
       (fun e1 e2 ->
@@ -833,7 +842,7 @@ let debug_binding context callback vb =
             in
             let preamble =
               open_log ~message:descr_loc.txt ~loc:descr_loc.loc
-                ~log_level:context.entry_log_level ()
+                ~log_level:context.entry_log_level context.track_or_explicit
             in
             entry_with_interrupts context ~loc ~descr_loc ~log_count_before ~preamble
               ~entry:(callback nested exp) ~result ~log_result ()
@@ -1180,7 +1189,8 @@ let traverse_expression =
               in
               let log_count_before = !global_log_count in
               let preamble =
-                open_log_no_source ~message ~loc ~log_level:context.entry_log_level ()
+                open_log_no_source ~message ~loc ~log_level:context.entry_log_level
+                  context.track_or_explicit
               in
               let result = A.ppat_var ~loc { loc; txt = "__res" } in
               let context = { context with entry_log_level } in
@@ -1239,7 +1249,9 @@ let traverse_expression =
               let then_' =
                 [%expr
                   let __entry_id = Debug_runtime.get_entry_id () in
-                  [%e open_log ~message ~loc ~log_level:context.entry_log_level ()];
+                  [%e
+                    open_log ~message ~loc ~log_level:context.entry_log_level
+                      context.track_or_explicit];
                   match [%e then_] with
                   | if_then__result ->
                       [%e close_log ~loc];
@@ -1263,7 +1275,9 @@ let traverse_expression =
                     let message = "else:" ^ loc_to_name loc in
                     [%expr
                       let __entry_id = Debug_runtime.get_entry_id () in
-                      [%e open_log ~message ~loc ~log_level:context.entry_log_level ()];
+                      [%e
+                        open_log ~message ~loc ~log_level:context.entry_log_level
+                          context.track_or_explicit];
                       match [%e else_] with
                       | if_else__result ->
                           [%e close_log ~loc];
@@ -1293,7 +1307,8 @@ let traverse_expression =
               let preamble =
                 open_log
                   ~message:("<for " ^ descr_loc.txt ^ ">")
-                  ~loc:descr_loc.loc ~log_level:context.entry_log_level ()
+                  ~loc:descr_loc.loc ~log_level:context.entry_log_level
+                  context.track_or_explicit
               in
               let header =
                 log_value context ~loc ~typ ~descr_loc ~is_explicit:false ~is_result:false
@@ -1310,7 +1325,9 @@ let traverse_expression =
             let transformed =
               [%expr
                 let __entry_id = Debug_runtime.get_entry_id () in
-                [%e open_log ~message ~loc ~log_level:context.entry_log_level ()];
+                [%e
+                  open_log ~message ~loc ~log_level:context.entry_log_level
+                    context.track_or_explicit];
                 match [%e { exp with pexp_desc }] with
                 | () -> [%e close_log ~loc]
                 | exception e ->
@@ -1329,7 +1346,7 @@ let traverse_expression =
               let descr_loc = { txt = "<while body>"; loc } in
               let preamble =
                 open_log ~message:"<while loop>" ~loc:descr_loc.loc
-                  ~log_level:context.entry_log_level ()
+                  ~log_level:context.entry_log_level context.track_or_explicit
               in
               entry_with_interrupts context ~loc ~descr_loc ~log_count_before ~preamble
                 ~entry:(callback context body)
@@ -1341,7 +1358,9 @@ let traverse_expression =
             let transformed =
               [%expr
                 let __entry_id = Debug_runtime.get_entry_id () in
-                [%e open_log ~message ~loc ~log_level:context.entry_log_level ()];
+                [%e
+                  open_log ~message ~loc ~log_level:context.entry_log_level
+                    context.track_or_explicit];
                 match [%e { exp with pexp_desc }] with
                 | () -> [%e close_log ~loc]
                 | exception e ->