diff --git a/CHANGELOG.md b/CHANGELOG.md index 59c54f3b0d..75393e7b6b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,7 @@ #### :rocket: New Feature - Untagged variants: consider regexp as an object type. https://github.com/rescript-lang/rescript-compiler/pull/6296 - Semantic-based optimization of code generated for untagged variants https://github.com/rescript-lang/rescript-compiler/issues/6108 +- Record type spreads: Allow using type variables in type spreads. Both uninstantiated and instantiated ones https://github.com/rescript-lang/rescript-compiler/pull/6309 # 11.0.0-beta.2 diff --git a/jscomp/build_tests/super_errors/expected/record_type_spreads_deep_sub.res.expected b/jscomp/build_tests/super_errors/expected/record_type_spreads_deep_sub.res.expected new file mode 100644 index 0000000000..da6b670d0d --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/record_type_spreads_deep_sub.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/record_type_spreads_deep_sub.res:8:9-21 + + 6 │ + 7 │ let d: d = { + 8 │ x: Ok("this errors"), + 9 │ } + 10 │ + + This has type: string + Somewhere wanted: int + + You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/record_type_spreads_deep_sub.res b/jscomp/build_tests/super_errors/fixtures/record_type_spreads_deep_sub.res new file mode 100644 index 0000000000..82681095bc --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/record_type_spreads_deep_sub.res @@ -0,0 +1,9 @@ +// Checks that deep subsitution works as intended +type t<'a, 'b> = {x: result<'a, 'b>} +type d = { + ...t, +} + +let d: d = { + x: Ok("this errors"), +} diff --git a/jscomp/ml/record_type_spread.ml b/jscomp/ml/record_type_spread.ml new file mode 100644 index 0000000000..76cc710f63 --- /dev/null +++ b/jscomp/ml/record_type_spread.ml @@ -0,0 +1,88 @@ +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 -> {t with desc = Tlink (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, ref Types.Mnil)} + | Tsubst t -> {t with desc = Tsubst (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 + +let substitute_type_vars (type_vars : (string * Types.type_expr) list) + (typ : Types.type_expr) = + 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 + +let has_type_spread (lbls : Typedtree.label_declaration list) = + lbls + |> List.exists (fun (l : Typedtree.label_declaration) -> + match l with + | {ld_name = {txt = "..."}} -> true + | _ -> false) + +let extract_type_vars (type_params : Types.type_expr list) + (typ : Types.type_expr) = + (* The type variables applied to the record spread itself. *) + let applied_type_vars = + match Ctype.repr typ with + | {desc = Tpoly ({desc = Tconstr (_, tvars, _)}, _)} -> tvars + | _ -> [] + in + if List.length type_params = List.length applied_type_vars then + (* Track which type param in the record we're spreading + belongs to which type variable applied to the spread itself. *) + let paired_type_vars = List.combine type_params applied_type_vars in + paired_type_vars + |> List.filter_map (fun (t, applied_tvar) -> + match t.Types.desc with + | Tvar (Some tname) -> Some (tname, applied_tvar) + | _ -> None) + else [] \ No newline at end of file diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 4401bc6015..a9f63da5be 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -425,29 +425,38 @@ let transl_declaration ~typeRecordAsObject env sdecl id = else typ in {lbl with pld_type = typ }) in let lbls, lbls' = transl_labels env true lbls in - let has_spread = - lbls - |> List.exists (fun l -> - match l with - | {ld_name = {txt = "..."}} -> true - | _ -> false) in - let lbls_opt = match has_spread with + 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) : 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 = + { + 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 = Record_type_spread.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 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)}) -> - 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}) -> + 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' diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 98f2abbcea..7f0c61958c 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -10,12 +10,42 @@ function getX(v) { return v.x; } +var DeepSub = { + d: { + x: { + TAG: "Ok", + _0: 1 + }, + z: { + NAME: "Two", + VAL: 1 + } + } +}; + var v = { y: 3, x: 3 }; +var d = { + a: "", + b: 1, + c: undefined, + d: { + TAG: "Ok", + _0: 1 + } +}; + +var x = { + c: "hello" +}; + exports.getY = getY; exports.getX = getX; exports.v = v; +exports.d = d; +exports.x = x; +exports.DeepSub = DeepSub; /* No side effect */ diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index 7e74c7e4c4..ee373fb1ca 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -9,3 +9,53 @@ 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>, +} + +type d<'a> = { + ...f<'a>, +} + +let d: d = { + a: "", + b: 1, + c: None, + d: Some(Ok(1)), +} + +type rn<'aaa> = {c: option<'aaa>} + +type withRenamedTypeVariable<'bbb> = { + ...rn<'bbb>, +} + +let x: withRenamedTypeVariable = { + c: Some(true), +} + +type rnAsString = { + ...rn, +} + +let x: rnAsString = { + c: Some("hello"), +} + +module DeepSub = { + type t<'a, 'b> = { + x: result<'a, 'b>, + z: [#One | #Two('a) | #Three('b)], + } + type d = { + ...t, + } + let d: d = { + x: Ok(1), + z: #Two(1), + } +}