From e487f2f93af647c4c65a98230131b3643c2374db Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 10 Jan 2025 23:56:21 +0100 Subject: [PATCH] poc of nested record definitions --- compiler/syntax/src/res_core.ml | 142 +++++++++++++++++++++-------- compiler/syntax/src/res_printer.ml | 71 +++++++++++++-- tests/tests/src/nested_records.mjs | 16 ++++ tests/tests/src/nested_records.res | 15 +++ 4 files changed, 196 insertions(+), 48 deletions(-) create mode 100644 tests/tests/src/nested_records.mjs create mode 100644 tests/tests/src/nested_records.res diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 02c660b9d3..d8864b8e53 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -4048,7 +4048,7 @@ and parse_array_exp p = (* TODO: check attributes in the case of poly type vars, * might be context dependend: parseFieldDeclaration (see ocaml) *) -and parse_poly_type_expr p = +and parse_poly_type_expr ?current_type_name_path ?inline_types p = let start_pos = p.Parser.start_pos in match p.Parser.token with | SingleQuote -> ( @@ -4075,7 +4075,7 @@ and parse_poly_type_expr p = return_type | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) | _ -> assert false) - | _ -> parse_typ_expr p + | _ -> parse_typ_expr ?current_type_name_path ?inline_types p (* 'a 'b 'c *) and parse_type_var_list p = @@ -4103,7 +4103,7 @@ and parse_lident_list p = in loop p [] -and parse_atomic_typ_expr ~attrs p = +and parse_atomic_typ_expr ?current_type_name_path ?inline_types ~attrs p = Parser.leave_breadcrumb p Grammar.AtomicTypExpr; let start_pos = p.Parser.start_pos in let typ = @@ -4160,7 +4160,8 @@ and parse_atomic_typ_expr ~attrs p = let extension = parse_extension p in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Typ.extension ~attrs ~loc extension - | Lbrace -> parse_record_or_object_type ~attrs p + | Lbrace -> + parse_record_or_object_type ?current_type_name_path ?inline_types ~attrs p | Eof -> Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); Recover.default_type () @@ -4222,7 +4223,7 @@ and parse_package_constraint p = Some (type_constr, typ) | _ -> None -and parse_record_or_object_type ~attrs p = +and parse_record_or_object_type ?current_type_name_path ?inline_types ~attrs p = (* for inline record in constructor *) let start_pos = p.Parser.start_pos in Parser.expect Lbrace p; @@ -4236,20 +4237,39 @@ and parse_record_or_object_type ~attrs p = Asttypes.Closed | _ -> Asttypes.Closed in - let () = - match p.token with - | Lident _ -> - Parser.err p - (Diagnostics.message ErrorMessages.forbidden_inline_record_declaration) - | _ -> () - in - let fields = - parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parse_string_field_declaration p - in - Parser.expect Rbrace p; - let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Typ.object_ ~loc ~attrs fields closed_flag + match (p.token, inline_types, current_type_name_path) with + | Lident _, Some inline_types, Some current_type_name_path -> + let labels = + parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f: + (parse_field_declaration_region ~current_type_name_path ~inline_types) + p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let inline_type_name = current_type_name_path |> String.concat "." in + inline_types := + (inline_type_name, loc, Parsetree.Ptype_record labels) :: !inline_types; + + let lid = Location.mkloc (Longident.Lident inline_type_name) loc in + Ast_helper.Typ.constr + ~attrs:[(Location.mknoloc "inlineRecordReference", PStr [])] + ~loc lid [] + | _ -> + let () = + match p.token with + | Lident _ -> + Parser.err p + (Diagnostics.message ErrorMessages.forbidden_inline_record_declaration) + | _ -> () + in + let fields = + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.object_ ~loc ~attrs fields closed_flag (* TODO: check associativity in combination with attributes *) and parse_type_alias p typ = @@ -4458,7 +4478,8 @@ and parse_es6_arrow_type ~attrs p = * | uident.lident * | uident.uident.lident --> long module path *) -and parse_typ_expr ?attrs ?(es6_arrow = true) ?(alias = true) p = +and parse_typ_expr ?current_type_name_path ?inline_types ?attrs + ?(es6_arrow = true) ?(alias = true) p = (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) let start_pos = p.Parser.start_pos in let attrs = @@ -4469,7 +4490,9 @@ and parse_typ_expr ?attrs ?(es6_arrow = true) ?(alias = true) p = let typ = if es6_arrow && is_es6_arrow_type p then parse_es6_arrow_type ~attrs p else - let typ = parse_atomic_typ_expr ~attrs p in + let typ = + parse_atomic_typ_expr ?current_type_name_path ?inline_types ~attrs p + in parse_arrow_type_rest ~es6_arrow ~start_pos typ p in let typ = if alias then parse_type_alias p typ else typ in @@ -4610,7 +4633,8 @@ and parse_field_declaration p = let loc = mk_loc start_pos typ.ptyp_loc.loc_end in Ast_helper.Type.field ~attrs ~loc ~mut ~optional name typ -and parse_field_declaration_region ?found_object_field p = +and parse_field_declaration_region ?current_type_name_path ?inline_types + ?found_object_field p = let start_pos = p.Parser.start_pos in let attrs = parse_attributes p in let mut = @@ -4635,12 +4659,17 @@ and parse_field_declaration_region ?found_object_field p = | Lident _ -> let lident, loc = parse_lident p in let name = Location.mkloc lident loc in + let current_type_name_path = + match current_type_name_path with + | None -> None + | Some current_type_name_path -> Some (current_type_name_path @ [name.txt]) + in let optional = parse_optional_label p in let typ = match p.Parser.token with | Colon -> Parser.next p; - parse_poly_type_expr p + parse_poly_type_expr ?current_type_name_path ?inline_types p | _ -> Ast_helper.Typ.constr ~loc:name.loc ~attrs {name with txt = Lident name.txt} @@ -4666,12 +4695,13 @@ and parse_field_declaration_region ?found_object_field p = * | { field-decl, field-decl } * | { field-decl, field-decl, field-decl, } *) -and parse_record_declaration p = +and parse_record_declaration ?current_type_name_path ?inline_types p = Parser.leave_breadcrumb p Grammar.RecordDecl; Parser.expect Lbrace p; let rows = parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:parse_field_declaration_region p + ~f:(parse_field_declaration_region ?current_type_name_path ?inline_types) + p in Parser.expect Rbrace p; Parser.eat_breadcrumb p; @@ -4914,7 +4944,7 @@ and parse_type_constructor_declarations ?first p = * ∣ = private record-decl * | = .. *) -and parse_type_representation p = +and parse_type_representation ?current_type_name_path ?inline_types p = Parser.leave_breadcrumb p Grammar.TypeRepresentation; (* = consumed *) let private_flag = @@ -4925,7 +4955,9 @@ and parse_type_representation p = match p.Parser.token with | Bar | Uident _ -> Parsetree.Ptype_variant (parse_type_constructor_declarations p) - | Lbrace -> Parsetree.Ptype_record (parse_record_declaration p) + | Lbrace -> + Parsetree.Ptype_record + (parse_record_declaration ?current_type_name_path ?inline_types p) | DotDot -> Parser.next p; Ptype_open @@ -5117,7 +5149,7 @@ and parse_type_equation_or_constr_decl p = (* TODO: is this a good idea? *) (None, Asttypes.Public, Parsetree.Ptype_abstract) -and parse_record_or_object_decl p = +and parse_record_or_object_decl ?current_type_name_path ?inline_types p = let start_pos = p.Parser.start_pos in Parser.expect Lbrace p; match p.Parser.token with @@ -5173,7 +5205,9 @@ and parse_record_or_object_decl p = let found_object_field = ref false in let fields = parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:(parse_field_declaration_region ~found_object_field) + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types ~found_object_field) p in Parser.expect Rbrace p; @@ -5244,7 +5278,11 @@ and parse_record_or_object_decl p = match attrs with | [] -> parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parse_field_declaration_region p + ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types) + p | attr :: _ as attrs -> let first = let field = parse_field_declaration p in @@ -5261,7 +5299,11 @@ and parse_record_or_object_decl p = in first :: parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parse_field_declaration_region p + ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types) + p in Parser.expect Rbrace p; Parser.eat_breadcrumb p; @@ -5451,14 +5493,16 @@ and parse_polymorphic_variant_type_args p = | [typ] -> typ | types -> Ast_helper.Typ.tuple ~loc ~attrs types -and parse_type_equation_and_representation p = +and parse_type_equation_and_representation ?current_type_name_path ?inline_types + p = match p.Parser.token with | (Equal | Bar) as token -> ( if token = Bar then Parser.expect Equal p; Parser.next p; match p.Parser.token with | Uident _ -> parse_type_equation_or_constr_decl p - | Lbrace -> parse_record_or_object_decl p + | Lbrace -> + parse_record_or_object_decl ?current_type_name_path ?inline_types p | Private -> parse_private_eq_or_repr p | Bar | DotDot -> let priv, kind = parse_type_representation p in @@ -5468,7 +5512,9 @@ and parse_type_equation_and_representation p = match p.Parser.token with | Equal -> Parser.next p; - let priv, kind = parse_type_representation p in + let priv, kind = + parse_type_representation ?current_type_name_path ?inline_types p + in (manifest, priv, kind) | _ -> (manifest, Public, Parsetree.Ptype_abstract))) | _ -> (None, Public, Parsetree.Ptype_abstract) @@ -5534,9 +5580,13 @@ and parse_type_extension ~params ~attrs ~name p = let constructors = loop p [first] in Ast_helper.Te.mk ~attrs ~params ~priv name constructors -and parse_type_definitions ~attrs ~name ~params ~start_pos p = +and parse_type_definitions ?current_type_name_path ?inline_types ~attrs ~name + ~params ~start_pos p = let type_def = - let manifest, priv, kind = parse_type_equation_and_representation p in + let manifest, priv, kind = + parse_type_equation_and_representation ?current_type_name_path + ?inline_types p + in let cstrs = parse_type_constraints p in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest @@ -5585,8 +5635,24 @@ and parse_type_definition_or_extension ~attrs p = (longident |> ErrorMessages.type_declaration_name_longident |> Diagnostics.message) in - let type_defs = parse_type_definitions ~attrs ~name ~params ~start_pos p in - TypeDef {rec_flag; types = type_defs} + let current_type_name_path = Longident.flatten name.txt in + let inline_types = ref [] in + let type_defs = + parse_type_definitions ~inline_types ~current_type_name_path ~attrs ~name + ~params ~start_pos p + in + let rec_flag = + if List.length !inline_types > 0 then Asttypes.Recursive else rec_flag + in + let inline_types = + !inline_types + |> List.map (fun (inline_type_name, loc, kind) -> + Ast_helper.Type.mk + ~attrs:[(Location.mknoloc "inlineRecordDefinition", PStr [])] + ~loc ~kind + {name with txt = inline_type_name}) + in + TypeDef {rec_flag; types = inline_types @ type_defs} (* external value-name : typexp = external-declaration *) and parse_external_def ~attrs ~start_pos p = diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 1144c178ba..11ac7180de 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -550,6 +550,16 @@ module State = struct let should_break_callback t = t.custom_layout > custom_layout_threshold end +let is_inline_record_definition attrs = + attrs + |> List.exists (fun (({txt}, _) : Parsetree.attribute) -> + txt = "inlineRecordDefinition") + +let is_inline_record_reference attrs = + attrs + |> List.exists (fun (({txt}, _) : Parsetree.attribute) -> + txt = "inlineRecordReference") + let rec print_structure ~state (s : Parsetree.structure) t = match s with | [] -> print_comments_inside_file t @@ -569,6 +579,23 @@ and print_structure_item ~state (si : Parsetree.structure_item) cmt_tbl = | Asttypes.Recursive -> Doc.text "rec " in print_value_bindings ~state ~rec_flag value_bindings cmt_tbl + | Pstr_type (Recursive, type_declarations) + when type_declarations + |> List.find_opt (fun (td : Parsetree.type_declaration) -> + is_inline_record_definition td.ptype_attributes) + |> Option.is_some -> + let inline_record_definitions, regular_declarations = + type_declarations + |> List.partition (fun (td : Parsetree.type_declaration) -> + td.ptype_attributes + |> List.exists (fun (({txt}, _) : Parsetree.attribute) -> + txt = "inlineRecordDefinition")) + in + print_type_declarations ~inline_record_definitions ~state + ~rec_flag: + (if List.length regular_declarations > 1 then Doc.text "rec " + else Doc.nil) + regular_declarations cmt_tbl | Pstr_type (rec_flag, type_declarations) -> let rec_flag = match rec_flag with @@ -1109,11 +1136,12 @@ and print_value_description ~state value_description cmt_tbl = else Doc.nil); ]) -and print_type_declarations ~state ~rec_flag type_declarations cmt_tbl = +and print_type_declarations ?inline_record_definitions ~state ~rec_flag + type_declarations cmt_tbl = print_listi ~get_loc:(fun n -> n.Parsetree.ptype_loc) ~nodes:type_declarations - ~print:(print_type_declaration2 ~state ~rec_flag) + ~print:(print_type_declaration2 ?inline_record_definitions ~state ~rec_flag) cmt_tbl (* @@ -1219,8 +1247,8 @@ and print_type_declaration ~state ~name ~equal_sign ~rec_flag i (Doc.concat [attrs; prefix; type_name; type_params; manifest_and_kind; constraints]) -and print_type_declaration2 ~state ~rec_flag (td : Parsetree.type_declaration) - cmt_tbl i = +and print_type_declaration2 ?inline_record_definitions ~state ~rec_flag + (td : Parsetree.type_declaration) cmt_tbl i = let name = let doc = print_ident_like td.Parsetree.ptype_name.txt in print_comments doc cmt_tbl td.ptype_name.loc @@ -1280,7 +1308,8 @@ and print_type_declaration2 ~state ~rec_flag (td : Parsetree.type_declaration) manifest; Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; print_private_flag td.ptype_private; - print_record_declaration ~state lds cmt_tbl; + print_record_declaration ?inline_record_definitions ~state lds + cmt_tbl; ] | Ptype_variant cds -> let manifest = @@ -1373,8 +1402,8 @@ and print_type_param ~state (param : Parsetree.core_type * Asttypes.variance) in Doc.concat [printed_variance; print_typ_expr ~state typ cmt_tbl] -and print_record_declaration ~state (lds : Parsetree.label_declaration list) - cmt_tbl = +and print_record_declaration ?inline_record_definitions ~state + (lds : Parsetree.label_declaration list) cmt_tbl = let force_break = match (lds, List.rev lds) with | first :: _, last :: _ -> @@ -1393,7 +1422,10 @@ and print_record_declaration ~state (lds : Parsetree.label_declaration list) ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = print_label_declaration ~state ld cmt_tbl in + let doc = + print_label_declaration ?inline_record_definitions + ~state ld cmt_tbl + in print_comments doc cmt_tbl ld.Parsetree.pld_loc) lds); ]); @@ -1558,7 +1590,8 @@ and print_constructor_arguments ?(is_dot_dot_dot = false) ~state ~indent in if indent then Doc.indent args else args -and print_label_declaration ~state (ld : Parsetree.label_declaration) cmt_tbl = +and print_label_declaration ?inline_record_definitions ~state + (ld : Parsetree.label_declaration) cmt_tbl = let attrs = print_attributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmt_tbl in @@ -1583,7 +1616,25 @@ and print_label_declaration ~state (ld : Parsetree.label_declaration) cmt_tbl = name; optional; (if is_dot then Doc.nil else Doc.text ": "); - print_typ_expr ~state ld.pld_type cmt_tbl; + (match + ( inline_record_definitions, + is_inline_record_reference ld.pld_type.ptyp_attributes, + ld.pld_type ) + with + | ( Some inline_record_definitions, + true, + {ptyp_desc = Ptyp_constr ({txt = Lident constr_name}, _)} ) -> ( + let record_definition = + inline_record_definitions + |> List.find (fun (r : Parsetree.type_declaration) -> + r.ptype_name.txt = constr_name) + in + match record_definition.ptype_kind with + | Ptype_record lds -> + print_record_declaration ~inline_record_definitions ~state lds + cmt_tbl + | _ -> assert false) + | _ -> print_typ_expr ~state ld.pld_type cmt_tbl); ]) and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = diff --git a/tests/tests/src/nested_records.mjs b/tests/tests/src/nested_records.mjs new file mode 100644 index 0000000000..c9e7e9bb63 --- /dev/null +++ b/tests/tests/src/nested_records.mjs @@ -0,0 +1,16 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +let options = { + extra: { + name: "test", + superExtra: { + age: 2222 + } + } +}; + +export { + options, +} +/* No side effect */ diff --git a/tests/tests/src/nested_records.res b/tests/tests/src/nested_records.res new file mode 100644 index 0000000000..92e8945034 --- /dev/null +++ b/tests/tests/src/nested_records.res @@ -0,0 +1,15 @@ +type options = { + extra?: { + name: string, + superExtra?: {age: int}, + }, +} + +let options = { + extra: { + name: "test", + superExtra: { + age: 2222, + }, + }, +}