mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-19 16:28:12 +03:00
Fix formatting of exception trees
This commit is contained in:
parent
b63e7d2f2d
commit
4ae949f7f8
@ -113,19 +113,6 @@ let string_repeat n s =
|
|||||||
done;
|
done;
|
||||||
Bytes.to_string buf
|
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 utf8_byte_index s ui0 =
|
||||||
let rec aux bi ui =
|
let rec aux bi ui =
|
||||||
if ui >= ui0 then bi
|
if ui >= ui0 then bi
|
||||||
@ -200,8 +187,8 @@ let format_loc_text ppf (pos : t) =
|
|||||||
String.sub line match_start_index
|
String.sub line match_start_index
|
||||||
(max 0 (match_end_index - match_start_index))
|
(max 0 (match_end_index - match_start_index))
|
||||||
in
|
in
|
||||||
let match_start_col = string_columns unmatched_prefix in
|
let match_start_col = String.width unmatched_prefix in
|
||||||
let match_num_cols = string_columns matched_substring in
|
let match_num_cols = String.width matched_substring in
|
||||||
Format.fprintf ppf "@{<bold;blue>%*d │@} %s@," nspaces line_no line;
|
Format.fprintf ppf "@{<bold;blue>%*d │@} %s@," nspaces line_no line;
|
||||||
if line_no >= sline && line_no <= eline then
|
if line_no >= sline && line_no <= eline then
|
||||||
Format.fprintf ppf "@{<bold;blue>%s │@} %s@{<bold;red>%s@}"
|
Format.fprintf ppf "@{<bold;blue>%s │@} %s@{<bold;red>%s@}"
|
||||||
|
@ -56,5 +56,17 @@ let remove_prefix ~prefix s =
|
|||||||
|
|
||||||
let format_t = Format.pp_print_string
|
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 Set = Set.Make (Stdlib.String)
|
||||||
module Map = Map.Make (Stdlib.String)
|
module Map = Map.Make (Stdlib.String)
|
||||||
|
@ -46,3 +46,8 @@ val remove_prefix : prefix:string -> string -> string
|
|||||||
- otherwise, [str] unchanged *)
|
- otherwise, [str] unchanged *)
|
||||||
|
|
||||||
val format_t : Format.formatter -> string -> unit
|
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. *)
|
||||||
|
@ -25,40 +25,42 @@ open Format
|
|||||||
|
|
||||||
(* Original credits for this printing code: Jean-Christophe Filiâtre *)
|
(* Original credits for this printing code: Jean-Christophe Filiâtre *)
|
||||||
let format_exception_tree (fmt : Format.formatter) (t : exception_tree) =
|
let format_exception_tree (fmt : Format.formatter) (t : exception_tree) =
|
||||||
let blue fmt s = Format.fprintf fmt "@{<blue>%s@}" s in
|
let blue fmt n s =
|
||||||
let rec print_node pref (t : exception_tree) =
|
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 =
|
let label, sons =
|
||||||
match t with
|
match t with
|
||||||
| Leaf l -> l.Dependency.ExceptionVertex.label, []
|
| Leaf l -> l.Dependency.ExceptionVertex.label, []
|
||||||
| Node (sons, l) -> l.Dependency.ExceptionVertex.label, sons
|
| Node (sons, l) -> l.Dependency.ExceptionVertex.label, sons
|
||||||
in
|
in
|
||||||
Format.fprintf fmt "@{<yellow>\"%a\"@}" LabelName.format_t label;
|
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
|
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
|
match sons with
|
||||||
| [t'] ->
|
| [t'] ->
|
||||||
blue fmt "───";
|
blue fmt 3 "───";
|
||||||
print_node (pref' ^ " ") t'
|
print_node (pref' ^ " ") (prefsz' + 1) t'
|
||||||
| _ ->
|
| _ ->
|
||||||
blue fmt "──";
|
blue fmt 1 "─";
|
||||||
print_sons pref' "─┬──" sons
|
print_sons pref' prefsz' "─┬──" sons
|
||||||
and print_sons pref start = function
|
and print_sons pref prefsz start = function
|
||||||
| [] -> assert false
|
| [] -> assert false
|
||||||
| [s] ->
|
| [s] ->
|
||||||
blue fmt " └──";
|
blue fmt 4 " └──";
|
||||||
print_node (pref ^ " ") s
|
print_node (pref ^ " ") (prefsz + 1) s
|
||||||
| s :: sons ->
|
| s :: sons ->
|
||||||
blue fmt start;
|
blue fmt 4 start;
|
||||||
print_node (pref ^ "| ") s;
|
print_node (pref ^ "| ") (prefsz + 2) s;
|
||||||
pp_print_cut fmt ();
|
pp_print_cut fmt ();
|
||||||
blue fmt (pref ^ " │");
|
blue fmt (prefsz + 2) (pref ^ " │");
|
||||||
pp_print_cut fmt ();
|
pp_print_cut fmt ();
|
||||||
blue fmt pref;
|
blue fmt prefsz pref;
|
||||||
print_sons pref " ├──" sons
|
print_sons pref prefsz " ├──" sons
|
||||||
in
|
in
|
||||||
Format.pp_open_vbox fmt 0;
|
Format.pp_open_vbox fmt 0;
|
||||||
print_node "" t;
|
print_node "" 0 t;
|
||||||
Format.pp_close_box fmt ()
|
Format.pp_close_box fmt ()
|
||||||
|
|
||||||
let build_exception_tree exc_graph =
|
let build_exception_tree exc_graph =
|
||||||
@ -97,8 +99,8 @@ let print_exceptions_graph
|
|||||||
(RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules))
|
(RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules))
|
||||||
g;
|
g;
|
||||||
let tree = build_exception_tree g in
|
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
|
(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))
|
(fun fmt tree -> format_exception_tree fmt tree))
|
||||||
tree
|
tree
|
||||||
|
Loading…
Reference in New Issue
Block a user