From 4ae949f7f8b62f5663ea1dd7e8aad0d543d5c66c Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 7 Jul 2023 14:48:53 +0200 Subject: [PATCH] Fix formatting of exception trees --- compiler/catala_utils/pos.ml | 17 ++------------ compiler/catala_utils/string.ml | 12 ++++++++++ compiler/catala_utils/string.mli | 5 ++++ compiler/desugared/print.ml | 40 +++++++++++++++++--------------- 4 files changed, 40 insertions(+), 34 deletions(-) diff --git a/compiler/catala_utils/pos.ml b/compiler/catala_utils/pos.ml index f928da0e..8ab5da48 100644 --- a/compiler/catala_utils/pos.ml +++ b/compiler/catala_utils/pos.ml @@ -113,19 +113,6 @@ let string_repeat n s = done; Bytes.to_string buf -(* Note: this should do, but remains incorrect for combined unicode characters - that display as one (e.g. `e` + postfix `'`). We should switch to Uuseg at - some poing *) -let string_columns s = - let len = String.length s in - let rec aux ncols i = - if i >= len then ncols - else if s.[i] = '\t' then aux (ncols + 8) (i + 1) - else - aux (ncols + 1) (i + Uchar.utf_decode_length (String.get_utf_8_uchar s i)) - in - aux 0 0 - let utf8_byte_index s ui0 = let rec aux bi ui = if ui >= ui0 then bi @@ -200,8 +187,8 @@ let format_loc_text ppf (pos : t) = String.sub line match_start_index (max 0 (match_end_index - match_start_index)) in - let match_start_col = string_columns unmatched_prefix in - let match_num_cols = string_columns matched_substring in + let match_start_col = String.width unmatched_prefix in + let match_num_cols = String.width matched_substring in Format.fprintf ppf "@{%*d │@} %s@," nspaces line_no line; if line_no >= sline && line_no <= eline then Format.fprintf ppf "@{%s │@} %s@{%s@}" diff --git a/compiler/catala_utils/string.ml b/compiler/catala_utils/string.ml index 02ea9f29..717e588b 100644 --- a/compiler/catala_utils/string.ml +++ b/compiler/catala_utils/string.ml @@ -56,5 +56,17 @@ let remove_prefix ~prefix s = let format_t = Format.pp_print_string +(* Note: this should do, but remains incorrect for combined unicode characters + that display as one (e.g. `e` + postfix `'`). We should switch to Uuseg at + some poing *) +let width s = + let len = length s in + let rec aux ncols i = + if i >= len then ncols + else if get s i = '\t' then aux (ncols + 8) (i + 1) + else aux (ncols + 1) (i + Uchar.utf_decode_length (get_utf_8_uchar s i)) + in + aux 0 0 + module Set = Set.Make (Stdlib.String) module Map = Map.Make (Stdlib.String) diff --git a/compiler/catala_utils/string.mli b/compiler/catala_utils/string.mli index de785f37..ffa2f3fc 100644 --- a/compiler/catala_utils/string.mli +++ b/compiler/catala_utils/string.mli @@ -46,3 +46,8 @@ val remove_prefix : prefix:string -> string -> string - otherwise, [str] unchanged *) val format_t : Format.formatter -> string -> unit + +val width : string -> int +(** Returns the width of a given string in screen columns (assuming a monospace + font). Useful for alignment. This takes unicode (except composite chars) and + tabs into account, but not escape sequences. *) diff --git a/compiler/desugared/print.ml b/compiler/desugared/print.ml index 6f608b39..ac3548e2 100644 --- a/compiler/desugared/print.ml +++ b/compiler/desugared/print.ml @@ -25,40 +25,42 @@ open Format (* Original credits for this printing code: Jean-Christophe Filiâtre *) let format_exception_tree (fmt : Format.formatter) (t : exception_tree) = - let blue fmt s = Format.fprintf fmt "@{%s@}" s in - let rec print_node pref (t : exception_tree) = + let blue fmt n s = + Format.fprintf fmt "@{%a@}" (fun fmt -> Format.pp_print_as fmt n) s + in + let rec print_node pref prefsz (t : exception_tree) = let label, sons = match t with | Leaf l -> l.Dependency.ExceptionVertex.label, [] | Node (sons, l) -> l.Dependency.ExceptionVertex.label, sons in Format.fprintf fmt "@{\"%a\"@}" LabelName.format_t label; - let w = String.length (fst (LabelName.get_info label)) + 2 in + let w = String.width (fst (LabelName.get_info label)) + 2 in if sons != [] then - let pref' = pref ^ String.make (w + 1) ' ' in + let pref', prefsz' = pref ^ String.make (w + 1) ' ', prefsz + w + 2 in match sons with | [t'] -> - blue fmt "───"; - print_node (pref' ^ " ") t' + blue fmt 3 "───"; + print_node (pref' ^ " ") (prefsz' + 1) t' | _ -> - blue fmt "──"; - print_sons pref' "─┬──" sons - and print_sons pref start = function + blue fmt 1 "─"; + print_sons pref' prefsz' "─┬──" sons + and print_sons pref prefsz start = function | [] -> assert false | [s] -> - blue fmt " └──"; - print_node (pref ^ " ") s + blue fmt 4 " └──"; + print_node (pref ^ " ") (prefsz + 1) s | s :: sons -> - blue fmt start; - print_node (pref ^ "| ") s; + blue fmt 4 start; + print_node (pref ^ "| ") (prefsz + 2) s; pp_print_cut fmt (); - blue fmt (pref ^ " │"); + blue fmt (prefsz + 2) (pref ^ " │"); pp_print_cut fmt (); - blue fmt pref; - print_sons pref " ├──" sons + blue fmt prefsz pref; + print_sons pref prefsz " ├──" sons in Format.pp_open_vbox fmt 0; - print_node "" t; + print_node "" 0 t; Format.pp_close_box fmt () let build_exception_tree exc_graph = @@ -97,8 +99,8 @@ let print_exceptions_graph (RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules)) g; let tree = build_exception_tree g in - Message.emit_result "The exception tree structure is as follows:\n\n%a" + Message.emit_result "@[The exception tree structure is as follows:@,@,%a@]" (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,@,") (fun fmt tree -> format_exception_tree fmt tree)) tree