From d117851eefc54dd23e4286471933dbc56c96f213 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 10 Jul 2023 15:42:27 +0200 Subject: [PATCH 1/3] support record spreads in inline records by applying record type spread logic at a more central place --- jscomp/ml/record_type_spread.ml | 53 +++++++++++++++++++++++++++++- jscomp/ml/typedecl.ml | 52 ++++------------------------- jscomp/test/record_type_spread.js | 7 ++++ jscomp/test/record_type_spread.res | 9 +++++ 4 files changed, 74 insertions(+), 47 deletions(-) diff --git a/jscomp/ml/record_type_spread.ml b/jscomp/ml/record_type_spread.ml index 76cc710f63..b315632348 100644 --- a/jscomp/ml/record_type_spread.ml +++ b/jscomp/ml/record_type_spread.ml @@ -85,4 +85,55 @@ let extract_type_vars (type_params : Types.type_expr list) match t.Types.desc with | Tvar (Some tname) -> Some (tname, applied_tvar) | _ -> None) - else [] \ No newline at end of file + else [] + +let expand_record_spreads env lbls lbls' = + (* This tracks whether there are type spreads that doesn't seem to be records. + Some parts of the code needs this to handle a syntax ambiguitiy between record + and object type spreads.*) + let might_have_object_spreads = ref false in + if has_type_spread lbls then + let rec extract (t : Types.type_expr) = + match t.desc with + | Tpoly (t, []) -> extract t + | _ -> Ctype.repr t + in + let mkLbl (l : Types.label_declaration) (ld_type : Typedtree.core_type) + (type_vars : (string * Types.type_expr) list) : + Typedtree.label_declaration = + { + ld_id = l.ld_id; + ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; + ld_mutable = l.ld_mutable; + ld_type = + {ld_type with ctyp_type = substitute_type_vars type_vars l.ld_type}; + ld_loc = l.ld_loc; + ld_attributes = l.ld_attributes; + } + in + let rec process_lbls acc lbls lbls' = + match (lbls, lbls') with + | {Typedtree.ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> ( + match + Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) + with + | _p0, _p, {type_kind = Type_record (fields, _repr); type_params} -> + let type_vars = extract_type_vars type_params ld_type.ctyp_type in + process_lbls + ( fst acc @ Ext_list.map fields (fun l -> mkLbl l ld_type type_vars), + snd acc + @ Ext_list.map fields (fun l -> + {l with ld_type = substitute_type_vars type_vars l.ld_type}) + ) + rest rest' + | _ -> assert false + | exception _ -> + might_have_object_spreads := true; + acc) + | lbl :: rest, lbl' :: rest' -> + process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' + | _ -> acc + in + let lbls, lbls' = process_lbls ([], []) lbls lbls' in + (!might_have_object_spreads, (lbls, lbls')) + else (!might_have_object_spreads, (lbls, lbls')) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index fde833ee31..1425c3ac39 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -244,7 +244,7 @@ let transl_labels env closed lbls = } ) lbls in - lbls, lbls' + Record_type_spread.expand_record_spreads env lbls lbls' let transl_constructor_arguments env closed = function | Pcstr_tuple l -> @@ -252,7 +252,7 @@ let transl_constructor_arguments env closed = function Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), Cstr_tuple l | Pcstr_record l -> - let lbls, lbls' = transl_labels env closed l in + let _, (lbls, lbls') = transl_labels env closed l in Types.Cstr_record lbls', Cstr_record lbls @@ -501,54 +501,14 @@ let transl_declaration ~typeRecordAsObject env sdecl id = {typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])} else typ in {lbl with pld_type = typ }) in - let lbls, lbls' = transl_labels env true lbls in - let lbls_opt = match Record_type_spread.has_type_spread lbls with - | true -> - let rec extract t = match t.desc with - | Tpoly(t, []) -> extract t - | _ -> Ctype.repr t in - let mkLbl (l: Types.label_declaration) (ld_type: Typedtree.core_type) (type_vars: (string * Types.type_expr) list) : Typedtree.label_declaration = - { - ld_id = l.ld_id; - ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; - ld_mutable = l.ld_mutable; - ld_type = {ld_type with ctyp_type = Record_type_spread.substitute_type_vars type_vars l.ld_type}; - ld_loc = l.ld_loc; - ld_attributes = l.ld_attributes; - } in - let rec process_lbls acc lbls lbls' = match lbls, lbls' with - | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> - (match Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) with - (_p0, _p, {type_kind=Type_record (fields, _repr); type_params}) -> - let type_vars = Record_type_spread.extract_type_vars type_params ld_type.ctyp_type in - process_lbls - ( fst acc - @ (Ext_list.map fields (fun l -> - mkLbl l ld_type type_vars)) - , - snd acc - @ (Ext_list.map fields (fun l -> - { - l with - ld_type = - Record_type_spread.substitute_type_vars type_vars l.ld_type; - })) ) - rest rest' - | _ -> assert false - | exception _ -> None) - | lbl::rest, lbl'::rest' -> process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' - | _ -> Some acc - in - process_lbls ([], []) lbls lbls' - | false -> Some (lbls, lbls') in + let might_have_object_spreads, (lbls, lbls') = transl_labels env true lbls in let rec check_duplicates loc (lbls : Typedtree.label_declaration list) seen = match lbls with | [] -> () | lbl::rest -> let name = lbl.ld_id.name in if StringSet.mem name seen then raise(Error(loc, Duplicate_label name)); check_duplicates loc rest (StringSet.add name seen) in - (match lbls_opt with - | Some (lbls, lbls') -> + (if might_have_object_spreads = false then ( check_duplicates sdecl.ptype_loc lbls StringSet.empty; let optionalLabels = Ext_list.filter_map lbls (fun lbl -> @@ -559,7 +519,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = else if optionalLabels <> [] then Record_optional_labels optionalLabels else Record_regular), sdecl - | None -> + ) else ( (* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *) typeRecordAsObject := true; let fields = Ext_list.map lbls_ (fun ld -> @@ -571,7 +531,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = ptype_kind = Ptype_abstract; ptype_manifest = Some (Ast_helper.Typ.object_ ~loc:sdecl.ptype_loc fields Closed); } in - (Ttype_abstract, Type_abstract, sdecl)) + (Ttype_abstract, Type_abstract, sdecl))) | Ptype_open -> Ttype_open, Type_open, sdecl in let (tman, man) = match sdecl.ptype_manifest with diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 7f0c61958c..3f13ac35e4 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -42,10 +42,17 @@ var x = { c: "hello" }; +var o = { + TAG: "One", + first: "1", + id: "1" +}; + exports.getY = getY; exports.getX = getX; exports.v = v; exports.d = d; exports.x = x; exports.DeepSub = DeepSub; +exports.o = o; /* No side effect */ diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index ee373fb1ca..e5fb6e0723 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -59,3 +59,12 @@ module DeepSub = { z: #Two(1), } } + +type base = { + id: string, + name?: string, +} + +type inlineRecord = One({first: string, ...base}) + +let o = One({first: "1", id: "1"}) From ce58ff92b22f5a4c4432f49769dedd8630cfabae Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 30 Jul 2023 21:29:42 +0200 Subject: [PATCH 2/3] parse single spreads in variant payloads as inline records with single spread --- jscomp/syntax/src/res_core.ml | 82 ++++++++++++++---------------- jscomp/test/record_type_spread.js | 6 +++ jscomp/test/record_type_spread.res | 4 ++ 3 files changed, 48 insertions(+), 44 deletions(-) diff --git a/jscomp/syntax/src/res_core.ml b/jscomp/syntax/src/res_core.ml index e15f1e66e0..394cb7c30b 100644 --- a/jscomp/syntax/src/res_core.ml +++ b/jscomp/syntax/src/res_core.ml @@ -134,10 +134,6 @@ module ErrorMessages = struct let stringInterpolationInPattern = "String interpolation is not supported in pattern matching." - let spreadInRecordDeclaration = - "A record type declaration doesn't support the ... spread. Only an object \ - (with quoted field names) does." - let objectQuotedFieldName name = "An object type declaration needs quoted field names. Did you mean \"" ^ name ^ "\"?" @@ -482,6 +478,11 @@ let lidentOfPath longident = | [] -> "" | ident :: _ -> ident +let makeRecordDotField ~dotdotdotStart ~dotdotdotEnd ~loc typ = + Ast_helper.Type.field ~loc + {txt = "..."; loc = mkLoc dotdotdotStart dotdotdotEnd} + typ + let makeNewtypes ~attrs ~loc newtypes exp = let expr = List.fold_right @@ -4579,40 +4580,37 @@ and parseConstrDeclArgs p = (* start of object type spreading, e.g. `User({...a, "u": int})` *) Parser.next p; let typ = parseTypExpr p in - let () = - match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.next p - | _ -> Parser.expect Comma p - in - let () = - match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () - in - let fields = - Parsetree.Oinherit typ - :: parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc fields Asttypes.Closed - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) + (* always treat single spreads as records *) + let isSingleSpread = p.token = Rbrace in + if isSingleSpread then ( + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let dotField = + typ |> makeRecordDotField ~loc ~dotdotdotStart ~dotdotdotEnd + in + Parser.expect Rparen p; + Parsetree.Pcstr_record [dotField]) + else + let fields = + Parsetree.Oinherit typ + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) | _ -> ( let attrs = parseAttributes p in match p.Parser.token with @@ -5016,9 +5014,7 @@ and parseRecordOrObjectDecl p = Parser.next p; let loc = mkLoc startPos p.prevEndPos in let dotField = - Ast_helper.Type.field ~loc - {txt = "..."; loc = mkLoc dotdotdotStart dotdotdotEnd} - typ + typ |> makeRecordDotField ~loc ~dotdotdotStart ~dotdotdotEnd in let kind = Parsetree.Ptype_record [dotField] in (None, Public, kind) @@ -5026,9 +5022,7 @@ and parseRecordOrObjectDecl p = Parser.expect Comma p; let loc = mkLoc startPos p.prevEndPos in let dotField = - Ast_helper.Type.field ~loc - {txt = "..."; loc = mkLoc dotdotdotStart dotdotdotEnd} - typ + typ |> makeRecordDotField ~loc ~dotdotdotStart ~dotdotdotEnd in let foundObjectField = ref false in let fields = diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 3f13ac35e4..0be4ac0775 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -48,6 +48,11 @@ var o = { id: "1" }; +var o2 = { + TAG: "OneSingle", + id: "1" +}; + exports.getY = getY; exports.getX = getX; exports.v = v; @@ -55,4 +60,5 @@ exports.d = d; exports.x = x; exports.DeepSub = DeepSub; exports.o = o; +exports.o2 = o2; /* No side effect */ diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index e5fb6e0723..d46863da3a 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -68,3 +68,7 @@ type base = { type inlineRecord = One({first: string, ...base}) let o = One({first: "1", id: "1"}) + +type inlineRecordSingleSpread = OneSingle({...base}) + +let o2 = OneSingle({id: "1"}) From 7b67f9ba5e0fdf6fd016f36fff068d9137f313bc Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 30 Jul 2023 21:31:03 +0200 Subject: [PATCH 3/3] changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index fba92ae26f..6ecf25f5d7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,7 @@ #### :rocket: New Feature - GenType: Propagate comments from record fields to emitted TypeScript types. https://github.com/rescript-lang/rescript-compiler/pull/6333 +- Variant payloads: Allow spreading record definitions into inline records in variant payloads. https://github.com/rescript-lang/rescript-compiler/pull/6326 #### :boom: Breaking Change