Support record spreads in inline records

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
 

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 []
+  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'))

jscomp/ml/typedecl.ml

@@ -244,15 +244,15 @@ 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 ->
       let l = List.map (transl_simple_type env closed) l in
       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

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,19 +5014,15 @@ 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)
     | _ ->
       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 =

jscomp/test/record_type_spread.res

@@ -59,3 +59,16 @@ module DeepSub = {
     z: #Two(1),
   }
 }
+
+type base = {
+  id: string,
+  name?: string,
+}
+
+type inlineRecord = One({first: string, ...base})
+
+let o = One({first: "1", id: "1"})
+
+type inlineRecordSingleSpread = OneSingle({...base})
+
+let o2 = OneSingle({id: "1"})