From 300d993733f09f8e7ba52a524089959f0468f00a Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 4 Aug 2023 11:40:23 +0200 Subject: [PATCH] Simplify visitors ppx annotations the small downside is that we lose a little bit of granularity by making defining all the types at once (with `type ... and`) ; but one well-placed annotation seems to be enough. also discarded the `iter` visitor that was unused. --- compiler/surface/ast.ml | 663 +++-------------------------- compiler/surface/fill_positions.ml | 2 +- 2 files changed, 49 insertions(+), 616 deletions(-) diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index 8c24eced..ea4b27d9 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -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}*) diff --git a/compiler/surface/fill_positions.ml b/compiler/surface/fill_positions.ml index 376be5e1..a4c3a535 100644 --- a/compiler/surface/fill_positions.ml +++ b/compiler/surface/fill_positions.ml @@ -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