Skip to content

Commit f1d0698

Browse files
tsnobiptsnobip
committed
support record type alias in rest
1 parent 74422b4 commit f1d0698

File tree

6 files changed

+115
-65
lines changed

6 files changed

+115
-65
lines changed

‎compiler/ml/ast_mapper_from0.ml‎

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -77,6 +77,18 @@ let map_constant = function
7777

7878
let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
7979

80+
let record_rest_attr_name = "res.record_rest"
81+
82+
let get_record_rest_attr attrs_ =
83+
let rec remove_record_rest_attr acc = function
84+
| ({Location.txt = attr_name; _}, Pt.PPat (rest, None)) :: attrs
85+
when attr_name = record_rest_attr_name ->
86+
(Some rest, List.rev_append acc attrs)
87+
| attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs
88+
| [] -> (None, List.rev acc)
89+
in
90+
remove_record_rest_attr [] attrs_
91+
8092
module T = struct
8193
(* Type expressions for the core language *)
8294

@@ -576,7 +588,7 @@ module P = struct
576588
construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
577589
| Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
578590
| Ppat_record (lpl, cf) ->
579-
let rest, attrs = Parsetree0.get_record_rest_attr attrs in
591+
let rest, attrs = get_record_rest_attr attrs in
580592
record ~loc ~attrs ?rest
581593
(Ext_list.map lpl (fun (lid, p) ->
582594
let lid1 = map_loc sub lid in

‎compiler/ml/ast_mapper_to0.ml‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -77,6 +77,11 @@ let map_constant = function
7777

7878
let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
7979

80+
let record_rest_attr_name = "res.record_rest"
81+
82+
let add_record_rest_attr ~rest attrs =
83+
(Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs
84+
8085
module T = struct
8186
(* Type expressions for the core language *)
8287

@@ -564,7 +569,7 @@ module P = struct
564569
match rest with
565570
| None -> attrs
566571
| Some rest_pat ->
567-
Parsetree0.add_record_rest_attr ~rest:(sub.pat sub rest_pat) attrs
572+
add_record_rest_attr ~rest:(sub.pat sub rest_pat) attrs
568573
in
569574
record ~loc ~attrs
570575
(Ext_list.map lpl (fun {lid; x = p; opt = optional} ->

‎compiler/ml/parsetree0.ml‎

Lines changed: 0 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -597,7 +597,6 @@ and module_binding = {
597597

598598
let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr [])
599599
let optional_attr0 = (Location.mknoloc "res.optional", PStr [])
600-
let record_rest_attr_name = "res.record_rest"
601600

602601
let add_optional_attr ~optional attrs =
603602
if optional then optional_attr0 :: attrs else attrs
@@ -609,16 +608,3 @@ let get_optional_attr attrs_ =
609608
let attrs = remove_optional_attr attrs_ in
610609
let optional = List.length attrs <> List.length attrs_ in
611610
(optional, attrs)
612-
613-
let add_record_rest_attr ~rest attrs =
614-
(Location.mknoloc record_rest_attr_name, PPat (rest, None)) :: attrs
615-
616-
let get_record_rest_attr attrs_ =
617-
let rec remove_record_rest_attr acc = function
618-
| ({Location.txt = attr_name; _}, Parsetree.PPat (rest, None)) :: attrs
619-
when attr_name = record_rest_attr_name ->
620-
(Some rest, List.rev_append acc attrs)
621-
| attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs
622-
| [] -> (None, List.rev acc)
623-
in
624-
remove_record_rest_attr [] attrs_

‎compiler/ml/typecore.ml‎

Lines changed: 50 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -343,6 +343,19 @@ let unify_pat_types loc env ty ty' =
343343
| Tags (l1, l2) ->
344344
raise (Typetexp.Error (loc, env, Typetexp.Variant_tags (l1, l2)))
345345

346+
let extract_instantiated_concrete_typedecl env loc ty =
347+
let _, _, decl = extract_concrete_typedecl env ty in
348+
let decl = instance_declaration decl in
349+
let args =
350+
match expand_head env ty with
351+
| {desc = Tconstr (_, args, _)} -> args
352+
| _ -> assert false
353+
in
354+
List.iter2
355+
(fun param arg -> unify_pat_types loc env param arg)
356+
decl.type_params args;
357+
decl
358+
346359
(* unification inside type_exp and type_expect *)
347360
let unify_exp_types ~context loc env ty expected_ty =
348361
try unify env ty expected_ty with
@@ -1593,18 +1606,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
15931606
raise (Error (rest_pat.ppat_loc, !env, Record_rest_invalid_type))
15941607
in
15951608
(* Look up the rest record type *)
1596-
let rest_path, rest_decl =
1609+
let rest_path, rest_annotation_decl =
15971610
Typetexp.find_type !env rest_type_lid.loc rest_type_lid.txt
15981611
in
1599-
let rest_decl =
1600-
match rest_decl.type_kind with
1601-
| Type_record _ -> instance_declaration rest_decl
1602-
| _ ->
1603-
raise
1604-
(Error
1605-
( rest_type_lid.loc,
1606-
!env,
1607-
Record_rest_not_record rest_type_lid.txt ))
1612+
let rest_annotation_decl =
1613+
instance_declaration rest_annotation_decl
16081614
in
16091615
(* Get explicit field names *)
16101616
let explicit_fields =
@@ -1617,10 +1623,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
16171623
in
16181624
let rest_type_args =
16191625
match rest_type_args_syntax with
1620-
| [] -> List.map (fun _ -> newvar ()) rest_decl.type_params
1626+
| [] ->
1627+
List.map (fun _ -> newvar ()) rest_annotation_decl.type_params
16211628
| args ->
16221629
let n_args = List.length args in
1623-
let n_params = List.length rest_decl.type_params in
1630+
let n_params = List.length rest_annotation_decl.type_params in
16241631
if n_args <> n_params then
16251632
raise
16261633
(Typetexp.Error
@@ -1640,30 +1647,45 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
16401647
let rest_type_expr =
16411648
newgenty (Tconstr (rest_path, rest_type_args, ref Mnil))
16421649
in
1643-
if rest_decl.type_private = Private then
1650+
if rest_annotation_decl.type_private = Private then
16441651
raise (Error (rest_type_lid.loc, !env, Private_type rest_type_expr));
16451652
List.iter2
16461653
(fun param arg -> unify_pat_types rest_type_lid.loc !env param arg)
1647-
rest_decl.type_params rest_type_args;
1654+
rest_annotation_decl.type_params rest_type_args;
1655+
let rest_decl =
1656+
match
1657+
try
1658+
Some
1659+
(extract_instantiated_concrete_typedecl !env rest_type_lid.loc
1660+
rest_type_expr)
1661+
with Not_found -> None
1662+
with
1663+
| Some rest_decl -> (
1664+
if rest_decl.type_private = Private then
1665+
raise
1666+
(Error (rest_type_lid.loc, !env, Private_type rest_type_expr));
1667+
match rest_decl.type_kind with
1668+
| Type_record _ -> rest_decl
1669+
| _ ->
1670+
raise
1671+
(Error
1672+
( rest_type_lid.loc,
1673+
!env,
1674+
Record_rest_not_record rest_type_lid.txt )))
1675+
| None ->
1676+
raise
1677+
(Error
1678+
( rest_type_lid.loc,
1679+
!env,
1680+
Record_rest_not_record rest_type_lid.txt ))
1681+
in
16481682
let source_fields, source_repr =
16491683
match
16501684
try
1651-
let _, _, source_decl =
1652-
extract_concrete_typedecl !env record_ty
1653-
in
1654-
let source_decl = instance_declaration source_decl in
1655-
let source_type_args =
1656-
match expand_head !env record_ty with
1657-
| {desc = Tconstr (_, args, _)} -> args
1658-
| _ -> assert false
1659-
in
1660-
Some (source_decl, source_type_args)
1685+
Some (extract_instantiated_concrete_typedecl !env loc record_ty)
16611686
with Not_found -> None
16621687
with
1663-
| Some (source_decl, source_type_args) -> (
1664-
List.iter2
1665-
(fun param arg -> unify_pat_types loc !env param arg)
1666-
source_decl.type_params source_type_args;
1688+
| Some source_decl -> (
16671689
match source_decl.type_kind with
16681690
| Type_record (fields, repr) ->
16691691
( List.map

‎tests/tests/src/record_rest_test.mjs‎

Lines changed: 34 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,10 @@ function describeConfig(c) {
1111
];
1212
}
1313

14+
function getAliasedRest(param) {
15+
return ((({name: __unused0, ...__rest}) => __rest))(param);
16+
}
17+
1418
function getRenamedRest(param) {
1519
return ((({"user-name": __unused0, ...__rest}) => __rest))(param);
1620
}
@@ -62,13 +66,13 @@ Mocha.describe("Record_rest_test", () => {
6266
version: "1.0",
6367
debug: true
6468
});
65-
Test_utils.eq("File \"record_rest_test.res\", line 124, characters 7-14", "test", "test");
66-
Test_utils.eq("File \"record_rest_test.res\", line 125, characters 7-14", rest, {
69+
Test_utils.eq("File \"record_rest_test.res\", line 128, characters 7-14", "test", "test");
70+
Test_utils.eq("File \"record_rest_test.res\", line 129, characters 7-14", rest, {
6771
version: "1.0",
6872
debug: true
6973
});
7074
});
71-
Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 130, characters 6-13", describeConfig({
75+
Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 134, characters 6-13", describeConfig({
7276
name: "match",
7377
version: "2.0",
7478
debug: false
@@ -79,20 +83,28 @@ Mocha.describe("Record_rest_test", () => {
7983
debug: false
8084
}
8185
]));
82-
Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 137, characters 7-14", getName({
86+
Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 141, characters 7-14", getName({
8387
name: "param",
8488
version: "3.0",
8589
debug: true
8690
}), "param"));
87-
Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 142, characters 6-13", getRenamedRest({
91+
Mocha.test("record rest accepts type aliases to record shapes", () => Test_utils.eq("File \"record_rest_test.res\", line 146, characters 6-13", getAliasedRest({
92+
name: "aliased",
93+
version: "3.1",
94+
debug: false
95+
}), {
96+
version: "3.1",
97+
debug: false
98+
}));
99+
Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 154, characters 6-13", getRenamedRest({
88100
"user-name": "renamed",
89101
version: "3.2",
90102
debug: true
91103
}), {
92104
version: "3.2",
93105
debug: true
94106
}));
95-
Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 150, characters 6-13", ((({...__rest}) => __rest))({
107+
Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 162, characters 6-13", ((({...__rest}) => __rest))({
96108
name: "whole",
97109
version: "3.5",
98110
debug: false
@@ -108,7 +120,7 @@ Mocha.describe("Record_rest_test", () => {
108120
style: "bold",
109121
onClick: onClick
110122
});
111-
Test_utils.eq("File \"record_rest_test.res\", line 159, characters 7-14", rest, {
123+
Test_utils.eq("File \"record_rest_test.res\", line 171, characters 7-14", rest, {
112124
style: "bold",
113125
onClick: onClick
114126
});
@@ -118,18 +130,18 @@ Mocha.describe("Record_rest_test", () => {
118130
id: "1",
119131
value: 42
120132
});
121-
Test_utils.eq("File \"record_rest_test.res\", line 164, characters 7-14", "1", "1");
122-
Test_utils.eq("File \"record_rest_test.res\", line 165, characters 7-14", intRest, {
133+
Test_utils.eq("File \"record_rest_test.res\", line 176, characters 7-14", "1", "1");
134+
Test_utils.eq("File \"record_rest_test.res\", line 177, characters 7-14", intRest, {
123135
value: 42
124136
});
125-
Test_utils.eq("File \"record_rest_test.res\", line 166, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({
137+
Test_utils.eq("File \"record_rest_test.res\", line 178, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({
126138
id: "2",
127139
value: "hello"
128140
}), {
129141
value: "hello"
130142
});
131143
});
132-
Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 171, characters 6-13", getTupleRest([
144+
Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 183, characters 6-13", getTupleRest([
133145
{
134146
name: "tuple",
135147
version: "4.0",
@@ -141,7 +153,7 @@ Mocha.describe("Record_rest_test", () => {
141153
debug: false
142154
}));
143155
Mocha.test("variant payload rest works through the or-pattern path", () => {
144-
Test_utils.eq("File \"record_rest_test.res\", line 179, characters 6-13", getWrappedRest({
156+
Test_utils.eq("File \"record_rest_test.res\", line 191, characters 6-13", getWrappedRest({
145157
TAG: "Wrap",
146158
_0: {
147159
name: "wrapped",
@@ -152,7 +164,7 @@ Mocha.describe("Record_rest_test", () => {
152164
version: "5.0",
153165
debug: true
154166
});
155-
Test_utils.eq("File \"record_rest_test.res\", line 184, characters 6-13", getWrappedRest({
167+
Test_utils.eq("File \"record_rest_test.res\", line 196, characters 6-13", getWrappedRest({
156168
TAG: "Mirror",
157169
_0: {
158170
name: "mirror",
@@ -165,7 +177,7 @@ Mocha.describe("Record_rest_test", () => {
165177
});
166178
});
167179
Mocha.test("inline record variant rest removes the runtime tag field", () => {
168-
Test_utils.eq("File \"record_rest_test.res\", line 192, characters 6-13", getInlineWrappedRest({
180+
Test_utils.eq("File \"record_rest_test.res\", line 204, characters 6-13", getInlineWrappedRest({
169181
TAG: "InlineWrap",
170182
name: "inline",
171183
version: "7.0",
@@ -174,7 +186,7 @@ Mocha.describe("Record_rest_test", () => {
174186
version: "7.0",
175187
debug: true
176188
});
177-
Test_utils.eq("File \"record_rest_test.res\", line 197, characters 6-13", getInlineWrappedRest({
189+
Test_utils.eq("File \"record_rest_test.res\", line 209, characters 6-13", getInlineWrappedRest({
178190
TAG: "InlineMirror",
179191
name: "inlineMirror",
180192
version: "8.0",
@@ -185,7 +197,7 @@ Mocha.describe("Record_rest_test", () => {
185197
});
186198
});
187199
Mocha.test("inline record variant rest excludes fields renamed with @as", () => {
188-
Test_utils.eq("File \"record_rest_test.res\", line 205, characters 6-13", getRenamedInlineWrappedRest({
200+
Test_utils.eq("File \"record_rest_test.res\", line 217, characters 6-13", getRenamedInlineWrappedRest({
189201
TAG: "RenamedInlineWrap",
190202
"user-name": "inlineRenamed",
191203
version: "8.5",
@@ -194,7 +206,7 @@ Mocha.describe("Record_rest_test", () => {
194206
version: "8.5",
195207
debug: true
196208
});
197-
Test_utils.eq("File \"record_rest_test.res\", line 212, characters 6-13", getRenamedInlineWrappedRest({
209+
Test_utils.eq("File \"record_rest_test.res\", line 224, characters 6-13", getRenamedInlineWrappedRest({
198210
TAG: "RenamedInlineMirror",
199211
"user-name": "inlineRenamed2",
200212
version: "8.6",
@@ -205,7 +217,7 @@ Mocha.describe("Record_rest_test", () => {
205217
});
206218
});
207219
Mocha.test("inline record variant rest removes a custom runtime tag field", () => {
208-
Test_utils.eq("File \"record_rest_test.res\", line 222, characters 6-13", getCustomTaggedInlineWrappedRest({
220+
Test_utils.eq("File \"record_rest_test.res\", line 234, characters 6-13", getCustomTaggedInlineWrappedRest({
209221
kind: "CustomInlineWrap",
210222
name: "customInline",
211223
version: "9.0",
@@ -214,7 +226,7 @@ Mocha.describe("Record_rest_test", () => {
214226
version: "9.0",
215227
debug: true
216228
});
217-
Test_utils.eq("File \"record_rest_test.res\", line 229, characters 6-13", getCustomTaggedInlineWrappedRest({
229+
Test_utils.eq("File \"record_rest_test.res\", line 241, characters 6-13", getCustomTaggedInlineWrappedRest({
218230
kind: "CustomInlineMirror",
219231
name: "customInlineMirror",
220232
version: "10.0",
@@ -225,7 +237,7 @@ Mocha.describe("Record_rest_test", () => {
225237
});
226238
});
227239
Mocha.test("inline record rest works with a non-identifier custom tag name", () => {
228-
Test_utils.eq("File \"record_rest_test.res\", line 239, characters 6-13", getDashedTaggedInlineWrappedRest({
240+
Test_utils.eq("File \"record_rest_test.res\", line 251, characters 6-13", getDashedTaggedInlineWrappedRest({
229241
"custom-tag": "DashedInlineWrap",
230242
name: "dashedInline",
231243
version: "11.0",
@@ -234,7 +246,7 @@ Mocha.describe("Record_rest_test", () => {
234246
version: "11.0",
235247
debug: true
236248
});
237-
Test_utils.eq("File \"record_rest_test.res\", line 246, characters 6-13", getDashedTaggedInlineWrappedRest({
249+
Test_utils.eq("File \"record_rest_test.res\", line 258, characters 6-13", getDashedTaggedInlineWrappedRest({
238250
"custom-tag": "DashedInlineMirror",
239251
name: "dashedInlineMirror",
240252
version: "12.0",
@@ -248,6 +260,7 @@ Mocha.describe("Record_rest_test", () => {
248260

249261
export {
250262
describeConfig,
263+
getAliasedRest,
251264
getRenamedRest,
252265
getName,
253266
getWholeConfig,

0 commit comments

Comments
 (0)