Allow type variables when spreading record type definitions

jscomp/ml/record_spread.ml

@@ -0,0 +1,51 @@
+module StringMap = Map.Make (String)
+
+let t_equals t1 t2  = t1.Types.level = t2.Types.level && t1.id = t2.id
+
+let substitute_types ~type_map (t : Types.type_expr) =
+  if StringMap.is_empty type_map then t
+  else
+    let apply_substitution type_variable_name t =
+      match StringMap.find_opt type_variable_name type_map with 
+      | None -> t
+      | Some substituted_type -> substituted_type
+    in
+    let rec loop (t : Types.type_expr) =
+      match t.desc with
+      | Tlink t -> loop t
+      | Tvar Some type_variable_name -> apply_substitution type_variable_name t
+      | Tvar None -> t
+      | Tunivar _ -> t
+      | Tconstr (path, args, memo) ->
+        {t with desc = Tconstr (path, args |> List.map loop, memo)}
+      | Tsubst t -> loop t
+      | Tvariant rd -> {t with desc = Tvariant (row_desc rd)}
+      | Tnil -> t
+      | Tarrow (lbl, t1, t2, c) ->
+        {t with desc = Tarrow (lbl, loop t1, loop t2, c)}
+      | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)}
+      | Tobject (t, r) -> {t with desc = Tobject (loop t, r)}
+      | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)}
+      | Tpoly (t, []) -> loop t
+      | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)}
+      | Tpackage (p, l, tl) ->
+        {t with desc = Tpackage (p, l, tl |> List.map loop)}
+    and row_desc (rd : Types.row_desc) =
+      let row_fields =
+        rd.row_fields |> List.map (fun (l, rf) -> (l, row_field rf))
+      in
+      let row_more = loop rd.row_more in
+      let row_name =
+        match rd.row_name with
+        | None -> None
+        | Some (p, tl) -> Some (p, tl |> List.map loop)
+      in
+      {rd with row_fields; row_more; row_name}
+    and row_field (rf : Types.row_field) =
+      match rf with
+      | Rpresent None -> rf
+      | Rpresent (Some t) -> Rpresent (Some (loop t))
+      | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r)
+      | Rabsent -> Rabsent
+    in
+    loop t

jscomp/ml/typedecl.ml

@@ -433,21 +433,57 @@ let transl_declaration ~typeRecordAsObject env sdecl id =
                    | _ -> false) in
           let lbls_opt = match has_spread with
             | true ->
+              let substitute_type_vars type_vars typ =
+                let open Record_spread in
+                let type_map = type_vars |> List.fold_left (fun acc (tvar_name, tvar_typ) -> StringMap.add tvar_name tvar_typ acc) StringMap.empty in
+                substitute_types ~type_map typ in
               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) : Typedtree.label_declaration =
-                { ld_id = l.ld_id;
+              let mkLbl (l: Types.label_declaration) (ld_type: Typedtree.core_type) (type_vars: (string * Types.type_expr) list) : Typedtree.label_declaration =
+                let lbl = {
+                  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 = l.ld_type};
+                  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
+                  ld_attributes = l.ld_attributes;
+                } in
+                lbl in
               let rec process_lbls acc lbls lbls' = match lbls, lbls' with
                 | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' ->
+                  (* The type variables applied to the record spread itself. *)
+                  let applied_type_vars =
+                    match Ctype.repr ld_type.ctyp_type with
+                    | {desc = Tpoly ({desc = Tconstr (_, tvars, _)}, _)} -> tvars
+                    | _ -> [] in
                   (match Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) with
-                    (_p0, _p, {type_kind=Type_record (fields, _repr)}) ->
-                      process_lbls (fst acc @ (fields |> List.map (fun l -> mkLbl l ld_type)), snd acc @ fields) rest rest'
+                    (_p0, _p, {type_kind=Type_record (fields, _repr); type_params}) ->
+                      (* Track which type param in the record we're spreading 
+                         belongs to which type variable applied to the spread itself. *)
+                      let idx = ref 0 in
+                      let type_vars =
+                        type_params
+                        |> List.filter_map (fun t ->
+                               let index = !idx in
+                               idx := index + 1;
+                               match t.desc with
+                               | Tvar (Some tname) -> (
+                                 match List.nth_opt applied_type_vars index with
+                                 | None -> None
+                                 | Some t -> Some (tname, t))
+                               | _ -> None) in
+                      process_lbls
+                        ( fst acc @ (fields |> List.map (fun l -> mkLbl l ld_type type_vars)),
+                          snd acc
+                          @ (fields
+                            |> List.map (fun (l : Types.label_declaration) ->
+                                  {
+                                    l with
+                                    ld_type =
+                                      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'
@@ -1356,7 +1392,7 @@ let transl_type_decl env rec_flag sdecl_list =
     (fun sdecl tdecl ->
       let decl = tdecl.typ_type in
        match Ctype.closed_type_decl decl with
-         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+       | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
        | None   -> ())
     sdecl_list tdecls;
   (* Check that constraints are enforced *)

jscomp/test/record_type_spread.res

@@ -9,3 +9,39 @@ let getY = (v: y) => v.y
 let getX = (v: y) => v.x
 
 let v: y = {y: 3, x: 3}
+
+type f<'a> = {
+  a: string,
+  b: 'a,
+  c: option<'a>,
+  d: option<result<'a, 'a>>,
+}
+
+type d<'a> = {
+  ...f<'a>,
+}
+
+let d: d<int> = {
+  a: "",
+  b: 1,
+  c: None,
+  d: Some(Ok(1)),
+}
+
+type rn<'aaa> = {c: option<'aaa>}
+
+type withRenamedTypeVariable<'bbb> = {
+  ...rn<'bbb>,
+}
+
+let x: withRenamedTypeVariable<bool> = {
+  c: Some(true),
+}
+
+type rnAsString = {
+  ...rn<string>,
+}
+
+let x: rnAsString = {
+  c: Some("hello"),
+}