only output BEGIN DEBUG SESSION when the (initial) log level > 0

lukstafi · Oct 18, 2024 · 409f866 · 409f866
1 parent 74ba8ff
commit 409f866
Show file tree

Hide file tree

Showing 4 changed files with 49 additions and 37 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -1,3 +1,10 @@
+## [2.0.2] -- 2024-10-18
+
+### Changed
+
+- `Shared_config` now has an `init_log_level` field, populated from the runtime creation functions' `~log_level` argument.
+- The header `BEGIN DEBUG SESSION` is only output when the (initial) log level is greater than 0.
+
 ## [2.0.1] -- 2024-09-08
 
 ### Changed

diff --git a/minidebug_runtime.ml b/minidebug_runtime.ml
@@ -68,14 +68,16 @@ module type Shared_config = sig
   val split_files_after : int option
   val toc_entry : toc_entry_criteria
   val description : string
+  val init_log_level : int
 end
 
 let elapsed_default = Not_reported
 
 let shared_config ?(time_tagged = Not_tagged) ?(elapsed_times = elapsed_default)
     ?(location_format = Beg_pos) ?(print_entry_ids = false) ?(verbose_entry_ids = false)
     ?(global_prefix = "") ?split_files_after ?(with_table_of_contents = false)
-    ?(toc_entry = And []) ?(for_append = true) filename : (module Shared_config) =
+    ?(toc_entry = And []) ?(for_append = true) ?(log_level = 9) filename :
+    (module Shared_config) =
   let module Result = struct
     let current_ch_name = ref filename
 
@@ -157,6 +159,7 @@ let shared_config ?(time_tagged = Not_tagged) ?(elapsed_times = elapsed_default)
     let split_files_after = split_files_after
     let toc_entry = toc_entry
     let description = filename ^ (if global_prefix = "" then "" else ":") ^ global_prefix
+    let init_log_level = log_level
   end in
   (module Result)
 
@@ -243,7 +246,7 @@ let opt_verbose_entry_id ~verbose_entry_ids ~entry_id =
 module Flushing (Log_to : Shared_config) : Debug_runtime = struct
   open Log_to
 
-  let log_level = ref 9
+  let log_level = ref init_log_level
   let max_nesting_depth = ref None
   let max_num_children = ref None
   let debug_ch = ref @@ debug_ch ()
@@ -264,17 +267,19 @@ module Flushing (Log_to : Shared_config) : Debug_runtime = struct
   let indent () = String.make (List.length !stack) ' '
 
   let () =
-    match Log_to.time_tagged with
-    | Not_tagged -> Printf.fprintf !debug_ch "\nBEGIN DEBUG SESSION %s\n%!" global_prefix
-    | Clock ->
-        Printf.fprintf !debug_ch "\nBEGIN DEBUG SESSION %sat time %s\n%!" global_prefix
-          (timestamp_to_string ())
-    | Elapsed ->
-        Printf.fprintf !debug_ch
-          "\nBEGIN DEBUG SESSION %sat elapsed %s, corresponding to time %s\n%!"
-          global_prefix
-          (Format.asprintf "%a" pp_elapsed ())
-          (timestamp_to_string ())
+    if !log_level > 0 then
+      match Log_to.time_tagged with
+      | Not_tagged ->
+          Printf.fprintf !debug_ch "\nBEGIN DEBUG SESSION %s\n%!" global_prefix
+      | Clock ->
+          Printf.fprintf !debug_ch "\nBEGIN DEBUG SESSION %sat time %s\n%!" global_prefix
+            (timestamp_to_string ())
+      | Elapsed ->
+          Printf.fprintf !debug_ch
+            "\nBEGIN DEBUG SESSION %sat elapsed %s, corresponding to time %s\n%!"
+            global_prefix
+            (Format.asprintf "%a" pp_elapsed ())
+            (timestamp_to_string ())
 
   let close_log ~fname ~start_lnum ~entry_id =
     match (!hidden_entries, !stack) with
@@ -477,7 +482,7 @@ let anchor_entry_id ~is_pure_text ~entry_id =
 module PrintBox (Log_to : Shared_config) = struct
   open Log_to
 
-  let log_level = ref 9
+  let log_level = ref init_log_level
   let max_nesting_depth = ref None
   let max_num_children = ref None
   let check_log_level level = level <= !log_level
@@ -559,18 +564,19 @@ module PrintBox (Log_to : Shared_config) = struct
     | `No_hyperlinks -> inner
 
   let () =
-    let log_header =
-      match time_tagged with
-      | Not_tagged -> CFormat.asprintf "@.BEGIN DEBUG SESSION %s@." global_prefix
-      | Clock ->
-          CFormat.asprintf "@.BEGIN DEBUG SESSION %sat time %a@." global_prefix
-            pp_timestamp ()
-      | Elapsed ->
-          CFormat.asprintf
-            "@.BEGIN DEBUG SESSION %sat elapsed %a, corresponding to time %a@."
-            global_prefix pp_elapsed () pp_timestamp ()
-    in
-    output_string (debug_ch ()) log_header
+    if !log_level > 0 then
+      let log_header =
+        match time_tagged with
+        | Not_tagged -> CFormat.asprintf "@.BEGIN DEBUG SESSION %s@." global_prefix
+        | Clock ->
+            CFormat.asprintf "@.BEGIN DEBUG SESSION %sat time %a@." global_prefix
+              pp_timestamp ()
+        | Elapsed ->
+            CFormat.asprintf
+              "@.BEGIN DEBUG SESSION %sat elapsed %a, corresponding to time %a@."
+              global_prefix pp_elapsed () pp_timestamp ()
+      in
+      output_string (debug_ch ()) log_header
 
   let apply_highlight hl b =
     let rec loop b =
@@ -1345,7 +1351,7 @@ let debug_file ?(time_tagged = Not_tagged) ?(elapsed_times = elapsed_default)
     PrintBox
       ((val shared_config ~time_tagged ~elapsed_times ~location_format ~print_entry_ids
               ~verbose_entry_ids ~global_prefix ~for_append ?split_files_after
-              ~with_table_of_contents ~toc_entry filename)) in
+              ~with_table_of_contents ~toc_entry ~log_level filename)) in
   Debug.config.backend <- Option.value backend ~default:(`Markdown default_md_config);
   Debug.config.boxify_sexp_from_size <- boxify_sexp_from_size;
   Debug.config.max_inline_sexp_length <- max_inline_sexp_length;
@@ -1409,13 +1415,13 @@ let debug ?debug_ch ?(time_tagged = Not_tagged) ?(elapsed_times = elapsed_defaul
     let global_prefix = if global_prefix = "" then "" else global_prefix ^ " "
     let split_files_after = None
     let toc_entry = toc_entry
+    let init_log_level = log_level
   end) in
   Debug.config.highlight_terms <- Option.map Re.compile highlight_terms;
   Debug.config.prune_upto <- prune_upto;
   Debug.config.truncate_children <- truncate_children;
   Debug.config.exclude_on_path <- Option.map Re.compile exclude_on_path;
   Debug.config.values_first_mode <- values_first_mode;
-  Debug.log_level := log_level;
   Debug.config.snapshot_every_sec <- snapshot_every_sec;
   Debug.config.toc_specific_hyperlink <- toc_specific_hyperlink;
   (module Debug)
@@ -1471,19 +1477,19 @@ let debug_flushing ?debug_ch:d_ch ?table_of_contents_ch ?filename
           let global_prefix = if global_prefix = "" then "" else global_prefix ^ " "
           let split_files_after = split_files_after
           let toc_entry = toc_entry
+          let init_log_level = log_level
         end : Shared_config)
     | Some filename, None ->
         let filename = filename ^ ".log" in
         shared_config ~time_tagged ~elapsed_times ~location_format ~print_entry_ids
           ~global_prefix ?split_files_after ~with_table_of_contents ~toc_entry ~for_append
-          filename
+          ~log_level filename
     | Some _, Some _ ->
         invalid_arg
           "Minidebug_runtime.debug_flushing: only one of debug_ch, filename should be \
            provided"
   in
   let module Debug = Flushing ((val log_to)) in
-  Debug.log_level := log_level;
   (module Debug)
 
 let forget_printbox (module Runtime : PrintBox_runtime) = (module Runtime : Debug_runtime)

diff --git a/minidebug_runtime.mli b/minidebug_runtime.mli
@@ -36,6 +36,7 @@ module type Shared_config = sig
   val split_files_after : int option
   val toc_entry : toc_entry_criteria
   val description : string
+  val init_log_level : int
 end
 
 val shared_config :
@@ -49,6 +50,7 @@ val shared_config :
   ?with_table_of_contents:bool ->
   ?toc_entry:toc_entry_criteria ->
   ?for_append:bool ->
+  ?log_level:int ->
   string ->
   (module Shared_config)
 (** Sets up a file with the given path, or if [split_files_after] is given, creates a
@@ -78,7 +80,9 @@ val shared_config :
     anchors of the log headers. Note that debug runtime builders that take a channel
     instead of a file name, will use [global_prefix] instead for the anchor links. The
     setting [toc_entry] controls the selection of headers to include in a ToC (it defaults
-    to [And []], which means including all entries). *)
+    to [And []], which means including all entries).
+    
+    [log_level], is provided, specifies {!Shared_config.init_log_level}.  *)
 
 (** When using the
     {{:http://lukstafi.github.io/ppx_minidebug/ppx_minidebug/Minidebug_runtime/index.html}

diff --git a/test/test_expect_test.ml b/test/test_expect_test.ml
@@ -2623,8 +2623,6 @@ let%expect_test "%log runtime log levels while-loop" =
     │   └─(INFO: 3 j= 21)
     └─result = 21
     21
-
-    BEGIN DEBUG SESSION Nothing
     21
 
     BEGIN DEBUG SESSION Error
@@ -3964,8 +3962,7 @@ let%expect_test "%track_rt_show expression runtime passing" =
     t2 test B begin
      "line B"
     t2 test B end
-
-    BEGIN DEBUG SESSION t3 |}]
+    |}]
 
 let%expect_test "%debug_show tuples values_first_mode highlighted" =
   let module Debug_runtime =
@@ -4140,8 +4137,6 @@ let%expect_test "%logN_block runtime log levels" =
     │     └─(INFO: 3 j= 21)
     └─result = 21
     21
-
-    BEGIN DEBUG SESSION for=1,with=0
     0
 
     BEGIN DEBUG SESSION for=2,with=1