CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Print exception tree

Browse Source
This commit is contained in:
Denis Merigoux 2023-04-07 16:35:09 +02:00
parent 2afb6fc20c
commit 6479c3c10b
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
7 changed files with 174 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
compiler/desugared/dependency.ml
View File

@ -244,10 +244,14 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
(** {2 Graph declaration} *)
module ExceptionVertex = struct
include RuleName.Set
type t = { rules : Pos.t RuleName.Map.t; label : LabelName.t }
let compare x y = RuleName.Map.compare compare x.rules y.rules
let hash (x : t) : int =
RuleName.Set.fold (fun r acc -> Int.logxor (RuleName.hash r) acc) x 0
RuleName.Map.fold
(fun r _ acc -> Int.logxor (RuleName.hash r) acc)
x.rules 0
let equal x y = compare x y = 0
end
@ -353,9 +357,19 @@ let build_exceptions_graph
in
LabelName.Map.update label_of_rule
(fun rule_set ->
let pos =
(* We have to overwrite the law info on tis position because the
pass at the surface AST level that fills the law info on
positions only does it for positions inside expressions, the
visitor in [surface/fill_positions.ml] does not go into the
info of [RuleName.t], etc.*)
Pos.overwrite_law_info
(snd (RuleName.get_info rule.rule_id))
(Pos.get_law_info (Expr.pos rule.rule_just))
in
match rule_set with
| None -> Some (RuleName.Set.singleton rule_name)
| Some rule_set -> Some (RuleName.Set.add rule_name rule_set))
| None -> Some (RuleName.Map.singleton rule_name pos)
| Some rule_set -> Some (RuleName.Map.add rule_name pos rule_set))
rule_sets)
def LabelName.Map.empty
in
@ -363,7 +377,7 @@ let build_exceptions_graph
fst
(LabelName.Map.choose
(LabelName.Map.filter
(fun _ rule_set -> RuleName.Set.mem r rule_set)
(fun _ rule_set -> RuleName.Map.mem r rule_set)
label_to_rule_sets))
in
(* Next, we collect the exception edges between those groups of rules referred
@ -431,7 +445,8 @@ let build_exceptions_graph
(* We've got the vertices and the edges, let's build the graph! *)
let g =
LabelName.Map.fold
(fun _label rule_set g -> ExceptionsDependencies.add_vertex g rule_set)
(fun label rule_set g ->
ExceptionsDependencies.add_vertex g { rules = rule_set; label })
label_to_rule_sets ExceptionsDependencies.empty
in
(* then we add the edges *)
@ -439,10 +454,18 @@ let build_exceptions_graph
List.fold_left
(fun g edge ->
let rule_group_from =
LabelName.Map.find edge.label_from label_to_rule_sets
{
ExceptionVertex.rules =
LabelName.Map.find edge.label_from label_to_rule_sets;
label = edge.label_from;
}
in
let rule_group_to =
LabelName.Map.find edge.label_to label_to_rule_sets
{
ExceptionVertex.rules =
LabelName.Map.find edge.label_to label_to_rule_sets;
label = edge.label_to;
}
in
let edge =
ExceptionsDependencies.E.create rule_group_from edge.edge_positions
@ -464,14 +487,14 @@ let check_for_exception_cycle
let scc = List.find (fun scc -> List.length scc > 1) sccs in
let spans =
List.rev_map
(fun (vs : RuleName.Set.t) ->
let v = RuleName.Set.choose vs in
(fun (vs : ExceptionVertex.t) ->
let v, _ = RuleName.Map.choose vs.rules in
let rule = RuleName.Map.find v def in
let pos = Marked.get_mark (RuleName.get_info rule.Ast.rule_id) in
None, pos)
scc
in
let v = RuleName.Set.choose (List.hd scc) in
let v, _ = RuleName.Map.choose (List.hd scc).rules in
Errors.raise_multispanned_error spans
"Exception cycle detected when defining %a: each of these %d exceptions \
applies over the previous one, and the first applies over the last"

8
compiler/desugared/dependency.mli
View File

@ -72,8 +72,14 @@ val build_scope_dependencies : Ast.scope -> ScopeDependencies.t
module EdgeExceptions : Graph.Sig.ORDERED_TYPE_DFT with type t = Pos.t list
module ExceptionVertex : sig
type t = { rules : Pos.t RuleName.Map.t; label : LabelName.t }
end
module ExceptionsDependencies :
Graph.Sig.P with type V.t = RuleName.Set.t and type E.label = EdgeExceptions.t
Graph.Sig.P
with type V.t = ExceptionVertex.t
and type E.label = EdgeExceptions.t
val build_exceptions_graph :
Ast.rule RuleName.Map.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t

95
compiler/desugared/print.ml
View File

@ -15,8 +15,101 @@
the License. *)
open Shared_ast
open Catala_utils
type exception_tree =
| Leaf of Dependency.ExceptionVertex.t
| Node of exception_tree list * Dependency.ExceptionVertex.t
open Format
(* Credits for this printing code: Jean-Christophe Filiâtre, *)
let format_exception_tree (fmt : Format.formatter) (t : exception_tree) =
let blue s =
Format.asprintf "%a" (Cli.format_with_style [ANSITerminal.blue]) s
in
let rec print_node pref (t : exception_tree) =
let (s, w), sons =
let print_s s =
( Format.asprintf "%a"
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" LabelName.format_t
s.Dependency.ExceptionVertex.label),
String.length
(Format.asprintf "\"%a\"" LabelName.format_t
s.Dependency.ExceptionVertex.label) )
in
match t with Leaf s -> print_s s, [] | Node (sons, s) -> print_s s, sons
in
pp_print_string fmt s;
if sons != [] then
let pref' = pref ^ String.make (w + 1) ' ' in
match sons with
| [t'] ->
pp_print_string fmt (blue "───");
print_node (pref' ^ " ") t'
| _ ->
pp_print_string fmt (blue "──");
print_sons pref' "┬──" sons
and print_sons pref start = function
| [] -> assert false
| [s] ->
pp_print_string fmt (blue " └──");
print_node (pref ^ " ") s
| s :: sons ->
pp_print_string fmt (blue start);
print_node (pref ^ "| ") s;
pp_force_newline fmt ();
pp_print_string fmt (blue pref);
print_sons pref "├──" sons
in
print_node "" t
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 : DesugaredVarName.t)
(g : Dependency.ExceptionsDependencies.t) =
assert false
Cli.result_format
"Printing the tree of exceptions for the definitions of variable %a of \
scope %a."
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" DesugaredVarName.format var)
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" ScopeName.format_t scope);
Dependency.ExceptionsDependencies.iter_vertex
(fun ex ->
Cli.result_format "Group of definitions with label %a:\n%a"
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" LabelName.format_t
ex.Dependency.ExceptionVertex.label)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(fun fmt (_, pos) ->
Format.fprintf fmt "%s" (Pos.retrieve_loc_text pos)))
(RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules))
g;
let tree = build_exception_tree g in
Cli.result_format "The exception tree structure is as follows:\n\n%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(fun fmt tree -> format_exception_tree fmt tree))
tree

5
compiler/desugared/print.mli
View File

@ -15,5 +15,8 @@
the License. *)
val print_exceptions_graph :
Shared_ast.DesugaredVarName.t -> Dependency.ExceptionsDependencies.t -> unit
Shared_ast.ScopeName.t ->
Shared_ast.DesugaredVarName.t ->
Dependency.ExceptionsDependencies.t ->
unit
(** Prints the exception graph of a variable to the terminal *)

44
compiler/driver.ml
View File

@ -165,9 +165,9 @@ let driver source_file (options : Cli.options) : int =
match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
| Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Errors.raise_error "There is no scope \"%a\" inside the program."
Errors.raise_error "There is no scope %a inside the program."
(Cli.format_with_style [ANSITerminal.yellow])
name)
("\"" ^ name ^ "\""))
in
(* This uid is a Desugared identifier *)
let variable_uid =
@ -201,24 +201,25 @@ let driver source_file (options : Cli.options) : int =
(Shared_ast.ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
with
| None ->
Errors.raise_error "Variable \"%a\" not found inside scope \"%a\""
Errors.raise_error "Variable %a not found inside scope %a"
(Cli.format_with_style [ANSITerminal.yellow])
name
("\"" ^ name ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "%a" Shared_ast.ScopeName.format_t scope_uid)
(Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t scope_uid)
| Some
(Desugared.Name_resolution.SubScope
(subscope_var_name, subscope_name)) -> (
match second_part with
| None ->
Errors.raise_error
"Subscope \"%a\" of scope \"%a\" cannot be selected by itself, \
please add \".<var>\" where <var> is a subscope variable."
"Subscope %a of scope %a cannot be selected by itself, please \
add \".<var>\" where <var> is a subscope variable."
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "%a" Shared_ast.SubScopeName.format_t
(Format.asprintf "\"%a\"" Shared_ast.SubScopeName.format_t
subscope_var_name)
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "%a" Shared_ast.ScopeName.format_t scope_uid)
(Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t
scope_uid)
| Some second_part -> (
match
Shared_ast.IdentName.Map.find_opt second_part
@ -230,16 +231,16 @@ let driver source_file (options : Cli.options) : int =
(Shared_ast.DesugaredVarName.SubScopeVar (subscope_var_name, v))
| _ ->
Errors.raise_error
"Var \"%a\" of subscope \"%a\" in scope \"%a\" does not \
exist, please check your command line arguments."
"Var %a of subscope %a in scope %a does not exist, please \
check your command line arguments."
(Cli.format_with_style [ANSITerminal.yellow])
second_part
("\"" ^ second_part ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "%a" Shared_ast.SubScopeName.format_t
(Format.asprintf "\"%a\"" Shared_ast.SubScopeName.format_t
subscope_var_name)
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "%a" Shared_ast.ScopeName.format_t scope_uid)
))
(Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t
scope_uid)))
| Some (Desugared.Name_resolution.ScopeVar v) ->
Some
(Shared_ast.DesugaredVarName.ScopeVar
@ -256,15 +257,14 @@ let driver source_file (options : Cli.options) : int =
| Some state -> state
| None ->
Errors.raise_error
"State \"%a\" is not found for variable \"%a\" of \
scope \"%a\""
"State %a is not found for variable %a of scope %a"
(Cli.format_with_style [ANSITerminal.yellow])
second_part
("\"" ^ second_part ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
first_part
("\"" ^ first_part ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "%a" Shared_ast.ScopeName.format_t
scope_uid))
(Format.asprintf "\"%a\""
Shared_ast.ScopeName.format_t scope_uid))
second_part )))
in
Cli.debug_print "Desugaring...";
@ -286,7 +286,7 @@ let driver source_file (options : Cli.options) : int =
Errors.raise_error
"Please provide a scope variable to analyze with the -v option."
in
Desugared.Print.print_exceptions_graph variable_uid
Desugared.Print.print_exceptions_graph scope_uid variable_uid
(Shared_ast.DesugaredVarName.Map.find variable_uid exceptions_graphs)
| `Scopelang ->
let _output_file, with_output = get_output_format () in

7
compiler/scopelang/from_desugared.ml
View File

@ -195,14 +195,15 @@ let def_map_to_tree
else base_cases)
exc_graph []
in
let rec build_tree (base_cases : RuleName.Set.t) : rule_tree =
let rec build_tree (base_cases : Desugared.Dependency.ExceptionVertex.t) :
rule_tree =
let exceptions =
Desugared.Dependency.ExceptionsDependencies.pred exc_graph base_cases
in
let base_case_as_rule_list =
List.map
(fun r -> RuleName.Map.find r def)
(RuleName.Set.elements base_cases)
(fun (r, _) -> RuleName.Map.find r def)
(RuleName.Map.bindings base_cases.rules)
in
match exceptions with
| [] -> Leaf base_case_as_rule_list

9
compiler/shared_ast/definitions.ml
View File

@ -53,6 +53,7 @@ module DesugaredVarName : sig
val hash : t -> int
val compare : t -> t -> int
val equal : t -> t -> bool
val format : Format.formatter -> t -> unit
module Map : Map.S with type key = t
module Set : Set.S with type elt = t
@ -91,6 +92,14 @@ end = struct
| SubScopeVar (x, xv), SubScopeVar (y, yv) ->
SubScopeName.equal x y && ScopeVar.equal xv yv
| (ScopeVar _ | SubScopeVar _), _ -> false
let format fmt x =
match x with
| ScopeVar (v, None) -> ScopeVar.format_t fmt v
| ScopeVar (v, Some st) ->
Format.fprintf fmt "%a.%a" ScopeVar.format_t v StateName.format_t st
| SubScopeVar (ss, v) ->
Format.fprintf fmt "%a.%a" SubScopeName.format_t ss ScopeVar.format_t v
end
include Ordering