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

Simplify visitors ppx annotations (#495)

Browse Source
This commit is contained in:
Louis Gesbert 2023-08-04 12:00:09 +02:00 committed by GitHub
commit 4cc3bd7e1d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 49 additions and 616 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

663
compiler/surface/ast.ml
View File

@ -31,49 +31,17 @@ open Catala_utils
(** {1 Type definitions} *)
type uident = (string[@opaque])
[@@deriving
visitors { variety = "map"; name = "uident_map"; nude = true },
visitors { variety = "iter"; name = "uident_iter"; nude = true }]
(** Constructors are CamelCase *)
type lident = (string[@opaque])
[@@deriving
visitors { variety = "map"; name = "lident_map"; nude = true },
visitors { variety = "iter"; name = "lident_iter"; nude = true }]
and lident = (string[@opaque])
(** Idents are snake_case *)
type path = uident Mark.pos list
[@@deriving
visitors
{
variety = "map";
ancestors = ["Mark.pos_map"; "uident_map"];
name = "path_map";
},
visitors
{
variety = "iter";
ancestors = ["Mark.pos_iter"; "uident_iter"];
name = "path_iter";
}]
and path = uident Mark.pos list
type scope_var = lident Mark.pos list
[@@deriving
visitors
{
variety = "map";
ancestors = ["Mark.pos_map"; "lident_map"];
name = "scope_var_map";
},
visitors
{
variety = "iter";
ancestors = ["Mark.pos_iter"; "lident_iter"];
name = "scope_var_iter";
}]
and scope_var = lident Mark.pos list
(** [foo.bar] in binding position: used to specify variables of subscopes *)
type primitive_typ =
and primitive_typ =
| Integer
| Decimal
| Boolean
@ -82,191 +50,47 @@ type primitive_typ =
| Text
| Date
| Named of path * uident Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["path_map"; "uident_map"];
name = "primitive_typ_map";
},
visitors
{
variety = "iter";
ancestors = ["path_iter"; "uident_iter"];
name = "primitive_typ_iter";
}]
type base_typ_data =
and base_typ_data =
| Primitive of primitive_typ
| Collection of base_typ_data Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["Mark.pos_map"; "primitive_typ_map"];
name = "base_typ_data_map";
},
visitors
{
variety = "iter";
ancestors = ["Mark.pos_iter"; "primitive_typ_iter"];
name = "base_typ_data_iter";
}]
type base_typ = Condition | Data of base_typ_data
[@@deriving
visitors
{
variety = "map";
ancestors = ["base_typ_data_map"];
name = "base_typ_map";
nude = true;
},
visitors
{
variety = "iter";
ancestors = ["base_typ_data_iter"];
name = "base_typ_iter";
nude = true;
}]
and base_typ = Condition | Data of base_typ_data
type func_typ = {
and func_typ = {
arg_typ : (lident Mark.pos * base_typ Mark.pos) list;
return_typ : base_typ Mark.pos;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["lident_map"; "base_typ_map"];
name = "func_typ_map";
nude = true;
},
visitors
{
variety = "iter";
ancestors = ["lident_iter"; "base_typ_iter"];
name = "func_typ_iter";
nude = true;
}]
type typ = naked_typ Mark.pos
and typ = naked_typ Mark.pos
and naked_typ = Base of base_typ | Func of func_typ
[@@deriving
visitors
{
variety = "map";
ancestors = ["func_typ_map"];
name = "typ_map";
nude = true;
},
visitors
{
variety = "iter";
ancestors = ["func_typ_iter"];
name = "typ_iter";
nude = true;
}]
type struct_decl_field = {
and struct_decl_field = {
struct_decl_field_name : lident Mark.pos;
struct_decl_field_typ : typ;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["typ_map"; "lident_map"];
name = "struct_decl_field_map";
},
visitors
{
variety = "iter";
ancestors = ["typ_iter"; "lident_iter"];
name = "struct_decl_field_iter";
}]
type struct_decl = {
and struct_decl = {
struct_decl_name : uident Mark.pos;
struct_decl_fields : struct_decl_field Mark.pos list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["struct_decl_field_map"];
name = "struct_decl_map";
},
visitors
{
variety = "iter";
ancestors = ["struct_decl_field_iter"];
name = "struct_decl_iter";
}]
type enum_decl_case = {
and enum_decl_case = {
enum_decl_case_name : uident Mark.pos;
enum_decl_case_typ : typ option;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["typ_map"];
name = "enum_decl_case_map";
nude = true;
},
visitors
{
variety = "iter";
ancestors = ["typ_iter"];
name = "enum_decl_case_iter";
nude = true;
}]
type enum_decl = {
and enum_decl = {
enum_decl_name : uident Mark.pos;
enum_decl_cases : enum_decl_case Mark.pos list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["enum_decl_case_map"];
name = "enum_decl_map";
nude = true;
},
visitors
{
variety = "iter";
ancestors = ["enum_decl_case_iter"];
name = "enum_decl_iter";
nude = true;
}]
type match_case_pattern =
and match_case_pattern =
(path * uident Mark.pos) Mark.pos list * lident Mark.pos option
[@@deriving
visitors
{
variety = "map";
ancestors = ["path_map"; "lident_map"; "uident_map"; "Mark.pos_map"];
name = "match_case_pattern_map";
},
visitors
{
variety = "iter";
ancestors = ["path_iter"; "lident_iter"; "uident_iter"; "Mark.pos_iter"];
name = "match_case_pattern_iter";
}]
type op_kind = KPoly | KInt | KDec | KMoney | KDate | KDuration
[@@deriving
visitors { variety = "map"; name = "op_kind_map"; nude = true },
visitors { variety = "iter"; name = "op_kind_iter"; nude = true }]
and op_kind = KPoly | KInt | KDec | KMoney | KDate | KDuration
type binop =
and binop =
| And
| Or
| Xor
@ -281,40 +105,10 @@ type binop =
| Eq
| Neq
| Concat
[@@deriving
visitors
{
variety = "map";
ancestors = ["op_kind_map"];
name = "binop_map";
nude = true;
},
visitors
{
variety = "iter";
ancestors = ["op_kind_iter"];
name = "binop_iter";
nude = true;
}]
type unop = Not | Minus of op_kind
[@@deriving
visitors
{
variety = "map";
ancestors = ["op_kind_map"];
name = "unop_map";
nude = true;
},
visitors
{
variety = "iter";
ancestors = ["op_kind_iter"];
name = "unop_iter";
nude = true;
}]
and unop = Not | Minus of op_kind
type builtin_expression =
and builtin_expression =
| Cardinal
| ToDecimal
| ToMoney
@ -324,83 +118,37 @@ type builtin_expression =
| LastDayOfMonth
| FirstDayOfMonth
| Round
[@@deriving
visitors { variety = "map"; name = "builtin_expression_map"; nude = true },
visitors { variety = "iter"; name = "builtin_expression_iter"; nude = true }]
type literal_date = {
and literal_date = {
literal_date_day : (int[@opaque]);
literal_date_month : (int[@opaque]);
literal_date_year : (int[@opaque]);
}
[@@deriving
visitors
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "literal_date_map" },
visitors
{
variety = "iter";
ancestors = ["Mark.pos_iter"];
name = "literal_date_iter";
}]
type literal_number =
and literal_number =
| Int of (string[@opaque])
| Dec of (string[@opaque]) * (string[@opaque])
[@@deriving
visitors { variety = "map"; name = "literal_number_map"; nude = true },
visitors { variety = "iter"; name = "literal_number_iter"; nude = true }]
type literal_unit = Percent | Year | Month | Day
[@@deriving
visitors { variety = "map"; name = "literal_unit_map"; nude = true },
visitors { variety = "iter"; name = "literal_unit_iter"; nude = true }]
and literal_unit = Percent | Year | Month | Day
type money_amount = {
and money_amount = {
money_amount_units : (string[@opaque]);
money_amount_cents : (string[@opaque]);
}
[@@deriving
visitors { variety = "map"; name = "money_amount_map"; nude = true },
visitors { variety = "iter"; name = "money_amount_iter"; nude = true }]
type literal =
and literal =
| LNumber of literal_number Mark.pos * literal_unit Mark.pos option
| LBool of bool
| LMoneyAmount of money_amount
| LDate of literal_date
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"literal_number_map";
"money_amount_map";
"literal_date_map";
"literal_unit_map";
];
name = "literal_map";
},
visitors
{
variety = "iter";
ancestors =
[
"literal_number_iter";
"money_amount_iter";
"literal_date_iter";
"literal_unit_iter";
];
name = "literal_iter";
}]
type collection_op =
and collection_op =
| Exists of { predicate : lident Mark.pos * expression }
| Forall of { predicate : lident Mark.pos * expression }
| Map of { f : lident Mark.pos * expression }
| Filter of { f : lident Mark.pos * expression }
| AggregateSum of { typ : primitive_typ }
(* it would be nice to remove the need for specifying the type here like for
(* it would be nice to remove the need for specifying the and here like for
extremums, but we need an additionl overload for "neutral element for
addition across types" *)
| AggregateExtremum of { max : bool; default : expression }
@ -441,55 +189,13 @@ and naked_expression =
| Ident of path * lident Mark.pos
| Dotted of expression * (path * lident Mark.pos) Mark.pos
(** Dotted is for both struct field projection and sub-scope variables *)
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"primitive_typ_map";
"match_case_pattern_map";
"literal_map";
"binop_map";
"unop_map";
"builtin_expression_map";
];
name = "expression_map";
},
visitors
{
variety = "iter";
ancestors =
[
"primitive_typ_iter";
"match_case_pattern_iter";
"literal_iter";
"binop_iter";
"unop_iter";
"builtin_expression_iter";
];
name = "expression_iter";
}]
type exception_to =
and exception_to =
| NotAnException
| UnlabeledException
| ExceptionToLabel of lident Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["lident_map"; "Mark.pos_map"];
name = "exception_to_map";
},
visitors
{
variety = "iter";
ancestors = ["lident_iter"; "Mark.pos_iter"];
name = "exception_to_iter";
}]
type rule = {
and rule = {
rule_label : lident Mark.pos option;
rule_exception_to : exception_to;
rule_parameter : lident Mark.pos list Mark.pos option;
@ -499,21 +205,8 @@ type rule = {
rule_consequence : (bool[@opaque]) Mark.pos;
rule_state : lident Mark.pos option;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["expression_map"; "scope_var_map"; "exception_to_map"];
name = "rule_map";
},
visitors
{
variety = "iter";
ancestors = ["expression_iter"; "scope_var_iter"; "exception_to_iter"];
name = "rule_iter";
}]
type definition = {
and definition = {
definition_label : lident Mark.pos option;
definition_exception_to : exception_to;
definition_name : scope_var Mark.pos;
@ -523,155 +216,46 @@ type definition = {
definition_expr : expression;
definition_state : lident Mark.pos option;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["expression_map"; "scope_var_map"; "exception_to_map"];
name = "definition_map";
},
visitors
{
variety = "iter";
ancestors = ["expression_iter"; "scope_var_iter"; "exception_to_iter"];
name = "definition_iter";
}]
type variation_typ = Increasing | Decreasing
[@@deriving
visitors { variety = "map"; name = "variation_typ_map" },
visitors { variety = "iter"; name = "variation_typ_iter" }]
and variation_typ = Increasing | Decreasing
type meta_assertion =
and meta_assertion =
| FixedBy of scope_var Mark.pos * lident Mark.pos
| VariesWith of
scope_var Mark.pos * expression * variation_typ Mark.pos option
[@@deriving
visitors
{
variety = "map";
ancestors = ["variation_typ_map"; "scope_var_map"; "expression_map"];
name = "meta_assertion_map";
},
visitors
{
variety = "iter";
ancestors = ["variation_typ_iter"; "scope_var_iter"; "expression_iter"];
name = "meta_assertion_iter";
}]
type assertion = {
and assertion = {
assertion_condition : expression option;
assertion_content : expression;
}
[@@deriving
visitors
{ variety = "map"; ancestors = ["expression_map"]; name = "assertion_map" },
visitors
{
variety = "iter";
ancestors = ["expression_iter"];
name = "assertion_iter";
}]
type scope_use_item =
and scope_use_item =
| Rule of rule
| Definition of definition
| Assertion of assertion
| MetaAssertion of meta_assertion
| DateRounding of variation_typ Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors =
["meta_assertion_map"; "definition_map"; "assertion_map"; "rule_map"];
name = "scope_use_item_map";
},
visitors
{
variety = "iter";
ancestors =
[
"meta_assertion_iter";
"definition_iter";
"assertion_iter";
"rule_iter";
];
name = "scope_use_item_iter";
}]
type scope_use = {
and scope_use = {
scope_use_condition : expression option;
scope_use_name : uident Mark.pos;
scope_use_items : scope_use_item Mark.pos list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["expression_map"; "scope_use_item_map"];
name = "scope_use_map";
},
visitors
{
variety = "iter";
ancestors = ["expression_iter"; "scope_use_item_iter"];
name = "scope_use_iter";
}]
type io_input = Input | Context | Internal
[@@deriving
visitors { variety = "map"; name = "io_input_map" },
visitors { variety = "iter"; name = "io_input_iter" }]
and io_input = Input | Context | Internal
type scope_decl_context_io = {
and scope_decl_context_io = {
scope_decl_context_io_input : io_input Mark.pos;
scope_decl_context_io_output : bool Mark.pos;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["io_input_map"; "Mark.pos_map"];
name = "scope_decl_context_io_map";
},
visitors
{
variety = "iter";
ancestors = ["io_input_iter"; "Mark.pos_iter"];
name = "scope_decl_context_io_iter";
}]
type scope_decl_context_scope = {
and scope_decl_context_scope = {
scope_decl_context_scope_name : lident Mark.pos;
scope_decl_context_scope_sub_scope : uident Mark.pos;
scope_decl_context_scope_attribute : scope_decl_context_io;
}
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"lident_map"; "uident_map"; "scope_decl_context_io_map"; "Mark.pos_map";
];
name = "scope_decl_context_scope_map";
},
visitors
{
variety = "iter";
ancestors =
[
"lident_iter";
"uident_iter";
"scope_decl_context_io_iter";
"Mark.pos_iter";
];
name = "scope_decl_context_scope_iter";
}]
type scope_decl_context_data = {
and scope_decl_context_data = {
scope_decl_context_item_name : lident Mark.pos;
scope_decl_context_item_typ : typ;
scope_decl_context_item_parameters :
@ -679,212 +263,61 @@ type scope_decl_context_data = {
scope_decl_context_item_attribute : scope_decl_context_io;
scope_decl_context_item_states : lident Mark.pos list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["typ_map"; "scope_decl_context_io_map"; "lident_map"];
name = "scope_decl_context_data_map";
},
visitors
{
variety = "iter";
ancestors = ["typ_iter"; "scope_decl_context_io_iter"; "lident_iter"];
name = "scope_decl_context_data_iter";
}]
type scope_decl_context_item =
and scope_decl_context_item =
| ContextData of scope_decl_context_data
| ContextScope of scope_decl_context_scope
[@@deriving
visitors
{
variety = "map";
ancestors =
["scope_decl_context_data_map"; "scope_decl_context_scope_map"];
name = "scope_decl_context_item_map";
},
visitors
{
variety = "iter";
ancestors =
["scope_decl_context_data_iter"; "scope_decl_context_scope_iter"];
name = "scope_decl_context_item_iter";
}]
type scope_decl = {
and scope_decl = {
scope_decl_name : uident Mark.pos;
scope_decl_context : scope_decl_context_item Mark.pos list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["scope_decl_context_item_map"];
name = "scope_decl_map";
},
visitors
{
variety = "iter";
ancestors = ["scope_decl_context_item_iter"];
name = "scope_decl_iter";
}]
type top_def = {
and top_def = {
topdef_name : lident Mark.pos;
topdef_args : (lident Mark.pos * base_typ Mark.pos) list Mark.pos option;
(** Empty list if this is not a function *)
topdef_type : typ;
topdef_expr : expression option;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["lident_map"; "typ_map"; "expression_map"];
name = "top_def_map";
},
visitors
{
variety = "iter";
ancestors = ["lident_iter"; "typ_iter"; "expression_iter"];
name = "top_def_iter";
}]
type code_item =
and code_item =
| ScopeUse of scope_use
| ScopeDecl of scope_decl
| StructDecl of struct_decl
| EnumDecl of enum_decl
| Topdef of top_def
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"scope_decl_map";
"enum_decl_map";
"struct_decl_map";
"scope_use_map";
"top_def_map";
];
name = "code_item_map";
},
visitors
{
variety = "iter";
ancestors =
[
"scope_decl_iter";
"enum_decl_iter";
"struct_decl_iter";
"scope_use_iter";
"top_def_iter";
];
name = "code_item_iter";
}]
type code_block = code_item Mark.pos list
[@@deriving
visitors
{ variety = "map"; ancestors = ["code_item_map"]; name = "code_block_map" },
visitors
{
variety = "iter";
ancestors = ["code_item_iter"];
name = "code_block_iter";
}]
and code_block = code_item Mark.pos list
and source_repr = (string[@opaque]) Mark.pos
type source_repr = (string[@opaque]) Mark.pos
[@@deriving
visitors
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "source_repr_map" },
visitors
{
variety = "iter";
ancestors = ["Mark.pos_iter"];
name = "source_repr_iter";
}]
type law_heading = {
and law_heading = {
law_heading_name : (string[@opaque]) Mark.pos;
law_heading_id : (string[@opaque]) option;
law_heading_is_archive : bool; [@opaque]
law_heading_precedence : (int[@opaque]);
}
[@@deriving
visitors
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "law_heading_map" },
visitors
{
variety = "iter";
ancestors = ["Mark.pos_iter"];
name = "law_heading_iter";
}]
type law_include =
and law_include =
| PdfFile of (string[@opaque]) Mark.pos * (int[@opaque]) option
| CatalaFile of (string[@opaque]) Mark.pos
| LegislativeText of (string[@opaque]) Mark.pos
[@@deriving
visitors
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "law_include_map" },
visitors
{
variety = "iter";
ancestors = ["Mark.pos_iter"];
name = "law_include_iter";
}]
type law_structure =
and law_structure =
| LawInclude of law_include
| LawHeading of law_heading * law_structure list
| LawText of (string[@opaque])
| CodeBlock of code_block * source_repr * bool (* Metadata if true *)
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"law_include_map";
"code_block_map";
"source_repr_map";
"law_heading_map";
];
name = "law_structure_map";
},
visitors
{
variety = "iter";
ancestors =
[
"law_include_iter";
"code_block_iter";
"source_repr_iter";
"law_heading_iter";
];
name = "law_structure_iter";
}]
type program = {
and program = {
program_interfaces :
((Shared_ast.Qident.path[@opaque]) * code_item Mark.pos) list;
program_items : law_structure list;
program_source_files : (string[@opaque]) list;
}
[@@deriving
visitors
{ variety = "map"; ancestors = ["law_structure_map"]; name = "program_map" },
visitors
{
variety = "iter";
ancestors = ["law_structure_iter"];
name = "program_iter";
}]
type source_file = law_structure list
and source_file = law_structure list
[@@deriving visitors { variety = "map"; ancestors = ["Mark.pos_map"] }]
(** {1 Helpers}*)

2
compiler/surface/fill_positions.ml
View File

@ -19,7 +19,7 @@ open Catala_utils
let fill_pos_with_legislative_info (p : Ast.program) : Ast.program =
let visitor =
object
inherit [_] Ast.program_map as super
inherit [_] Ast.map as super
method! visit_pos f env x =
f env (Mark.remove x), Pos.overwrite_law_info (Mark.get x) env