Skip to content

Commit d117851

Browse files
committed
support record spreads in inline records by applying record type spread logic at a more central place
1 parent 062c387 commit d117851

File tree

4 files changed

+74
-47
lines changed

4 files changed

+74
-47
lines changed

jscomp/ml/record_type_spread.ml

Lines changed: 52 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -85,4 +85,55 @@ let extract_type_vars (type_params : Types.type_expr list)
8585
match t.Types.desc with
8686
| Tvar (Some tname) -> Some (tname, applied_tvar)
8787
| _ -> None)
88-
else []
88+
else []
89+
90+
let expand_record_spreads env lbls lbls' =
91+
(* This tracks whether there are type spreads that doesn't seem to be records.
92+
Some parts of the code needs this to handle a syntax ambiguitiy between record
93+
and object type spreads.*)
94+
let might_have_object_spreads = ref false in
95+
if has_type_spread lbls then
96+
let rec extract (t : Types.type_expr) =
97+
match t.desc with
98+
| Tpoly (t, []) -> extract t
99+
| _ -> Ctype.repr t
100+
in
101+
let mkLbl (l : Types.label_declaration) (ld_type : Typedtree.core_type)
102+
(type_vars : (string * Types.type_expr) list) :
103+
Typedtree.label_declaration =
104+
{
105+
ld_id = l.ld_id;
106+
ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc};
107+
ld_mutable = l.ld_mutable;
108+
ld_type =
109+
{ld_type with ctyp_type = substitute_type_vars type_vars l.ld_type};
110+
ld_loc = l.ld_loc;
111+
ld_attributes = l.ld_attributes;
112+
}
113+
in
114+
let rec process_lbls acc lbls lbls' =
115+
match (lbls, lbls') with
116+
| {Typedtree.ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> (
117+
match
118+
Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type)
119+
with
120+
| _p0, _p, {type_kind = Type_record (fields, _repr); type_params} ->
121+
let type_vars = extract_type_vars type_params ld_type.ctyp_type in
122+
process_lbls
123+
( fst acc @ Ext_list.map fields (fun l -> mkLbl l ld_type type_vars),
124+
snd acc
125+
@ Ext_list.map fields (fun l ->
126+
{l with ld_type = substitute_type_vars type_vars l.ld_type})
127+
)
128+
rest rest'
129+
| _ -> assert false
130+
| exception _ ->
131+
might_have_object_spreads := true;
132+
acc)
133+
| lbl :: rest, lbl' :: rest' ->
134+
process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest'
135+
| _ -> acc
136+
in
137+
let lbls, lbls' = process_lbls ([], []) lbls lbls' in
138+
(!might_have_object_spreads, (lbls, lbls'))
139+
else (!might_have_object_spreads, (lbls, lbls'))

jscomp/ml/typedecl.ml

Lines changed: 6 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -244,15 +244,15 @@ let transl_labels env closed lbls =
244244
}
245245
)
246246
lbls in
247-
lbls, lbls'
247+
Record_type_spread.expand_record_spreads env lbls lbls'
248248

249249
let transl_constructor_arguments env closed = function
250250
| Pcstr_tuple l ->
251251
let l = List.map (transl_simple_type env closed) l in
252252
Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
253253
Cstr_tuple l
254254
| Pcstr_record l ->
255-
let lbls, lbls' = transl_labels env closed l in
255+
let _, (lbls, lbls') = transl_labels env closed l in
256256
Types.Cstr_record lbls',
257257
Cstr_record lbls
258258

@@ -501,54 +501,14 @@ let transl_declaration ~typeRecordAsObject env sdecl id =
501501
{typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])}
502502
else typ in
503503
{lbl with pld_type = typ }) in
504-
let lbls, lbls' = transl_labels env true lbls in
505-
let lbls_opt = match Record_type_spread.has_type_spread lbls with
506-
| true ->
507-
let rec extract t = match t.desc with
508-
| Tpoly(t, []) -> extract t
509-
| _ -> Ctype.repr t in
510-
let mkLbl (l: Types.label_declaration) (ld_type: Typedtree.core_type) (type_vars: (string * Types.type_expr) list) : Typedtree.label_declaration =
511-
{
512-
ld_id = l.ld_id;
513-
ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc};
514-
ld_mutable = l.ld_mutable;
515-
ld_type = {ld_type with ctyp_type = Record_type_spread.substitute_type_vars type_vars l.ld_type};
516-
ld_loc = l.ld_loc;
517-
ld_attributes = l.ld_attributes;
518-
} in
519-
let rec process_lbls acc lbls lbls' = match lbls, lbls' with
520-
| {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' ->
521-
(match Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) with
522-
(_p0, _p, {type_kind=Type_record (fields, _repr); type_params}) ->
523-
let type_vars = Record_type_spread.extract_type_vars type_params ld_type.ctyp_type in
524-
process_lbls
525-
( fst acc
526-
@ (Ext_list.map fields (fun l ->
527-
mkLbl l ld_type type_vars))
528-
,
529-
snd acc
530-
@ (Ext_list.map fields (fun l ->
531-
{
532-
l with
533-
ld_type =
534-
Record_type_spread.substitute_type_vars type_vars l.ld_type;
535-
})) )
536-
rest rest'
537-
| _ -> assert false
538-
| exception _ -> None)
539-
| lbl::rest, lbl'::rest' -> process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest'
540-
| _ -> Some acc
541-
in
542-
process_lbls ([], []) lbls lbls'
543-
| false -> Some (lbls, lbls') in
504+
let might_have_object_spreads, (lbls, lbls') = transl_labels env true lbls in
544505
let rec check_duplicates loc (lbls : Typedtree.label_declaration list) seen = match lbls with
545506
| [] -> ()
546507
| lbl::rest ->
547508
let name = lbl.ld_id.name in
548509
if StringSet.mem name seen then raise(Error(loc, Duplicate_label name));
549510
check_duplicates loc rest (StringSet.add name seen) in
550-
(match lbls_opt with
551-
| Some (lbls, lbls') ->
511+
(if might_have_object_spreads = false then (
552512
check_duplicates sdecl.ptype_loc lbls StringSet.empty;
553513
let optionalLabels =
554514
Ext_list.filter_map lbls (fun lbl ->
@@ -559,7 +519,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id =
559519
else if optionalLabels <> [] then
560520
Record_optional_labels optionalLabels
561521
else Record_regular), sdecl
562-
| None ->
522+
) else (
563523
(* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *)
564524
typeRecordAsObject := true;
565525
let fields = Ext_list.map lbls_ (fun ld ->
@@ -571,7 +531,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id =
571531
ptype_kind = Ptype_abstract;
572532
ptype_manifest = Some (Ast_helper.Typ.object_ ~loc:sdecl.ptype_loc fields Closed);
573533
} in
574-
(Ttype_abstract, Type_abstract, sdecl))
534+
(Ttype_abstract, Type_abstract, sdecl)))
575535
| Ptype_open -> Ttype_open, Type_open, sdecl
576536
in
577537
let (tman, man) = match sdecl.ptype_manifest with

jscomp/test/record_type_spread.js

Lines changed: 7 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

jscomp/test/record_type_spread.res

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,3 +59,12 @@ module DeepSub = {
5959
z: #Two(1),
6060
}
6161
}
62+
63+
type base = {
64+
id: string,
65+
name?: string,
66+
}
67+
68+
type inlineRecord = One({first: string, ...base})
69+
70+
let o = One({first: "1", id: "1"})

0 commit comments

Comments
 (0)