Fix and properly test multifile logging for PrintBox

minidebug_runtime.ml

@@ -22,6 +22,15 @@ end
 let debug_ch ?(time_tagged = false) ?max_nesting_depth ?max_num_children
     ?split_files_after ?(for_append = true) filename : (module Debug_ch) =
   let module Result = struct
+    let () =
+      match split_files_after with
+      | Some _ when not for_append ->
+          let dirname = Filename.remove_extension filename in
+          if not (Sys.file_exists dirname) then Sys.mkdir dirname 0o777;
+          Array.iter (fun file -> Sys.remove @@ Filename.concat dirname file)
+          @@ Sys.readdir dirname
+      | _ -> ()
+
     let find_ch () =
       match split_files_after with
       | None ->
@@ -31,9 +40,6 @@ let debug_ch ?(time_tagged = false) ?max_nesting_depth ?max_num_children
           let dirname = Filename.remove_extension filename in
           let suffix = Filename.extension filename in
           if not (Sys.file_exists dirname) then Sys.mkdir dirname 0o777;
-          if not for_append then
-            Array.iter (fun file -> Sys.remove @@ Filename.concat dirname file)
-            @@ Sys.readdir dirname;
           let rec find i =
             let fname = Filename.concat dirname @@ Int.to_string i in
             if
@@ -53,7 +59,9 @@ let debug_ch ?(time_tagged = false) ?max_nesting_depth ?max_num_children
     let refresh_ch () =
       match split_files_after with
       | None -> false
-      | Some split_after -> Out_channel.length !current_ch > Int64.of_int split_after
+      | Some split_after ->
+          Out_channel.flush !current_ch;
+          Int64.to_int (Out_channel.length !current_ch) > split_after
 
     let debug_ch () =
       if refresh_ch () then current_ch := find_ch ();
@@ -383,14 +391,15 @@ module PrintBox (Log_to : Debug_ch) = struct
       | [ { highlight = false; _ } ] when config.highlighted_roots -> []
       | [ ({ cond = true; _ } as entry) ] ->
           let box = stack_to_tree entry in
+          let ch = debug_ch () in
           (match config.backend with
-          | `Text -> PrintBox_text.output (debug_ch ()) box
-          | `Html config ->
-              output_string (debug_ch ()) @@ PrintBox_html.(to_string ~config box)
+          | `Text -> PrintBox_text.output ch box
+          | `Html config -> output_string ch @@ PrintBox_html.(to_string ~config box)
           | `Markdown config ->
-              output_string (debug_ch ())
+              output_string ch
               @@ PrintBox_md.(to_string Config.(foldable_trees config) box));
-          output_string (debug_ch ()) "\n";
+          output_string ch "\n";
+          Out_channel.flush ch;
           []
       | _ -> failwith "ppx_minidebug: close_log must follow an earlier open_log_preamble"
 

test/debugger_multifile_1.expected.md

@@ -0,0 +1,22 @@
+
+BEGIN DEBUG SESSION
+<details><summary><span style="font-family: monospace">foo = (7 8 16)</span></summary>
+
+- ["test/test_debug_multifile.ml":9:19-11:17](../test/test_debug_multifile.ml#L9)
+- <span style="font-family: monospace">x = 7</span>
+- <details><summary><span style="font-family: monospace">y = 8</span></summary>
+
+  - ["test/test_debug_multifile.ml":10:6](../test/test_debug_multifile.ml#L10)
+  </details>
+</details>
+
+<details><summary><span style="font-family: monospace">bar = 336</span></summary>
+
+- ["test/test_debug_multifile.ml":17:19-19:14](../test/test_debug_multifile.ml#L17)
+- <span style="font-family: monospace">x = ((first 7) (second 42))</span>
+- <details><summary><span style="font-family: monospace">y = 8</span></summary>
+
+  - ["test/test_debug_multifile.ml":18:6](../test/test_debug_multifile.ml#L18)
+  </details>
+</details>
+

test/debugger_multifile_2.expected.md

@@ -0,0 +1,14 @@
+<details><summary><span style="font-family: monospace">baz = 359</span></summary>
+
+- ["test/test_debug_multifile.ml":23:19-26:28](../test/test_debug_multifile.ml#L23)
+- <span style="font-family: monospace">x = ((first 7) (second 42))</span>
+- <details><summary><span style="font-family: monospace">_yz = (8 3)</span></summary>
+
+  - ["test/test_debug_multifile.ml":24:17](../test/test_debug_multifile.ml#L24)
+  </details>
+- <details><summary><span style="font-family: monospace">_uw = (7 13)</span></summary>
+
+  - ["test/test_debug_multifile.ml":25:17](../test/test_debug_multifile.ml#L25)
+  </details>
+</details>
+

test/dune

@@ -53,11 +53,13 @@
 
 (rule
  (target debugger_sexp_printbox.log)
- (action (run %{dep:test_debug_sexp.exe})))
+ (action
+  (run %{dep:test_debug_sexp.exe})))
 
 (rule
  (alias runtest)
- (action (diff debugger_sexp_printbox.expected.log debugger_sexp_printbox.log)))
+ (action
+  (diff debugger_sexp_printbox.expected.log debugger_sexp_printbox.log)))
 
 (executable
  (name test_debug_pp)
@@ -69,11 +71,13 @@
 
 (rule
  (target debugger_pp_format.log)
- (action (run %{dep:test_debug_pp.exe})))
+ (action
+  (run %{dep:test_debug_pp.exe})))
 
 (rule
  (alias runtest)
- (action (diff debugger_pp_format.expected.log debugger_pp_format.log)))
+ (action
+  (diff debugger_pp_format.expected.log debugger_pp_format.log)))
 
 (executable
  (name test_debug_show)
@@ -85,11 +89,13 @@
 
 (rule
  (target debugger_show_flushing.log)
- (action (run %{dep:test_debug_show.exe})))
+ (action
+  (run %{dep:test_debug_show.exe})))
 
 (rule
  (alias runtest)
- (action (diff debugger_show_flushing.expected.log debugger_show_flushing.log)))
+ (action
+  (diff debugger_show_flushing.expected.log debugger_show_flushing.log)))
 
 (executable
  (name test_debug_html)
@@ -107,7 +113,7 @@
  (preprocess
   (pps ppx_minidebug ppx_sexp_conv)))
 
-(test
+(executable
  (name test_debug_multifile)
  (modules test_debug_multifile)
  (libraries sexplib0 minidebug_runtime)
@@ -117,24 +123,52 @@
 
 (rule
  (target debugger_sexp_html.html)
- (action (run %{dep:test_debug_html.exe})))
+ (action
+  (run %{dep:test_debug_html.exe})))
 
 (rule
  (target debugger_sexp_md.md)
- (action (run %{dep:test_debug_md.exe})))
+ (action
+  (run %{dep:test_debug_md.exe})))
+
+(rule
+ (targets debugger_multifile_1.md debugger_multifile_2.md)
+ (enabled_if
+  (= %{system} linux))
+ (action
+  (progn
+   (run %{dep:test_debug_multifile.exe})
+   (system "cp -f debugger_multifile/1.md debugger_multifile_1.md")
+   (system "cp -f debugger_multifile/2.md debugger_multifile_2.md"))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff debugger_sexp_html.expected.html debugger_sexp_html.html)))
 
 (rule
  (alias runtest)
- (action (diff debugger_sexp_html.expected.html debugger_sexp_html.html)))
+ (action
+  (diff debugger_sexp_md.expected.md debugger_sexp_md.md)))
 
 (rule
  (alias runtest)
- (action (diff debugger_sexp_md.expected.md debugger_sexp_md.md)))
+ (enabled_if
+  (= %{system} linux))
+ (action
+  (diff debugger_multifile_1.expected.md debugger_multifile_1.md)))
+
+(rule
+ (alias runtest)
+ (enabled_if
+  (= %{system} linux))
+ (action
+  (diff debugger_multifile_2.expected.md debugger_multifile_2.md)))
 
 (library
  (name test_inline_tests)
  (inline_tests)
  (modules test_expect_test)
  (libraries minidebug_runtime str)
  (preprocess
-  (pps ppx_minidebug ppx_deriving.show ppx_expect)))
+  (pps ppx_minidebug ppx_deriving.show ppx_expect)))

test/test_debug_multifile.ml

@@ -1,9 +1,10 @@
 open Sexplib0.Sexp_conv
 
 module Debug_runtime =
-  (val Minidebug_runtime.debug_file ~hyperlink:"../" ~split_files_after:(1 lsl 8)
-         ~backend:(`Markdown PrintBox_md.Config.uniform) ~values_first_mode:true
-         "debugger_multifile")
+  (* Split as soon as possible. *)
+  (val Minidebug_runtime.debug_file ~hyperlink:"../" ~split_files_after:(1 lsl 9)
+         ~for_append:false ~backend:(`Markdown PrintBox_md.Config.uniform)
+         ~values_first_mode:true "debugger_multifile")
 
 let%debug_sexp foo (x : int) : int list =
   let y : int = x + 1 in