Skip to content

Commit

Permalink
poc of nested record definitions
Browse files Browse the repository at this point in the history
  • Loading branch information
@zth
zth committed Jan 10, 2025
1 parent 11b2c2d commit e487f2f
Show file tree
Hide file tree
Showing 4 changed files with 196 additions and 48 deletions.
142 changes: 104 additions & 38 deletions compiler/syntax/src/res_core.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 -> (
Expand All @@ -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 =
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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 ()
Expand Down Expand Up @@ -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;
Expand All @@ -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 =
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand All @@ -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}
Expand All @@ -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;
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand All @@ -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;
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down
Loading

0 comments on commit e487f2f

Please sign in to comment.