From 7f3bbcb665ddfba58811aa5740010c65999e1b79 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 22 Jun 2023 19:55:50 +0200 Subject: [PATCH 01/14] exploration --- jscomp/ml/typedecl.ml | 49 ++++++++++++++++++++++++------ jscomp/test/record_type_spread.js | 7 +++++ jscomp/test/record_type_spread.res | 15 +++++++++ 3 files changed, 61 insertions(+), 10 deletions(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 4401bc6015..be446b2e1e 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -36,7 +36,7 @@ type error = | Type_clash of Env.t * (type_expr * type_expr) list | Parameters_differ of Path.t * type_expr * type_expr | Null_arity_external - | Unbound_type_var of type_expr * type_declaration + | Unbound_type_var of type_expr * type_declaration * string | Cannot_extend_private_type of Path.t | Not_extensible_type of Path.t | Extension_mismatch of Path.t * Includecore.type_mismatch list @@ -436,18 +436,47 @@ let transl_declaration ~typeRecordAsObject env sdecl id = 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: 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 = + (if sdecl.ptype_name.txt = "d" then ( + print_endline "type vars: "; (type_vars |> List.iter(Format.eprintf "tvar @[%a@]@." Printtyp.raw_type_expr)); + Format.eprintf "#1 @[%a@]@." Printtyp.raw_type_expr l.ld_type; + let new_ty = + match l.ld_type with + | ({desc = Tvar (Some tvar_name)} | {desc = Tlink({desc=Tvar (Some tvar_name)})}) -> ( + print_endline ("tvarname:" ^ tvar_name); + match + type_vars + |> List.find_opt (fun t -> + Format.eprintf "t: @[%a@]@." Printtyp.raw_type_expr t; + match t.desc with + | (Tvar (Some n) | Tlink ({desc=Tvar (Some n)})) when n = tvar_name -> true + | _ -> false) + with + | None -> print_endline "no tvar"; {ld_type with ctyp_type = l.ld_type} + | Some tvar -> print_endline "found tvar"; {ld_type with ctyp_type = tvar}) + | _ -> print_endline "no typ"; print_endline (match l.ld_type.desc with | Tlink _ -> "Tlink" | _ -> "-"); {ld_type with ctyp_type = l.ld_type} + in + Format.eprintf "#2 @[%a@]@." Printtyp.raw_type_expr new_ty.ctyp_type; + new_ty) + else {ld_type with ctyp_type = 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' -> + let type_vars = + match 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' + process_lbls (fst acc @ (fields |> List.map (fun l -> mkLbl l ld_type type_vars)), snd acc @ fields) rest rest' | _ -> assert false | exception _ -> None) | lbl::rest, lbl'::rest' -> process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' @@ -1356,7 +1385,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, "#2"))) | None -> ()) sdecl_list tdecls; (* Check that constraints are enforced *) @@ -1790,7 +1819,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = | Some p -> set_fixed_row env sdecl.ptype_loc p decl end; begin match Ctype.closed_type_decl decl with None -> () - | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) + | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl, "not closed #1"))) end; let decl = name_recursion sdecl id decl in let type_variance = @@ -1946,8 +1975,8 @@ let report_error ppf = function fprintf ppf "but is used here with type") | Null_arity_external -> fprintf ppf "External identifiers must be functions" - | Unbound_type_var (ty, decl) -> - fprintf ppf "A type variable is unbound in this type declaration"; + | Unbound_type_var (ty, decl, s) -> + fprintf ppf "A type variable is unbound in this type declaration: %s" s; let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 98f2abbcea..12aea82ea7 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -15,7 +15,14 @@ var v = { x: 3 }; +var d = { + a: "", + b: 1, + c: 1 +}; + exports.getY = getY; exports.getX = getX; exports.v = v; +exports.d = d; /* No side effect */ diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index 7e74c7e4c4..9983709b3a 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -9,3 +9,18 @@ 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, +} + +type d<'a> = { + ...f<'a>, +} + +let d: d = { + a: "", + b: 1, + c: 1, +} From e2c07c5b5251332df14dceb01c7234a5fbfa765d Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 22 Jun 2023 21:58:06 +0200 Subject: [PATCH 02/14] simple substitution of type parameters, and some cleanup --- jscomp/ml/typedecl.ml | 60 ++++++++++++++++-------------- jscomp/test/record_type_spread.js | 3 +- jscomp/test/record_type_spread.res | 1 - 3 files changed, 33 insertions(+), 31 deletions(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index be446b2e1e..dfaecfdb99 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -36,7 +36,7 @@ type error = | Type_clash of Env.t * (type_expr * type_expr) list | Parameters_differ of Path.t * type_expr * type_expr | Null_arity_external - | Unbound_type_var of type_expr * type_declaration * string + | Unbound_type_var of type_expr * type_declaration | Cannot_extend_private_type of Path.t | Not_extensible_type of Path.t | Extension_mismatch of Path.t * Includecore.type_mismatch list @@ -433,6 +433,18 @@ let transl_declaration ~typeRecordAsObject env sdecl id = | _ -> false) in let lbls_opt = match has_spread with | true -> + let substitute_type_vars type_vars typ = + match typ with + | {desc = Tvar (Some tvar_name)} + | {desc = Tlink {desc = Tvar (Some tvar_name)}} -> + type_vars + |> List.find_opt (fun t -> + match t.desc with + | (Tvar (Some n) | Tlink {desc = Tvar (Some n)}) when n = tvar_name + -> + true + | _ -> false) + | _ -> None in let rec extract t = match t.desc with | Tpoly(t, []) -> extract t | _ -> Ctype.repr t in @@ -442,28 +454,9 @@ let transl_declaration ~typeRecordAsObject env sdecl id = ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; ld_mutable = l.ld_mutable; ld_type = - (if sdecl.ptype_name.txt = "d" then ( - print_endline "type vars: "; (type_vars |> List.iter(Format.eprintf "tvar @[%a@]@." Printtyp.raw_type_expr)); - Format.eprintf "#1 @[%a@]@." Printtyp.raw_type_expr l.ld_type; - let new_ty = - match l.ld_type with - | ({desc = Tvar (Some tvar_name)} | {desc = Tlink({desc=Tvar (Some tvar_name)})}) -> ( - print_endline ("tvarname:" ^ tvar_name); - match - type_vars - |> List.find_opt (fun t -> - Format.eprintf "t: @[%a@]@." Printtyp.raw_type_expr t; - match t.desc with - | (Tvar (Some n) | Tlink ({desc=Tvar (Some n)})) when n = tvar_name -> true - | _ -> false) - with - | None -> print_endline "no tvar"; {ld_type with ctyp_type = l.ld_type} - | Some tvar -> print_endline "found tvar"; {ld_type with ctyp_type = tvar}) - | _ -> print_endline "no typ"; print_endline (match l.ld_type.desc with | Tlink _ -> "Tlink" | _ -> "-"); {ld_type with ctyp_type = l.ld_type} - in - Format.eprintf "#2 @[%a@]@." Printtyp.raw_type_expr new_ty.ctyp_type; - new_ty) - else {ld_type with ctyp_type = l.ld_type}); + (match substitute_type_vars type_vars l.ld_type with + | None -> {ld_type with ctyp_type = l.ld_type} + | Some tvar -> {ld_type with ctyp_type = tvar}); ld_loc = l.ld_loc; ld_attributes = l.ld_attributes; } in @@ -476,7 +469,18 @@ let transl_declaration ~typeRecordAsObject env sdecl id = | _ -> [] 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 type_vars)), snd acc @ fields) rest rest' + 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 + |> Option.value ~default:l.ld_type; + })) ) + rest rest' | _ -> assert false | exception _ -> None) | lbl::rest, lbl'::rest' -> process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' @@ -1385,7 +1389,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, "#2"))) + | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) | None -> ()) sdecl_list tdecls; (* Check that constraints are enforced *) @@ -1819,7 +1823,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = | Some p -> set_fixed_row env sdecl.ptype_loc p decl end; begin match Ctype.closed_type_decl decl with None -> () - | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl, "not closed #1"))) + | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) end; let decl = name_recursion sdecl id decl in let type_variance = @@ -1975,8 +1979,8 @@ let report_error ppf = function fprintf ppf "but is used here with type") | Null_arity_external -> fprintf ppf "External identifiers must be functions" - | Unbound_type_var (ty, decl, s) -> - fprintf ppf "A type variable is unbound in this type declaration: %s" s; + | Unbound_type_var (ty, decl) -> + fprintf ppf "A type variable is unbound in this type declaration"; let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 12aea82ea7..d840115bfc 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -17,8 +17,7 @@ var v = { var d = { a: "", - b: 1, - c: 1 + b: 1 }; exports.getY = getY; diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index 9983709b3a..3602bcc947 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -22,5 +22,4 @@ type d<'a> = { let d: d = { a: "", b: 1, - c: 1, } From 3340f6c4c8c0842d8d9b086f2f83fc5c11425e8d Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 23 Jun 2023 22:23:23 +0200 Subject: [PATCH 03/14] do deep substitution of type variables --- jscomp/ml/record_spread.ml | 51 ++++++++++++++++++++++++++++++ jscomp/ml/typedecl.ml | 33 ++++++++----------- jscomp/test/record_type_spread.js | 7 +++- jscomp/test/record_type_spread.res | 4 +++ 4 files changed, 74 insertions(+), 21 deletions(-) create mode 100644 jscomp/ml/record_spread.ml diff --git a/jscomp/ml/record_spread.ml b/jscomp/ml/record_spread.ml new file mode 100644 index 0000000000..7df277739f --- /dev/null +++ b/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 \ No newline at end of file diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index dfaecfdb99..c90be7a773 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -434,29 +434,18 @@ let transl_declaration ~typeRecordAsObject env sdecl id = let lbls_opt = match has_spread with | true -> let substitute_type_vars type_vars typ = - match typ with - | {desc = Tvar (Some tvar_name)} - | {desc = Tlink {desc = Tvar (Some tvar_name)}} -> - type_vars - |> List.find_opt (fun t -> - match t.desc with - | (Tvar (Some n) | Tlink {desc = Tvar (Some n)}) when n = tvar_name - -> - true - | _ -> false) - | _ -> None in + 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) (type_vars: Types.type_expr list) : Typedtree.label_declaration = + 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 = - (match substitute_type_vars type_vars l.ld_type with - | None -> {ld_type with ctyp_type = l.ld_type} - | Some tvar -> {ld_type with ctyp_type = tvar}); + 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 @@ -464,8 +453,13 @@ let transl_declaration ~typeRecordAsObject env sdecl id = let rec process_lbls acc lbls lbls' = match lbls, lbls' with | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> let type_vars = - match ld_type.ctyp_type with - | {desc = Tpoly ({desc = Tconstr (_, tvars, _)}, _)} -> tvars + match Ctype.repr ld_type.ctyp_type with + | {desc = Tpoly ({desc = Tconstr (_, tvars, _)}, _)} -> + tvars + |> List.filter_map (fun tvar -> + match Ctype.repr tvar with + | {desc = Tvar (Some name)} -> Some (name, tvar) + | _ -> None) | _ -> [] in (match Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) with (_p0, _p, {type_kind=Type_record (fields, _repr)}) -> @@ -477,8 +471,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = { l with ld_type = - substitute_type_vars type_vars l.ld_type - |> Option.value ~default:l.ld_type; + substitute_type_vars type_vars l.ld_type; })) ) rest rest' | _ -> assert false diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index d840115bfc..088f919144 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -17,7 +17,12 @@ var v = { var d = { a: "", - b: 1 + b: 1, + c: undefined, + d: { + TAG: "Ok", + _0: 1 + } }; exports.getY = getY; diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index 3602bcc947..ab1ce179e8 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -13,6 +13,8 @@ let v: y = {y: 3, x: 3} type f<'a> = { a: string, b: 'a, + c: option<'a>, + d: option>, } type d<'a> = { @@ -22,4 +24,6 @@ type d<'a> = { let d: d = { a: "", b: 1, + c: None, + d: Some(Ok(1)), } From af3b0d058487120449cf23209f9bbf0c0eaaa2ec Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 23 Jun 2023 22:42:42 +0200 Subject: [PATCH 04/14] allow renaming type variables, and spreading with instantiated type variables --- jscomp/ml/typedecl.ml | 26 ++++++++++++++++++-------- jscomp/test/record_type_spread.js | 5 +++++ jscomp/test/record_type_spread.res | 18 ++++++++++++++++++ 3 files changed, 41 insertions(+), 8 deletions(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index c90be7a773..03ae2fd58d 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -452,17 +452,27 @@ let transl_declaration ~typeRecordAsObject env sdecl id = lbl in let rec process_lbls acc lbls lbls' = match lbls, lbls' with | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> - let type_vars = + (* 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 - |> List.filter_map (fun tvar -> - match Ctype.repr tvar with - | {desc = Tvar (Some name)} -> Some (name, tvar) - | _ -> None) + | {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)}) -> + (_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 diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 088f919144..44ce4b190c 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -25,8 +25,13 @@ var d = { } }; +var x = { + c: "hello" +}; + exports.getY = getY; exports.getX = getX; exports.v = v; exports.d = d; +exports.x = x; /* No side effect */ diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index ab1ce179e8..d5a85faa73 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -27,3 +27,21 @@ let d: d = { 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"), +} From 4588502a49bc905f971675f1b7801135d00735b0 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 24 Jun 2023 12:45:39 +0200 Subject: [PATCH 05/14] cleanup --- jscomp/ml/record_spread.ml | 11 ++++++----- jscomp/ml/typedecl.ml | 5 ++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/jscomp/ml/record_spread.ml b/jscomp/ml/record_spread.ml index 7df277739f..dde234dc88 100644 --- a/jscomp/ml/record_spread.ml +++ b/jscomp/ml/record_spread.ml @@ -1,24 +1,25 @@ module StringMap = Map.Make (String) -let t_equals t1 t2 = t1.Types.level = t2.Types.level && t1.id = t2.id +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 + 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 + | 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, memo)} - | Tsubst t -> loop t + | Tsubst t -> {t with desc=Tsubst (loop t)} | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} | Tnil -> t | Tarrow (lbl, t1, t2, c) -> diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 03ae2fd58d..cc82b6294b 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -441,7 +441,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = | 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 = - let lbl = { + { ld_id = l.ld_id; ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; ld_mutable = l.ld_mutable; @@ -449,7 +449,6 @@ let transl_declaration ~typeRecordAsObject env sdecl id = ld_loc = l.ld_loc; 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. *) @@ -1392,7 +1391,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 *) From d4e98ee44344e2dae5aafb43a4beae1346fd45d8 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 24 Jun 2023 13:06:51 +0200 Subject: [PATCH 06/14] redo pairing type params logic --- jscomp/ml/typedecl.ml | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index cc82b6294b..4ccb4c0695 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -460,18 +460,15 @@ let transl_declaration ~typeRecordAsObject env sdecl id = (_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 + if List.length type_params = List.length applied_type_vars then + let paired_type_vars = List.combine type_params applied_type_vars in + paired_type_vars + |> List.filter_map (fun (t, applied_tvar) -> + match t.desc with + | Tvar (Some tname) -> Some (tname, applied_tvar) + | _ -> None) + else [] in process_lbls ( fst acc @ (fields |> List.map (fun l -> mkLbl l ld_type type_vars)), snd acc From e9ca35ed36010c402a4f972efe275bebfaee842c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 25 Jun 2023 04:27:14 +0200 Subject: [PATCH 07/14] refactor: better type inference --- jscomp/ml/typedecl.ml | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 4ccb4c0695..b3d38210fa 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -470,15 +470,17 @@ let transl_declaration ~typeRecordAsObject env sdecl id = | _ -> None) else [] in process_lbls - ( fst acc @ (fields |> List.map (fun l -> mkLbl l ld_type type_vars)), + ( fst acc + @ (Ext_list.map fields (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; - })) ) + @ (Ext_list.map fields (fun l -> + { + l with + ld_type = + substitute_type_vars type_vars l.ld_type; + })) ) rest rest' | _ -> assert false | exception _ -> None) From 72b75d9dbedcda464967bb16c45c895bb83ec6f6 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 25 Jun 2023 05:31:53 +0200 Subject: [PATCH 08/14] Don't ask. --- jscomp/ml/record_spread.ml | 4 ++-- jscomp/test/record_type_spread.js | 3 +++ jscomp/test/record_type_spread.res | 9 +++++++++ 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/jscomp/ml/record_spread.ml b/jscomp/ml/record_spread.ml index dde234dc88..de3b00e165 100644 --- a/jscomp/ml/record_spread.ml +++ b/jscomp/ml/record_spread.ml @@ -17,8 +17,8 @@ let substitute_types ~type_map (t : Types.type_expr) = 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)} + | 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 diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 44ce4b190c..12a1bb74d5 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -10,6 +10,8 @@ function getX(v) { return v.x; } +var DeepSub = {}; + var v = { y: 3, x: 3 @@ -34,4 +36,5 @@ 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 d5a85faa73..19f61d8b74 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -45,3 +45,12 @@ type rnAsString = { let x: rnAsString = { c: Some("hello"), } + +module DeepSub = { + type t<'a, 'b> = { + x: result<'a, 'b>, + } + type d = { + ...t, + } +} From b00cd220282cacfb4eafffb918bed60f7ca403cf Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 25 Jun 2023 10:53:07 +0200 Subject: [PATCH 09/14] remove open --- jscomp/ml/typedecl.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index b3d38210fa..f84641a2d3 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -434,9 +434,8 @@ let transl_declaration ~typeRecordAsObject env sdecl id = 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 type_map = type_vars |> List.fold_left (fun acc (tvar_name, tvar_typ) -> Record_spread.StringMap.add tvar_name tvar_typ acc) Record_spread.StringMap.empty in + Record_spread.substitute_types ~type_map typ in let rec extract t = match t.desc with | Tpoly(t, []) -> extract t | _ -> Ctype.repr t in From 23b94d2fbae3ada7446004cf8010b916322536a8 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 25 Jun 2023 10:55:24 +0200 Subject: [PATCH 10/14] rename record type spread utils file --- jscomp/ml/{record_spread.ml => record_type_spread.ml} | 0 jscomp/ml/typedecl.ml | 4 ++-- 2 files changed, 2 insertions(+), 2 deletions(-) rename jscomp/ml/{record_spread.ml => record_type_spread.ml} (100%) diff --git a/jscomp/ml/record_spread.ml b/jscomp/ml/record_type_spread.ml similarity index 100% rename from jscomp/ml/record_spread.ml rename to jscomp/ml/record_type_spread.ml diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index f84641a2d3..77ab5d592e 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -434,8 +434,8 @@ let transl_declaration ~typeRecordAsObject env sdecl id = let lbls_opt = match has_spread with | true -> let substitute_type_vars type_vars typ = - let type_map = type_vars |> List.fold_left (fun acc (tvar_name, tvar_typ) -> Record_spread.StringMap.add tvar_name tvar_typ acc) Record_spread.StringMap.empty in - Record_spread.substitute_types ~type_map typ in + let type_map = type_vars |> List.fold_left (fun acc (tvar_name, tvar_typ) -> Record_type_spread.StringMap.add tvar_name tvar_typ acc) Record_type_spread.StringMap.empty in + Record_type_spread.substitute_types ~type_map typ in let rec extract t = match t.desc with | Tpoly(t, []) -> extract t | _ -> Ctype.repr t in From 6d8339d57d166b4f1d986d8919412bbece8ae5d6 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 25 Jun 2023 11:07:41 +0200 Subject: [PATCH 11/14] move more things related to record type spreads into dedicated file --- jscomp/ml/record_type_spread.ml | 42 ++++++++++++++++++++++++++++++--- jscomp/ml/typedecl.ml | 32 ++++--------------------- 2 files changed, 43 insertions(+), 31 deletions(-) diff --git a/jscomp/ml/record_type_spread.ml b/jscomp/ml/record_type_spread.ml index de3b00e165..76cc710f63 100644 --- a/jscomp/ml/record_type_spread.ml +++ b/jscomp/ml/record_type_spread.ml @@ -12,14 +12,14 @@ let substitute_types ~type_map (t : Types.type_expr) = in let rec loop (t : Types.type_expr) = match t.desc with - | Tlink t -> {t with desc=Tlink (loop t)} + | 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)} + | Tsubst t -> {t with desc = Tsubst (loop t)} | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} | Tnil -> t | Tarrow (lbl, t1, t2, c) -> @@ -49,4 +49,40 @@ let substitute_types ~type_map (t : Types.type_expr) = | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r) | Rabsent -> Rabsent in - loop t \ No newline at end of file + 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 77ab5d592e..a9f63da5be 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -425,17 +425,8 @@ 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 substitute_type_vars type_vars typ = - let type_map = type_vars |> List.fold_left (fun acc (tvar_name, tvar_typ) -> Record_type_spread.StringMap.add tvar_name tvar_typ acc) Record_type_spread.StringMap.empty in - Record_type_spread.substitute_types ~type_map typ in let rec extract t = match t.desc with | Tpoly(t, []) -> extract t | _ -> Ctype.repr t in @@ -444,30 +435,15 @@ let transl_declaration ~typeRecordAsObject env sdecl id = 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_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' -> - (* 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); type_params}) -> - (* Track which type param in the record we're spreading - belongs to which type variable applied to the spread itself. *) - let type_vars = - if List.length type_params = List.length applied_type_vars then - let paired_type_vars = List.combine type_params applied_type_vars in - paired_type_vars - |> List.filter_map (fun (t, applied_tvar) -> - match t.desc with - | Tvar (Some tname) -> Some (tname, applied_tvar) - | _ -> None) - else [] in + 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 -> @@ -478,7 +454,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = { l with ld_type = - substitute_type_vars type_vars l.ld_type; + Record_type_spread.substitute_type_vars type_vars l.ld_type; })) ) rest rest' | _ -> assert false From 0eddf31c88d2ec2a29f1aa2a9b8e38f87e3f6cad Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 25 Jun 2023 11:13:14 +0200 Subject: [PATCH 12/14] test for deep sub --- .../record_type_spreads_deep_sub.res.expected | 14 ++++++++++++++ .../fixtures/record_type_spreads_deep_sub.res | 9 +++++++++ 2 files changed, 23 insertions(+) create mode 100644 jscomp/build_tests/super_errors/expected/record_type_spreads_deep_sub.res.expected create mode 100644 jscomp/build_tests/super_errors/fixtures/record_type_spreads_deep_sub.res 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"), +} From ad9e0319e59b083f75134739b84b9c2c1dc42218 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 25 Jun 2023 11:17:43 +0200 Subject: [PATCH 13/14] extend test a bit --- jscomp/test/record_type_spread.js | 13 ++++++++++++- jscomp/test/record_type_spread.res | 7 ++++++- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/jscomp/test/record_type_spread.js b/jscomp/test/record_type_spread.js index 12a1bb74d5..7f0c61958c 100644 --- a/jscomp/test/record_type_spread.js +++ b/jscomp/test/record_type_spread.js @@ -10,7 +10,18 @@ function getX(v) { return v.x; } -var DeepSub = {}; +var DeepSub = { + d: { + x: { + TAG: "Ok", + _0: 1 + }, + z: { + NAME: "Two", + VAL: 1 + } + } +}; var v = { y: 3, diff --git a/jscomp/test/record_type_spread.res b/jscomp/test/record_type_spread.res index 19f61d8b74..ee373fb1ca 100644 --- a/jscomp/test/record_type_spread.res +++ b/jscomp/test/record_type_spread.res @@ -49,8 +49,13 @@ let x: rnAsString = { 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), + } } From 4588da72d9317822341c066fb3842b3acd332db4 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 25 Jun 2023 12:23:08 +0200 Subject: [PATCH 14/14] changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) 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