Add stacktraces to the html debug output (#2567)

lib/Fmt.ml

@@ -88,13 +88,15 @@ let with_box_debug k = with_pp (Box_debug.with_box (fun fs -> eval fs k))
 (** Break hints and format strings --------------------------------------*)
 
 let break n o =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.break fs n o ;
+      Box_debug.break fs n o ~stack ;
       Format_.pp_print_break fs n o )
 
 let force_break = break 1000 0
 
 let space_break =
+  (* a stack is useless here, this would require adding a unit parameter *)
   with_pp (fun fs ->
       Box_debug.space_break fs ;
       Format_.pp_print_space fs () )
@@ -105,13 +107,15 @@ let cut_break =
       Format_.pp_print_cut fs () )
 
 let force_newline =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.force_newline fs ;
+      Box_debug.force_newline ~stack fs ;
       Format_.pp_force_newline fs () )
 
 let cbreak ~fits ~breaks =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.cbreak fs ~fits ~breaks ;
+      Box_debug.cbreak fs ~stack ~fits ~breaks ;
       Format_.pp_print_custom_break fs ~fits ~breaks )
 
 let noop = with_pp (fun _ -> ())
@@ -136,7 +140,12 @@ let char c = with_pp (fun fs -> Format_.pp_print_char fs c)
 let utf8_length s =
   Uuseg_string.fold_utf_8 `Grapheme_cluster (fun n _ -> n + 1) 0 s
 
-let str_as n s = with_pp (fun fs -> Format_.pp_print_as fs n s)
+let str_as n s =
+  let stack = Box_debug.get_stack () in
+  with_pp (fun fs ->
+      Box_debug.start_str fs ;
+      Format_.pp_print_as fs n s ;
+      Box_debug.end_str ~stack fs )
 
 let str s = if String.is_empty s then noop else str_as (utf8_length s) s
 
@@ -186,22 +195,25 @@ let fmt_opt o = Option.value o ~default:noop
 (** Conditional on immediately following a line break -------------------*)
 
 let if_newline s =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.if_newline fs s ;
+      Box_debug.if_newline fs ~stack s ;
       Format_.pp_print_string_if_newline fs s )
 
 let break_unless_newline n o =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.break_unless_newline fs n o ;
+      Box_debug.break_unless_newline fs ~stack n o ;
       Format_.pp_print_or_newline fs n o "" "" )
 
 (** Conditional on breaking of enclosing box ----------------------------*)
 
 type behavior = Fit | Break
 
 let fits_or_breaks ~level fits nspaces offset breaks =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.fits_or_breaks fs fits nspaces offset breaks ;
+      Box_debug.fits_or_breaks fs ~stack fits nspaces offset breaks ;
       Format_.pp_print_fits_or_breaks fs ~level fits nspaces offset breaks )
 
 let fits_breaks ?force ?(hint = (0, Int.min_value)) ?(level = 0) fits breaks
@@ -245,27 +257,31 @@ let wrap_fits_breaks ?(space = true) conf x =
 let apply_max_indent n = Option.value_map !max_indent ~f:(min n) ~default:n
 
 let open_box ?name n =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
       let n = apply_max_indent n in
-      Box_debug.box_open ?name "b" n fs ;
+      Box_debug.box_open ~stack ?name "b" n fs ;
       Format_.pp_open_box fs n )
 
 and open_vbox ?name n =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
       let n = apply_max_indent n in
-      Box_debug.box_open ?name "v" n fs ;
+      Box_debug.box_open ~stack ?name "v" n fs ;
       Format_.pp_open_vbox fs n )
 
 and open_hvbox ?name n =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
       let n = apply_max_indent n in
-      Box_debug.box_open ?name "hv" n fs ;
+      Box_debug.box_open ~stack ?name "hv" n fs ;
       Format_.pp_open_hvbox fs n )
 
 and open_hovbox ?name n =
+  let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
       let n = apply_max_indent n in
-      Box_debug.box_open ?name "hov" n fs ;
+      Box_debug.box_open ~stack ?name "hov" n fs ;
       Format_.pp_open_hovbox fs n )
 
 and close_box =

lib/Translation_unit.ml

@@ -233,6 +233,7 @@ let check_comments (conf : Conf.t) cmts ~old:t_old ~new_:t_new =
 let format (type ext std) (ext_fg : ext Extended_ast.t)
     (std_fg : std Std_ast.t) ?output_file ~input_name ~prev_source
     ~ext_parsed ~std_parsed (conf : Conf.t) =
+  Box_debug.enable_stacktraces := conf.opr_opts.debug.v ;
   let dump_ast fg ~suffix ast =
     if conf.opr_opts.debug.v then
       Some

lib/box_debug.ml

@@ -44,22 +44,32 @@ let css =
   }
   .tooltiptext {
     visibility: hidden;
-    width: 120px;
+    width: min-content;
+    white-space: pre;
     background-color: black;
     color: #fff;
-    text-align: center;
-    padding: 5px 0;
+    text-align: left;
+    padding: 5px 5px;
     border-radius: 6px;
     position: absolute;
     z-index: 1;
+    font-size: 10px;
   }
-  .break:hover .tooltiptext {
+
+  div:hover>.tooltiptext, span:hover>.tooltiptext {
     visibility: visible;
   }
 |}
 
 let debug = ref false
 
+let enable_stacktraces = ref false
+
+let get_stack () =
+  if !enable_stacktraces then
+    Stdlib.Printexc.(30 |> get_callstack |> raw_backtrace_to_string)
+  else ""
+
 let fprintf_as_0 fs fmt = Format_.kasprintf (Format_.pp_print_as fs 0) fmt
 
 let debugf fs fmt =
@@ -93,25 +103,38 @@ let pp_box_name fs = function
 
 let pp_box_indent fs = function 0 -> () | i -> Format_.fprintf fs "(%d)" i
 
-let box_open ?name box_kind n fs =
-  debugf fs "<div class=\"box\"><p class=\"name\">%s%a%a</p>" box_kind
-    pp_box_name name pp_box_indent n
+let stack_tooltip fs stack =
+  match stack with
+  | Some stack -> debugf fs "<span class=\"tooltiptext\">%s</span>" stack
+  | None -> ()
+
+let box_open ?name ?stack box_kind n fs =
+  debugf fs "<div class=\"box\"><p class=\"name\"><span>%s%a%a</span>%a</p>"
+    box_kind pp_box_name name stack_tooltip stack pp_box_indent n
 
 let box_close fs = debugf fs "</div>"
 
-let break fs n o =
+let break fs n o ~stack =
   debugf fs
-    "<div class=\"break\">(%i,%i)<span class=\"tooltiptext\">break %i \
-     %i</span></div>"
-    n o n o
+    "<div class=\"break\">(%i,%i)<span class=\"tooltiptext\">break %i %i\n\
+     %s</span></div>"
+    n o n o stack
+
+let space_break ?stack fs =
+  debugf fs "<div class=\"break space_break\">space_break%a</div>"
+    stack_tooltip stack
+
+let cut_break ?stack fs =
+  debugf fs "<div class=\"break cut_break\">cut_break%a</div>" stack_tooltip
+    stack
 
-let space_break fs =
-  debugf fs "<div class=\"break space_break\">space_break</div>"
+let force_newline ?stack fs =
+  debugf fs "<div class=\"break force_newline\">force_newline%a</div>"
+    stack_tooltip stack
 
-let cut_break fs = debugf fs "<div class=\"break cut_break\">cut_break</div>"
+let start_str fs = debugf fs "<span class='string'>"
 
-let force_newline fs =
-  debugf fs "<div class=\"break force_newline\">force_newline</div>"
+let end_str ?stack fs = debugf fs "%a</span>" stack_tooltip stack
 
 let pp_keyword fs s = fprintf_as_0 fs "<span class=\"keyword\">%s</span>" s
 
@@ -153,27 +176,30 @@ let fmt fs f =
     _format_string fs fmt ; true )
   else false
 
-let cbreak fs ~fits:(s1, i, s2) ~breaks:(s3, j, s4) =
+let cbreak fs ~stack ~fits:(s1, i, s2) ~breaks:(s3, j, s4) =
   debugf fs
     "<div class=\"break cbreak\">(%s,%i,%s) (%s,%i,%s)<span \
-     class=\"tooltiptext\">cbreak ~fits:(%S, %i, %S) ~breaks:(%S, %i, \
-     %S)</span></div>"
-    s1 i s2 s3 j s4 s1 i s2 s3 j s4
+     class=\"tooltiptext\">cbreak ~fits:(%S, %i, %S) ~breaks:(%S, %i, %S)\n\
+     %s</span></div>"
+    s1 i s2 s3 j s4 s1 i s2 s3 j s4 stack
 
-let if_newline fs s =
+let if_newline fs ~stack s =
   debugf fs
     "<div class=\"break if_newline\">(%s)<span \
-     class=\"tooltiptext\">if_newline %S</span></div>"
-    s s
+     class=\"tooltiptext\">if_newline %S\n\
+     %s</span></div>"
+    s s stack
 
-let break_unless_newline fs n o =
+let break_unless_newline fs ~stack n o =
   debugf fs
     "<div class=\"break break_unless_newline\">(%i,%i)<span \
-     class=\"tooltiptext\">break_unless_newline %i %i</span></div>"
-    n o n o
+     class=\"tooltiptext\">break_unless_newline %i %i\n\
+     %s</span></div>"
+    n o n o stack
 
-let fits_or_breaks fs fits n o breaks =
+let fits_or_breaks fs ~stack fits n o breaks =
   debugf fs
     "<div class=\"break fits_or_breaks\">(%s,%i,%i,%s)<span \
-     class=\"tooltiptext\">fits_or_breaks %S %i %i %S</span></div>"
-    fits n o breaks fits n o breaks
+     class=\"tooltiptext\">fits_or_breaks %S %i %i %S\n\
+     %s</span></div>"
+    fits n o breaks fits n o breaks stack