From 1915b50929c62636682cfe3b419b4dcd60187c23 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Wed, 28 Jun 2023 10:31:25 +0200 Subject: [PATCH 1/9] sketch out variant-to-variant coercion --- jscomp/ml/ctype.ml | 34 ++++++++++++++++-- jscomp/ml/variant_coercion.ml | 63 +++++++++++++++++++++++++++++++-- jscomp/test/VariantCoercion.js | 6 ++++ jscomp/test/VariantCoercion.res | 9 +++++ 4 files changed, 108 insertions(+), 4 deletions(-) diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml index e3ea09a6e2..53d1925006 100644 --- a/jscomp/ml/ctype.ml +++ b/jscomp/ml/ctype.ml @@ -3954,7 +3954,7 @@ let rec subtype_rec env trace t1 t2 cstrs = | (Tconstr(_, [], _), Tconstr(path, [], _)) when Variant_coercion.can_coerce_path path && extract_concrete_typedecl env t1 |> Variant_coercion.is_variant_typedecl |> Option.is_some -> - (* type coercion for variants *) + (* type coercion for variants to primitives *) (match Variant_coercion.is_variant_typedecl (extract_concrete_typedecl env t1) with | Some constructors -> if constructors |> Variant_coercion.can_coerce_variant ~path then @@ -3962,8 +3962,38 @@ let rec subtype_rec env trace t1 t2 cstrs = else (trace, t1, t2, !univar_pairs)::cstrs | None -> (trace, t1, t2, !univar_pairs)::cstrs) - | (Tconstr(_, [], _), Tconstr(_, [], _)) -> (* type coercion for records *) + | (Tconstr(_, [], _), Tconstr(_, [], _)) -> (* type coercion for variants and records *) (match extract_concrete_typedecl env t1, extract_concrete_typedecl env t2 with + | (_, _, {type_kind=Type_variant (c1); type_attributes=t1attrs}), (_, _, {type_kind=Type_variant (c2); type_attributes=t2attrs}) -> + if + Variant_coercion.variant_configuration_can_be_coerced t1attrs t2attrs = false + then + (trace, t1, t2, !univar_pairs)::cstrs + else + let c1_len = List.length c1 in + if c1_len > List.length c2 then (trace, t1, t2, !univar_pairs)::cstrs + else + let constructor_map = Hashtbl.create c1_len in + c2 + |> List.iter (fun (c : Types.constructor_declaration) -> + Hashtbl.add constructor_map (Ident.name c.cd_id) c); + if c1 |> List.for_all (fun (c : Types.constructor_declaration) -> + match (c, Hashtbl.find_opt constructor_map (Ident.name c.cd_id)) with + | ( {Types.cd_args = Cstr_record _fields1}, + Some {Types.cd_args = Cstr_record _fields2} ) -> + (* TODO: Reuse logic from record coercion *) + false + | ( {Types.cd_args = Cstr_tuple tl1; cd_attributes=c1_attributes}, + Some {Types.cd_args = Cstr_tuple tl2; cd_attributes=c2_attributes} ) -> + if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then + begin try + let lst = subtype_list env trace tl1 tl2 cstrs in + List.length lst = List.length cstrs + with | _ -> false end + else false + | _ -> false) + then cstrs + else (trace, t1, t2, !univar_pairs)::cstrs | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {type_kind=Type_record (fields2, repr2)}) -> let same_repr = match repr1, repr2 with | (Record_regular | Record_optional_labels _), (Record_regular | Record_optional_labels _) -> diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 2f70a3434b..c5ff21f9e6 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -1,10 +1,13 @@ -let find_as_attribute_payload (attributes : Parsetree.attribute list) = +let find_attribute_payload name (attributes : Parsetree.attribute list) = attributes |> List.find_map (fun (attr : Parsetree.attribute) -> match attr with - | {txt = "as"}, payload -> Some payload + | {txt}, payload when txt = name -> Some payload | _ -> None) +let find_as_attribute_payload (attributes : Parsetree.attribute list) = + find_attribute_payload "as" attributes + (* TODO: Improve error messages? Say why we can't coerce. *) let check_constructors (constructors : Types.constructor_declaration list) check @@ -59,3 +62,59 @@ let is_variant_typedecl match typedecl with | {type_kind = Type_variant constructors} -> Some constructors | _ -> None + +let find_attribute_payload_as_string name attrs = + match find_attribute_payload name attrs with + | None -> None + | Some payload -> Ast_payload.is_single_string payload + +let variant_representation_matches (c1_attrs : Parsetree.attributes) + (c2_attrs : Parsetree.attributes) = + match + (find_as_attribute_payload c1_attrs, find_as_attribute_payload c2_attrs) + with + | None, None -> true + | Some p1, Some p2 -> ( + let string_matches = match + (Ast_payload.is_single_string p1, Ast_payload.is_single_string p2) + with + | Some (a, _), Some (b, _) when a = b -> true + | _ -> false in + if string_matches then true else + let float_matches = match + (Ast_payload.is_single_float p1, Ast_payload.is_single_float p2) + with + | Some a, Some b when a = b -> true + | _ -> false in + if float_matches then true else + let int_matches = match + (Ast_payload.is_single_int p1, Ast_payload.is_single_int p2) + with + | Some a, Some b when a = b -> true + | _ -> false in + if int_matches then true else + false) + | _ -> false + +let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) + (a2 : Parsetree.attributes) = + let unboxed = + match + (find_attribute_payload "unboxed" a1, find_attribute_payload "unboxed" a2) + with + | Some (PStr []), Some (PStr []) -> true + | None, None -> true + | _ -> false + in + if not unboxed then false + else + let tag = + match + ( find_attribute_payload_as_string "tag" a1, + find_attribute_payload_as_string "tag" a2 ) + with + | Some (tag1, _), Some (tag2, _) when tag1 = tag2 -> true + | None, None -> true + | _ -> false + in + if not tag then false else true \ No newline at end of file diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js index 1a4701e4e8..ce61be5247 100644 --- a/jscomp/test/VariantCoercion.js +++ b/jscomp/test/VariantCoercion.js @@ -2,6 +2,11 @@ 'use strict'; +var CoerceVariants = { + a: 1.1, + b: 1.1 +}; + var a = "Three"; var b = "Three"; @@ -20,4 +25,5 @@ exports.i = i; exports.d = d; exports.ii = ii; exports.dd = dd; +exports.CoerceVariants = CoerceVariants; /* No side effect */ diff --git a/jscomp/test/VariantCoercion.res b/jscomp/test/VariantCoercion.res index 75892a5f36..93ce5a9bf2 100644 --- a/jscomp/test/VariantCoercion.res +++ b/jscomp/test/VariantCoercion.res @@ -15,3 +15,12 @@ type onlyFloats = | @as(1.1) Onef | @as(2.2) Twof | @as(3.3) Threef let ii = Onef let dd = (ii :> float) + +module CoerceVariants = { + type a = One(int) | @as(1.1) Two + type b = One(int) | @as(1.1) Two | Three + + let a: a = Two + + let b: b = (a :> b) +} From da56f8eac34870b03feee8d9bc8074d67ed2e9f4 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Wed, 28 Jun 2023 18:53:57 +0200 Subject: [PATCH 2/9] reuse logic from ast_untagged_variants --- jscomp/core/matching_polyfill.ml | 2 ++ jscomp/ml/ast_uncurried.ml | 7 +----- jscomp/ml/ast_uncurried_utils.ml | 5 ++++ jscomp/ml/ast_untagged_variants.ml | 8 ++++-- jscomp/ml/variant_coercion.ml | 39 ++++++------------------------ 5 files changed, 21 insertions(+), 40 deletions(-) create mode 100644 jscomp/ml/ast_uncurried_utils.ml diff --git a/jscomp/core/matching_polyfill.ml b/jscomp/core/matching_polyfill.ml index 8afd89636e..ebee344132 100644 --- a/jscomp/core/matching_polyfill.ml +++ b/jscomp/core/matching_polyfill.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +let () = Ast_untagged_variants.extract_concrete_typedecl := Ctype.extract_concrete_typedecl + let names_from_construct_pattern (pat : Typedtree.pattern) = let rec resolve_path n (path : Path.t) = match Env.find_type path pat.pat_env with diff --git a/jscomp/ml/ast_uncurried.ml b/jscomp/ml/ast_uncurried.ml index 8b418ef287..1a49b2743a 100644 --- a/jscomp/ml/ast_uncurried.ml +++ b/jscomp/ml/ast_uncurried.ml @@ -69,12 +69,7 @@ let coreTypeIsUncurriedFun (typ : Parsetree.core_type) = true | _ -> false -let typeIsUncurriedFun (typ : Types.type_expr) = - match typ.desc with - | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> - true - | _ -> false - +let typeIsUncurriedFun = Ast_uncurried_utils.typeIsUncurriedFun let typeExtractUncurriedFun (typ : Parsetree.core_type) = match typ.ptyp_desc with diff --git a/jscomp/ml/ast_uncurried_utils.ml b/jscomp/ml/ast_uncurried_utils.ml new file mode 100644 index 0000000000..ad18b01a6d --- /dev/null +++ b/jscomp/ml/ast_uncurried_utils.ml @@ -0,0 +1,5 @@ +let typeIsUncurriedFun (typ : Types.type_expr) = + match typ.desc with + | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> + true + | _ -> false \ No newline at end of file diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml index e95f9f8764..042cd3169c 100644 --- a/jscomp/ml/ast_untagged_variants.ml +++ b/jscomp/ml/ast_untagged_variants.ml @@ -77,6 +77,10 @@ let process_untagged (attrs : Parsetree.attributes) = | _ -> ()); !st +let extract_concrete_typedecl: (Env.t -> + Types.type_expr -> + Path.t * Path.t * Types.type_declaration) ref = ref (Obj.magic ()) + let process_tag_type (attrs : Parsetree.attributes) = let st : tag_type option ref = ref None in Ext_list.iter attrs (fun ({txt; loc}, payload) -> @@ -137,7 +141,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : when Path.same path Predef.path_array -> Some ArrayType | true, Cstr_tuple [({desc = Tconstr _} as t)] - when Ast_uncurried.typeIsUncurriedFun t -> + when Ast_uncurried_utils.typeIsUncurriedFun t -> Some FunctionType | true, Cstr_tuple [{desc = Tarrow _}] -> Some FunctionType | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] @@ -148,7 +152,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : Some ObjectType | true, Cstr_tuple [ty] -> ( let default = Some UnknownType in - match Ctype.extract_concrete_typedecl env ty with + match !extract_concrete_typedecl env ty with | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType | _ -> default diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index c5ff21f9e6..8ccd4d08e2 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -63,57 +63,32 @@ let is_variant_typedecl | {type_kind = Type_variant constructors} -> Some constructors | _ -> None -let find_attribute_payload_as_string name attrs = - match find_attribute_payload name attrs with - | None -> None - | Some payload -> Ast_payload.is_single_string payload - let variant_representation_matches (c1_attrs : Parsetree.attributes) (c2_attrs : Parsetree.attributes) = match - (find_as_attribute_payload c1_attrs, find_as_attribute_payload c2_attrs) + (Ast_untagged_variants.process_tag_type c1_attrs, Ast_untagged_variants.process_tag_type c2_attrs) with | None, None -> true - | Some p1, Some p2 -> ( - let string_matches = match - (Ast_payload.is_single_string p1, Ast_payload.is_single_string p2) - with - | Some (a, _), Some (b, _) when a = b -> true - | _ -> false in - if string_matches then true else - let float_matches = match - (Ast_payload.is_single_float p1, Ast_payload.is_single_float p2) - with - | Some a, Some b when a = b -> true - | _ -> false in - if float_matches then true else - let int_matches = match - (Ast_payload.is_single_int p1, Ast_payload.is_single_int p2) - with - | Some a, Some b when a = b -> true - | _ -> false in - if int_matches then true else - false) + | Some s1, Some s2 when s1 = s2 -> true | _ -> false let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) (a2 : Parsetree.attributes) = let unboxed = match - (find_attribute_payload "unboxed" a1, find_attribute_payload "unboxed" a2) + (Ast_untagged_variants.process_untagged a1, Ast_untagged_variants.process_untagged a2) with - | Some (PStr []), Some (PStr []) -> true - | None, None -> true + | true, true | false, false -> true | _ -> false in if not unboxed then false else let tag = match - ( find_attribute_payload_as_string "tag" a1, - find_attribute_payload_as_string "tag" a2 ) + (Ast_untagged_variants.process_tag_name a1, + Ast_untagged_variants.process_tag_name a2 ) with - | Some (tag1, _), Some (tag2, _) when tag1 = tag2 -> true + | Some (tag1), Some (tag2) when tag1 = tag2 -> true | None, None -> true | _ -> false in From ce3d5327de334a0a9c1468c73e988d5d324d69d4 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Wed, 28 Jun 2023 18:58:13 +0200 Subject: [PATCH 3/9] reuse more logic --- jscomp/ml/variant_coercion.ml | 37 +++++++++++------------------------ 1 file changed, 11 insertions(+), 26 deletions(-) diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 8ccd4d08e2..5f980c7742 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -1,45 +1,28 @@ -let find_attribute_payload name (attributes : Parsetree.attribute list) = - attributes - |> List.find_map (fun (attr : Parsetree.attribute) -> - match attr with - | {txt}, payload when txt = name -> Some payload - | _ -> None) - -let find_as_attribute_payload (attributes : Parsetree.attribute list) = - find_attribute_payload "as" attributes - (* TODO: Improve error messages? Say why we can't coerce. *) let check_constructors (constructors : Types.constructor_declaration list) check = List.for_all (fun (c : Types.constructor_declaration) -> - check c.cd_args (find_as_attribute_payload c.cd_attributes)) + check c.cd_args (Ast_untagged_variants.process_tag_type c.cd_attributes)) constructors let can_coerce_to_string (constructors : Types.constructor_declaration list) = check_constructors constructors (fun args payload -> match (args, payload) with - | Cstr_tuple [], None -> true - | Cstr_tuple [], Some payload - when Ast_payload.is_single_string payload |> Option.is_some -> - true + | Cstr_tuple [], (None | Some (String _)) -> true | _ -> false) let can_coerce_to_int (constructors : Types.constructor_declaration list) = check_constructors constructors (fun args payload -> match (args, payload) with - | Cstr_tuple [], Some payload - when Ast_payload.is_single_int payload |> Option.is_some -> - true + | Cstr_tuple [], Some (Int _) -> true | _ -> false) let can_coerce_to_float (constructors : Types.constructor_declaration list) = check_constructors constructors (fun args payload -> match (args, payload) with - | Cstr_tuple [], Some payload - when Ast_payload.is_single_float payload |> Option.is_some -> - true + | Cstr_tuple [], Some (Float _) -> true | _ -> false) let can_coerce_path (path : Path.t) = @@ -66,7 +49,8 @@ let is_variant_typedecl let variant_representation_matches (c1_attrs : Parsetree.attributes) (c2_attrs : Parsetree.attributes) = match - (Ast_untagged_variants.process_tag_type c1_attrs, Ast_untagged_variants.process_tag_type c2_attrs) + ( Ast_untagged_variants.process_tag_type c1_attrs, + Ast_untagged_variants.process_tag_type c2_attrs ) with | None, None -> true | Some s1, Some s2 when s1 = s2 -> true @@ -76,7 +60,8 @@ let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) (a2 : Parsetree.attributes) = let unboxed = match - (Ast_untagged_variants.process_untagged a1, Ast_untagged_variants.process_untagged a2) + ( Ast_untagged_variants.process_untagged a1, + Ast_untagged_variants.process_untagged a2 ) with | true, true | false, false -> true | _ -> false @@ -85,11 +70,11 @@ let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) else let tag = match - (Ast_untagged_variants.process_tag_name a1, + ( Ast_untagged_variants.process_tag_name a1, Ast_untagged_variants.process_tag_name a2 ) with - | Some (tag1), Some (tag2) when tag1 = tag2 -> true + | Some tag1, Some tag2 when tag1 = tag2 -> true | None, None -> true | _ -> false in - if not tag then false else true \ No newline at end of file + if not tag then false else true From 536f46da20bea620f5eb6953d35b0f39285a8ebd Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Wed, 28 Jun 2023 20:08:30 +0200 Subject: [PATCH 4/9] handle inline records in variant coercion --- jscomp/ml/ctype.ml | 45 +++++++++++---------------------- jscomp/ml/record_coercion.ml | 33 ++++++++++++++++++++++++ jscomp/test/VariantCoercion.js | 9 ++++++- jscomp/test/VariantCoercion.res | 10 ++++++-- 4 files changed, 64 insertions(+), 33 deletions(-) create mode 100644 jscomp/ml/record_coercion.ml diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml index 53d1925006..fd13b29537 100644 --- a/jscomp/ml/ctype.ml +++ b/jscomp/ml/ctype.ml @@ -3979,16 +3979,23 @@ let rec subtype_rec env trace t1 t2 cstrs = Hashtbl.add constructor_map (Ident.name c.cd_id) c); if c1 |> List.for_all (fun (c : Types.constructor_declaration) -> match (c, Hashtbl.find_opt constructor_map (Ident.name c.cd_id)) with - | ( {Types.cd_args = Cstr_record _fields1}, - Some {Types.cd_args = Cstr_record _fields2} ) -> - (* TODO: Reuse logic from record coercion *) - false + | ( {Types.cd_args = Cstr_record fields1; cd_attributes=c1_attributes}, + Some {Types.cd_args = Cstr_record fields2; cd_attributes=c2_attributes} ) -> + if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then + let violation, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 in + if violation then false + else + begin try + let lst = subtype_list env trace tl1 tl2 cstrs in + List.length lst = List.length cstrs + with | _ -> false end + else false | ( {Types.cd_args = Cstr_tuple tl1; cd_attributes=c1_attributes}, Some {Types.cd_args = Cstr_tuple tl2; cd_attributes=c2_attributes} ) -> if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then begin try - let lst = subtype_list env trace tl1 tl2 cstrs in - List.length lst = List.length cstrs + let lst = subtype_list env trace tl1 tl2 cstrs in + List.length lst = List.length cstrs with | _ -> false end else false | _ -> false) @@ -4003,30 +4010,8 @@ let rec subtype_rec env trace t1 t2 cstrs = | Record_extension, Record_extension -> true | _ -> false in if same_repr then - let field_is_optional id repr = match repr with - | Record_optional_labels lbls -> List.mem (Ident.name id) lbls - | _ -> false in - let violation = ref false in - let label_decl_sub (acc1, acc2) ld2 = - match Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name) with - | Some ld1 -> - if field_is_optional ld1.ld_id repr1 <> (field_is_optional ld2.ld_id repr2) then - (* optional field can't be modified *) - violation := true; - let get_as (({txt}, payload) : Parsetree.attribute) = - if txt = "as" then Ast_payload.is_single_string payload - else None in - let get_as_name ld = match Ext_list.filter_map ld.ld_attributes get_as with - | [] -> ld.ld_id.name - | (s,_)::_ -> s in - if get_as_name ld1 <> get_as_name ld2 then violation := true; - ld1.ld_type :: acc1, ld2.ld_type :: acc2 - | None -> - (* field must be present *) - violation := true; - (acc1, acc2) in - let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in - if !violation + let violation, tl1, tl2 = Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2 in + if violation then (trace, t1, t2, !univar_pairs)::cstrs else subtype_list env trace tl1 tl2 cstrs diff --git a/jscomp/ml/record_coercion.ml b/jscomp/ml/record_coercion.ml new file mode 100644 index 0000000000..338749e524 --- /dev/null +++ b/jscomp/ml/record_coercion.ml @@ -0,0 +1,33 @@ +let check_record_fields ?repr1 ?repr2 (fields1 : Types.label_declaration list) + (fields2 : Types.label_declaration list) = + let field_is_optional id repr = + match repr with + | Some (Types.Record_optional_labels lbls) -> List.mem (Ident.name id) lbls + | _ -> false + in + let violation = ref false in + let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) = + match + Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name) + with + | Some ld1 -> + if field_is_optional ld1.ld_id repr1 <> field_is_optional ld2.ld_id repr2 + then (* optional field can't be modified *) + violation := true; + let get_as (({txt}, payload) : Parsetree.attribute) = + if txt = "as" then Ast_payload.is_single_string payload else None + in + let get_as_name (ld : Types.label_declaration) = + match Ext_list.filter_map ld.ld_attributes get_as with + | [] -> ld.ld_id.name + | (s, _) :: _ -> s + in + if get_as_name ld1 <> get_as_name ld2 then violation := true; + (ld1.ld_type :: acc1, ld2.ld_type :: acc2) + | None -> + (* field must be present *) + violation := true; + (acc1, acc2) + in + let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in + (!violation, tl1, tl2) \ No newline at end of file diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js index ce61be5247..3761e0d04e 100644 --- a/jscomp/test/VariantCoercion.js +++ b/jscomp/test/VariantCoercion.js @@ -2,9 +2,16 @@ 'use strict'; +var x = { + kind: "One", + age: 1 +}; + var CoerceVariants = { a: 1.1, - b: 1.1 + b: 1.1, + x: x, + y: x }; var a = "Three"; diff --git a/jscomp/test/VariantCoercion.res b/jscomp/test/VariantCoercion.res index 93ce5a9bf2..73d8d24dfb 100644 --- a/jscomp/test/VariantCoercion.res +++ b/jscomp/test/VariantCoercion.res @@ -17,10 +17,16 @@ let ii = Onef let dd = (ii :> float) module CoerceVariants = { - type a = One(int) | @as(1.1) Two - type b = One(int) | @as(1.1) Two | Three + @unboxed type a = One(int) | @as(1.1) Two | @as(null) T2 + @unboxed type b = One(int) | @as(1.1) Two | @as(null) T2 | Three let a: a = Two let b: b = (a :> b) + + @tag("kind") type x = One({age: int, name?: string}) + @tag("kind") type y = One({age: int, name?: string}) | Two({two: string}) + + let x: x = One({age: 1}) + let y: y = (x :> y) } From 36359ca6315e0b51dae12104a2eea9a2a43ad89a Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Wed, 28 Jun 2023 20:56:04 +0200 Subject: [PATCH 5/9] fix false positive in variant to primitive branch, and add tests --- .../expected/variant_to_variant_coercion.res.expected | 10 ++++++++++ .../variant_to_variant_coercion_as.res.expected | 10 ++++++++++ .../variant_to_variant_coercion_tag.res.expected | 10 ++++++++++ .../variant_to_variant_coercion_unboxed.res.expected | 10 ++++++++++ .../fixtures/variant_to_variant_coercion.res | 6 ++++++ .../fixtures/variant_to_variant_coercion_as.res | 6 ++++++ .../fixtures/variant_to_variant_coercion_tag.res | 6 ++++++ .../fixtures/variant_to_variant_coercion_unboxed.res | 6 ++++++ jscomp/ml/ctype.ml | 6 +++--- jscomp/ml/variant_coercion.ml | 6 +++--- 10 files changed, 70 insertions(+), 6 deletions(-) create mode 100644 jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected new file mode 100644 index 0000000000..75a0fc30b6 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_to_variant_coercion.res:6:10-15 + + 4 │ let x: x = One(true) + 5 │ + 6 │ let y = (x :> y) + 7 │ + + Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected new file mode 100644 index 0000000000..04a3f55798 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_to_variant_coercion_as.res:6:10-15 + + 4 │ let x: x = One(true) + 5 │ + 6 │ let y = (x :> y) + 7 │ + + Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected new file mode 100644 index 0000000000..33b2122b09 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_to_variant_coercion_tag.res:6:10-15 + + 4 │ let x: x = One(true) + 5 │ + 6 │ let y = (x :> y) + 7 │ + + Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected new file mode 100644 index 0000000000..6e4844a280 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_to_variant_coercion_unboxed.res:6:10-15 + + 4 │ let x: x = One(true) + 5 │ + 6 │ let y = (x :> y) + 7 │ + + Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res new file mode 100644 index 0000000000..6198fb6baa --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res @@ -0,0 +1,6 @@ +type x = One(bool) | Two +type y = One(string) | Two + +let x: x = One(true) + +let y = (x :> y) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res new file mode 100644 index 0000000000..9a9394d6da --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res @@ -0,0 +1,6 @@ +type x = | @as("one") One(bool) | Two(string) +type y = One(bool) | Two(string) + +let x: x = One(true) + +let y = (x :> y) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res new file mode 100644 index 0000000000..7fb78085c1 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res @@ -0,0 +1,6 @@ +@tag("kind") type x = One(bool) | Two(string) +type y = One(bool) | Two(string) + +let x: x = One(true) + +let y = (x :> y) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res new file mode 100644 index 0000000000..d0896f05af --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res @@ -0,0 +1,6 @@ +@unboxed type x = One(bool) | Two +type y = One(bool) | Two + +let x: x = One(true) + +let y = (x :> y) diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml index fd13b29537..1b92e9bbca 100644 --- a/jscomp/ml/ctype.ml +++ b/jscomp/ml/ctype.ml @@ -3952,10 +3952,10 @@ let rec subtype_rec env trace t1 t2 cstrs = | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | (Tconstr(_, [], _), Tconstr(path, [], _)) when Variant_coercion.can_coerce_path path && - extract_concrete_typedecl env t1 |> Variant_coercion.is_variant_typedecl |> Option.is_some - -> + extract_concrete_typedecl env t1 |> Variant_coercion.can_try_coerce_variant_to_primitive |> Option.is_some + -> (* type coercion for variants to primitives *) - (match Variant_coercion.is_variant_typedecl (extract_concrete_typedecl env t1) with + (match Variant_coercion.can_try_coerce_variant_to_primitive (extract_concrete_typedecl env t1) with | Some constructors -> if constructors |> Variant_coercion.can_coerce_variant ~path then cstrs diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 5f980c7742..3ae7c07ddb 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -40,10 +40,10 @@ let can_coerce_variant ~(path : Path.t) then true else false -let is_variant_typedecl - ((_, _, typedecl) : Path.t * Path.t * Types.type_declaration) = +let can_try_coerce_variant_to_primitive + ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = match typedecl with - | {type_kind = Type_variant constructors} -> Some constructors + | {type_kind = Type_variant constructors; type_params=[]} when Path.name p <> "bool"-> Some constructors | _ -> None let variant_representation_matches (c1_attrs : Parsetree.attributes) From beedf90bd0472b212cc54cb317f9a8e32082406c Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Wed, 28 Jun 2023 20:57:14 +0200 Subject: [PATCH 6/9] changelog --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1c2e172de8..ad6db1ff6a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,8 @@ > - :nail_care: [Polish] # 11.0.0-beta.4 (Unreleased) +#### :rocket: New Feature +- Variants: Allow coercing from variant to variant, where applicable. https://github.com/rescript-lang/rescript-compiler/pull/6314 # 11.0.0-beta.3 From 6cdc49e3df832f685c899457bfc2320be3e2f524 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Wed, 28 Jun 2023 21:01:10 +0200 Subject: [PATCH 7/9] format --- jscomp/ml/variant_coercion.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 3ae7c07ddb..e3901f4170 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -43,7 +43,9 @@ let can_coerce_variant ~(path : Path.t) let can_try_coerce_variant_to_primitive ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = match typedecl with - | {type_kind = Type_variant constructors; type_params=[]} when Path.name p <> "bool"-> Some constructors + | {type_kind = Type_variant constructors; type_params = []} + when Path.name p <> "bool" -> + Some constructors | _ -> None let variant_representation_matches (c1_attrs : Parsetree.attributes) From 15b6eca0e4b2c648ac374c113fa4cfc8677052e2 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 29 Jun 2023 11:46:58 +0200 Subject: [PATCH 8/9] reuse more logic from ast_untagged --- jscomp/ml/variant_coercion.ml | 39 +++++++++++++---------------------- 1 file changed, 14 insertions(+), 25 deletions(-) diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index e3901f4170..ba620c5366 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -7,24 +7,7 @@ let check_constructors (constructors : Types.constructor_declaration list) check check c.cd_args (Ast_untagged_variants.process_tag_type c.cd_attributes)) constructors -let can_coerce_to_string (constructors : Types.constructor_declaration list) = - check_constructors constructors (fun args payload -> - match (args, payload) with - | Cstr_tuple [], (None | Some (String _)) -> true - | _ -> false) - -let can_coerce_to_int (constructors : Types.constructor_declaration list) = - check_constructors constructors (fun args payload -> - match (args, payload) with - | Cstr_tuple [], Some (Int _) -> true - | _ -> false) - -let can_coerce_to_float (constructors : Types.constructor_declaration list) = - check_constructors constructors (fun args payload -> - match (args, payload) with - | Cstr_tuple [], Some (Float _) -> true - | _ -> false) - +(* Right now we only allow coercing to primitives string/int/float *) let can_coerce_path (path : Path.t) = Path.same path Predef.path_string || Path.same path Predef.path_int @@ -32,19 +15,25 @@ let can_coerce_path (path : Path.t) = let can_coerce_variant ~(path : Path.t) (constructors : Types.constructor_declaration list) = - if Path.same path Predef.path_string && can_coerce_to_string constructors then - true - else if Path.same path Predef.path_int && can_coerce_to_int constructors then - true - else if Path.same path Predef.path_float && can_coerce_to_float constructors - then true - else false + constructors + |> List.for_all (fun (c : Types.constructor_declaration) -> + let args = c.cd_args in + let payload = Ast_untagged_variants.process_tag_type c.cd_attributes in + match args with + | Cstr_tuple [] -> ( + match payload with + | None | Some (String _) -> Path.same path Predef.path_string + | Some (Int _) -> Path.same path Predef.path_int + | Some (Float _) -> Path.same path Predef.path_float + | Some (Null | Undefined | Bool _ | Untagged _) -> false) + | _ -> false) let can_try_coerce_variant_to_primitive ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = match typedecl with | {type_kind = Type_variant constructors; type_params = []} when Path.name p <> "bool" -> + (* bool is represented as a variant internally, so we need to account for that *) Some constructors | _ -> None From bc90fe4a582c0f8c5809a075c7cc8b6bbe382167 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 29 Jun 2023 11:53:37 +0200 Subject: [PATCH 9/9] remove unused --- jscomp/ml/variant_coercion.ml | 7 ------- 1 file changed, 7 deletions(-) diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index ba620c5366..f7d8e5944a 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -1,12 +1,5 @@ (* TODO: Improve error messages? Say why we can't coerce. *) -let check_constructors (constructors : Types.constructor_declaration list) check - = - List.for_all - (fun (c : Types.constructor_declaration) -> - check c.cd_args (Ast_untagged_variants.process_tag_type c.cd_attributes)) - constructors - (* Right now we only allow coercing to primitives string/int/float *) let can_coerce_path (path : Path.t) = Path.same path Predef.path_string