1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
open Shared_ast
open Catala_utils
type exception_tree =
| Leaf of Dependency.ExceptionVertex.t
| Node of exception_tree list * Dependency.ExceptionVertex.t
open Format
let format_exception_tree (fmt : Format.formatter) (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 "\"%a\"" LabelName.format label;
let w = String.width (fst (LabelName.get_info label)) + 2 in
if sons != [] then
let pref', prefsz' = pref ^ String.make (w + 1) ' ', prefsz + w + 2 in
match sons with
| [t'] ->
blue fmt 3 "───";
print_node (pref' ^ " ") (prefsz' + 1) t'
| _ ->
blue fmt 1 "─";
print_sons pref' prefsz' "─┬──" sons
and print_sons pref prefsz start = function
| [] -> assert false
| [s] ->
blue fmt 4 " └──";
print_node (pref ^ " ") (prefsz + 1) s
| s :: sons ->
blue fmt 4 start;
print_node (pref ^ "| ") (prefsz + 2) s;
pp_print_cut fmt ();
blue fmt (prefsz + 2) (pref ^ " │");
pp_print_cut fmt ();
blue fmt prefsz pref;
print_sons pref prefsz " ├──" sons
in
Format.pp_open_vbox fmt 0;
print_node "" 0 t;
Format.pp_close_box fmt ()
let build_exception_tree exc_graph =
let base_cases =
Dependency.ExceptionsDependencies.fold_vertex
(fun v base_cases ->
if Dependency.ExceptionsDependencies.out_degree exc_graph v = 0 then
v :: base_cases
else base_cases)
exc_graph []
in
let rec build_tree (base_cases : Dependency.ExceptionVertex.t) =
let exceptions =
Dependency.ExceptionsDependencies.pred exc_graph base_cases
in
match exceptions with
| [] -> Leaf base_cases
| _ -> Node (List.map build_tree exceptions, base_cases)
in
List.map build_tree base_cases
let print_exceptions_graph
(scope : ScopeName.t)
(var : Ast.ScopeDef.t)
(g : Dependency.ExceptionsDependencies.t) =
Message.result
"Printing the tree of exceptions for the definitions of variable \"%a\" of \
scope \"%a\"."
Ast.ScopeDef.format var ScopeName.format scope;
Dependency.ExceptionsDependencies.iter_vertex
(fun ex ->
Message.result "Definitions with label@ \"%a\":" LabelName.format
ex.Dependency.ExceptionVertex.label
~extra_pos:
(List.map
(fun p -> "", p)
(RuleName.Map.values ex.Dependency.ExceptionVertex.rules)))
g;
let tree = build_exception_tree g in
Message.result "@[<v>The exception tree structure is as follows:@,@,%a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,@,")
(fun fmt tree -> format_exception_tree fmt tree))
tree