From 6aaac03326e014e9b61391734ce7c09d679bb194 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 10 Oct 2024 17:14:04 +0200 Subject: [PATCH] Add stacktraces to the html debug output (#2567) --- lib/Fmt.ml | 38 +++++++++++++------ lib/Translation_unit.ml | 1 + lib/box_debug.ml | 84 +++++++++++++++++++++++++++-------------- 3 files changed, 83 insertions(+), 40 deletions(-) diff --git a/lib/Fmt.ml b/lib/Fmt.ml index f84eb67acf..2fb707203b 100644 --- a/lib/Fmt.ml +++ b/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,13 +195,15 @@ 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 ----------------------------*) @@ -200,8 +211,9 @@ let break_unless_newline n o = 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 = diff --git a/lib/Translation_unit.ml b/lib/Translation_unit.ml index b8ae74aee0..0b92c36dca 100644 --- a/lib/Translation_unit.ml +++ b/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 diff --git a/lib/box_debug.ml b/lib/box_debug.ml index 819f87dcd2..a2af7e73ab 100644 --- a/lib/box_debug.ml +++ b/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 "

%s%a%a

" box_kind - pp_box_name name pp_box_indent n +let stack_tooltip fs stack = + match stack with + | Some stack -> debugf fs "%s" stack + | None -> () + +let box_open ?name ?stack box_kind n fs = + debugf fs "

%s%a%a%a

" + box_kind pp_box_name name stack_tooltip stack pp_box_indent n let box_close fs = debugf fs "
" -let break fs n o = +let break fs n o ~stack = debugf fs - "
(%i,%i)break %i \ - %i
" - n o n o + "
(%i,%i)break %i %i\n\ + %s
" + n o n o stack + +let space_break ?stack fs = + debugf fs "
space_break%a
" + stack_tooltip stack + +let cut_break ?stack fs = + debugf fs "
cut_break%a
" stack_tooltip + stack -let space_break fs = - debugf fs "
space_break
" +let force_newline ?stack fs = + debugf fs "
force_newline%a
" + stack_tooltip stack -let cut_break fs = debugf fs "
cut_break
" +let start_str fs = debugf fs "" -let force_newline fs = - debugf fs "
force_newline
" +let end_str ?stack fs = debugf fs "%a" stack_tooltip stack let pp_keyword fs s = fprintf_as_0 fs "%s" 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 "
(%s,%i,%s) (%s,%i,%s)cbreak ~fits:(%S, %i, %S) ~breaks:(%S, %i, \ - %S)
" - 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
" + 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 "
(%s)if_newline %S
" - s s + class=\"tooltiptext\">if_newline %S\n\ + %s" + s s stack -let break_unless_newline fs n o = +let break_unless_newline fs ~stack n o = debugf fs "
(%i,%i)break_unless_newline %i %i
" - n o n o + class=\"tooltiptext\">break_unless_newline %i %i\n\ + %s" + 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 "
(%s,%i,%i,%s)fits_or_breaks %S %i %i %S
" - fits n o breaks fits n o breaks + class=\"tooltiptext\">fits_or_breaks %S %i %i %S\n\ + %s" + fits n o breaks fits n o breaks stack