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 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/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/ctype.ml b/jscomp/ml/ctype.ml index e3ea09a6e2..1b92e9bbca 100644 --- a/jscomp/ml/ctype.ml +++ b/jscomp/ml/ctype.ml @@ -3952,18 +3952,55 @@ 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 - -> - (* type coercion for variants *) - (match Variant_coercion.is_variant_typedecl (extract_concrete_typedecl env t1) with + 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.can_try_coerce_variant_to_primitive (extract_concrete_typedecl env t1) with | Some constructors -> if constructors |> Variant_coercion.can_coerce_variant ~path then 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; 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 + 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 _) -> @@ -3973,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/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 2f70a3434b..f7d8e5944a 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -1,44 +1,6 @@ -let find_as_attribute_payload (attributes : Parsetree.attribute list) = - attributes - |> List.find_map (fun (attr : Parsetree.attribute) -> - match attr with - | {txt = "as"}, payload -> Some payload - | _ -> None) - (* 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)) - 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 - | _ -> 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 - | _ -> 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 - | _ -> 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 @@ -46,16 +8,57 @@ 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 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" -> + (* bool is represented as a variant internally, so we need to account for that *) + Some constructors | _ -> None + +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 ) + with + | None, None -> true + | Some s1, Some s2 when s1 = s2 -> true + | _ -> false + +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 ) + with + | true, true | false, false -> true + | _ -> false + in + if not unboxed then false + else + let tag = + match + ( Ast_untagged_variants.process_tag_name a1, + Ast_untagged_variants.process_tag_name a2 ) + with + | Some tag1, Some tag2 when tag1 = tag2 -> true + | None, None -> true + | _ -> false + in + if not tag then false else true diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js index 1a4701e4e8..3761e0d04e 100644 --- a/jscomp/test/VariantCoercion.js +++ b/jscomp/test/VariantCoercion.js @@ -2,6 +2,18 @@ 'use strict'; +var x = { + kind: "One", + age: 1 +}; + +var CoerceVariants = { + a: 1.1, + b: 1.1, + x: x, + y: x +}; + var a = "Three"; var b = "Three"; @@ -20,4 +32,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..73d8d24dfb 100644 --- a/jscomp/test/VariantCoercion.res +++ b/jscomp/test/VariantCoercion.res @@ -15,3 +15,18 @@ type onlyFloats = | @as(1.1) Onef | @as(2.2) Twof | @as(3.3) Threef let ii = Onef let dd = (ii :> float) + +module CoerceVariants = { + @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) +}