Fix formatting of exception trees

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 "@{<bold;blue>%*d │@} %s@," nspaces line_no line;
         if line_no >= sline && line_no <= eline then
           Format.fprintf ppf "@{<bold;blue>%s │@} %s@{<bold;red>%s@}"

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)

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. *)

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 "@{<blue>%s@}" s in
-  let rec print_node pref (t : exception_tree) =
+  let blue fmt n s =
+    Format.fprintf fmt "@{<blue>%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 "@{<yellow>\"%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 "@[<v>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