From d98cc062079888c61ea1a79d7d11b98293f65180 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 26 Aug 2024 23:43:40 +0200 Subject: [PATCH 1/6] wip coerce polyvariant to variant --- jscomp/ml/ctype.ml | 8 ++++++ jscomp/ml/variant_coercion.ml | 45 +++++++++++++++++++++++++++++++++ jscomp/test/VariantCoercion.js | 10 ++++++++ jscomp/test/VariantCoercion.res | 20 +++++++++++++++ 4 files changed, 83 insertions(+) diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml index 76257a14c9..a5dbb55979 100644 --- a/jscomp/ml/ctype.ml +++ b/jscomp/ml/ctype.ml @@ -3701,6 +3701,14 @@ let rec subtype_rec env trace t1 t2 cstrs = with Exit -> (trace, t1, t2, !univar_pairs)::cstrs end + | (Tvariant {row_closed=true; row_fields}, Tconstr (_, [], _)) + when extract_concrete_typedecl_opt env t2 |> Variant_coercion.type_is_variant -> + (match extract_concrete_typedecl env t2 with + | (_, _, {type_kind=Type_variant (constructors); type_attributes}) -> + (match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes with + | Ok _ -> cstrs + | Error _ -> (trace, t1, t2, !univar_pairs)::cstrs) + | _ -> (trace, t1, t2, !univar_pairs)::cstrs) | Tvariant v, _ when !variant_is_subtype env (row_repr v) t2 -> diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 86f525ad2c..2ef74286cb 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -151,3 +151,48 @@ let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc right_loc; error = TagName {left_tag; right_tag}; })) + +let can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes + = + let polyvariant_runtime_representations = + row_fields + |> List.filter_map (fun (label, (field : Types.row_field)) -> + match field with + | Rpresent None -> Some label + | _ -> None) + in + if List.length polyvariant_runtime_representations <> List.length row_fields + then + (* Error: At least one polyvariant constructor has a payload. Cannot have payloads. *) + Error `PolyvariantConstructorHasPayload + else + let is_unboxed = Ast_untagged_variants.has_untagged type_attributes in + if + List.for_all + (fun polyvariant_value -> + constructors + |> List.exists (fun (c : Types.constructor_declaration) -> + let constructor_name = Ident.name c.cd_id in + match + Ast_untagged_variants.process_tag_type c.cd_attributes + with + | Some (String as_runtime_string) -> + (* `@as("")`, does the configured string match the polyvariant value? *) + as_runtime_string = polyvariant_value + | Some (Untagged StringType) when is_unboxed -> + (* An unboxed variant that has a catch all case will match _any_ string, so it matches anything here. *) + true + | Some _ -> + (* Any other `@as` can't match since it's by definition not a string *) + false + | None -> + (* No `@as` means the runtime representation will be the constructor name as a string. *) + polyvariant_value = constructor_name)) + polyvariant_runtime_representations + then Ok () + else Error `Unknown + +let type_is_variant (typ: (Path.t * Path.t * Types.type_declaration) option) = + match typ with + | Some (_, _, {type_kind = Type_variant _; _}) -> true + | _ -> false \ No newline at end of file diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js index 90e334d343..595af3d1a6 100644 --- a/jscomp/test/VariantCoercion.js +++ b/jscomp/test/VariantCoercion.js @@ -71,6 +71,15 @@ let CoerceFromBigintToVariant = { cc: 120n }; +let CoerceFromPolyvariantToVariant = { + simple: "One", + simpleP: "One", + withAs: "One", + withAsP: "One", + withMoreVariantConstructors: "One", + withMoreVariantConstructorsP: "One" +}; + let a$2 = "Three"; let b = "Three"; @@ -95,4 +104,5 @@ exports.CoerceFromStringToVariant = CoerceFromStringToVariant; exports.CoerceFromIntToVariant = CoerceFromIntToVariant; exports.CoerceFromFloatToVariant = CoerceFromFloatToVariant; exports.CoerceFromBigintToVariant = CoerceFromBigintToVariant; +exports.CoerceFromPolyvariantToVariant = CoerceFromPolyvariantToVariant; /* No side effect */ diff --git a/jscomp/test/VariantCoercion.res b/jscomp/test/VariantCoercion.res index 5c31324efc..28e24bfd59 100644 --- a/jscomp/test/VariantCoercion.res +++ b/jscomp/test/VariantCoercion.res @@ -92,3 +92,23 @@ module CoerceFromBigintToVariant = { let c = 120n let cc: mixed = (c :> mixed) } + +module CoerceFromPolyvariantToVariant = { + type simple = [#One | #Two] + type simpleP = One | Two + + let simple: simple = #One + let simpleP = (simple :> simpleP) + + type withAs = [#One | #two] + type withAsP = One | @as("two") Two + + let withAs: withAs = #One + let withAsP = (withAs :> withAsP) + + type withMoreVariantConstructors = [#One | #two] + type withMoreVariantConstructorsP = One | @as("two") Two | Three + + let withMoreVariantConstructors: withMoreVariantConstructors = #One + let withMoreVariantConstructorsP = (withMoreVariantConstructors :> withMoreVariantConstructorsP) +} From f72de7cb1f7e92f030588e762e8b43b04397d6ee Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 26 Aug 2024 23:51:45 +0200 Subject: [PATCH 2/6] fix unboxed catch-all --- jscomp/ml/variant_coercion.ml | 17 ++++++++++++----- jscomp/test/VariantCoercion.res | 8 ++++++++ 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 2ef74286cb..707010883e 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -167,6 +167,7 @@ let can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes Error `PolyvariantConstructorHasPayload else let is_unboxed = Ast_untagged_variants.has_untagged type_attributes in + print_endline (string_of_bool is_unboxed); if List.for_all (fun polyvariant_value -> @@ -179,15 +180,21 @@ let can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes | Some (String as_runtime_string) -> (* `@as("")`, does the configured string match the polyvariant value? *) as_runtime_string = polyvariant_value - | Some (Untagged StringType) when is_unboxed -> - (* An unboxed variant that has a catch all case will match _any_ string, so it matches anything here. *) - true | Some _ -> (* Any other `@as` can't match since it's by definition not a string *) false | None -> - (* No `@as` means the runtime representation will be the constructor name as a string. *) - polyvariant_value = constructor_name)) + (* No `@as` means the runtime representation will be the constructor + name as a string. + + However, there's a special case with unboxed types where there's a + string catch-all case. In that case, any polyvariant will match, + since the catch-all case will match any string. *) + (match c.cd_args with + | Cstr_tuple [{desc=Tconstr (p, _, _)}] + when is_unboxed && Path.same p Predef.path_string -> true + | _ -> polyvariant_value = constructor_name) + )) polyvariant_runtime_representations then Ok () else Error `Unknown diff --git a/jscomp/test/VariantCoercion.res b/jscomp/test/VariantCoercion.res index 28e24bfd59..f8f0826f67 100644 --- a/jscomp/test/VariantCoercion.res +++ b/jscomp/test/VariantCoercion.res @@ -111,4 +111,12 @@ module CoerceFromPolyvariantToVariant = { let withMoreVariantConstructors: withMoreVariantConstructors = #One let withMoreVariantConstructorsP = (withMoreVariantConstructors :> withMoreVariantConstructorsP) + + type withUnboxedCatchAll = [#One | #someOtherThing] + + @unboxed + type withUnboxedCatchAllP = One | @as("two") Two | Three | Other(string) + + let withUnboxedCatchAll: withUnboxedCatchAll = #One + let withUnboxedCatchAllP = (withUnboxedCatchAll :> withUnboxedCatchAllP) } From 13d46b1f7e76fbc7156a8fd7990ff6a4ff78f472 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 26 Aug 2024 23:52:58 +0200 Subject: [PATCH 3/6] logic --- jscomp/ml/variant_coercion.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index 707010883e..ec21601459 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -190,9 +190,9 @@ let can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes However, there's a special case with unboxed types where there's a string catch-all case. In that case, any polyvariant will match, since the catch-all case will match any string. *) - (match c.cd_args with - | Cstr_tuple [{desc=Tconstr (p, _, _)}] - when is_unboxed && Path.same p Predef.path_string -> true + (match is_unboxed, c.cd_args with + | true, Cstr_tuple [{desc=Tconstr (p, _, _)}] -> + Path.same p Predef.path_string | _ -> polyvariant_value = constructor_name) )) polyvariant_runtime_representations From 183ba6c8257396a8a1541c48260f22520c2fb50d Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 26 Aug 2024 23:58:23 +0200 Subject: [PATCH 4/6] cleanup --- jscomp/ml/ctype.ml | 4 ++-- jscomp/ml/variant_coercion.ml | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml index a5dbb55979..950a1a598f 100644 --- a/jscomp/ml/ctype.ml +++ b/jscomp/ml/ctype.ml @@ -3704,8 +3704,8 @@ let rec subtype_rec env trace t1 t2 cstrs = | (Tvariant {row_closed=true; row_fields}, Tconstr (_, [], _)) when extract_concrete_typedecl_opt env t2 |> Variant_coercion.type_is_variant -> (match extract_concrete_typedecl env t2 with - | (_, _, {type_kind=Type_variant (constructors); type_attributes}) -> - (match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes with + | (_, _, {type_kind=Type_variant variant_constructors; type_attributes}) -> + (match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_attributes with | Ok _ -> cstrs | Error _ -> (trace, t1, t2, !univar_pairs)::cstrs) | _ -> (trace, t1, t2, !univar_pairs)::cstrs) diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml index ec21601459..d05e932007 100644 --- a/jscomp/ml/variant_coercion.ml +++ b/jscomp/ml/variant_coercion.ml @@ -152,11 +152,12 @@ let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc error = TagName {left_tag; right_tag}; })) -let can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes +let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_attributes = let polyvariant_runtime_representations = row_fields |> List.filter_map (fun (label, (field : Types.row_field)) -> + (* Check that there's no payload in the polyvariant *) match field with | Rpresent None -> Some label | _ -> None) @@ -167,11 +168,10 @@ let can_coerce_polyvariant_to_variant ~row_fields ~constructors ~type_attributes Error `PolyvariantConstructorHasPayload else let is_unboxed = Ast_untagged_variants.has_untagged type_attributes in - print_endline (string_of_bool is_unboxed); if List.for_all (fun polyvariant_value -> - constructors + variant_constructors |> List.exists (fun (c : Types.constructor_declaration) -> let constructor_name = Ident.name c.cd_id in match From 0eb44ef3a223da6e187b72482416367c8f9d2a7f Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 27 Aug 2024 10:30:42 +0200 Subject: [PATCH 5/6] add fixture tests for polyvariant to variant coercion --- .../variant_coercion_open_polyvariant.res.expected | 10 ++++++++++ ...cion_polyvariant_mismatch_as_attribute.res.expected | 10 ++++++++++ ...ion_polyvariant_mismatch_as_attribute2.res.expected | 10 ++++++++++ ...t_coercion_polyvariant_unmatched_cases.res.expected | 10 ++++++++++ ...iant_coercion_polyvariant_with_payload.res.expected | 10 ++++++++++ .../fixtures/variant_coercion_open_polyvariant.res | 5 +++++ ...iant_coercion_polyvariant_mismatch_as_attribute.res | 7 +++++++ ...ant_coercion_polyvariant_mismatch_as_attribute2.res | 7 +++++++ .../variant_coercion_polyvariant_unmatched_cases.res | 7 +++++++ .../variant_coercion_polyvariant_with_payload.res | 7 +++++++ jscomp/test/VariantCoercion.js | 4 +++- 11 files changed, 86 insertions(+), 1 deletion(-) create mode 100644 jscomp/build_tests/super_errors/expected/variant_coercion_open_polyvariant.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute2.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_unmatched_cases.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_with_payload.res.expected create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_coercion_open_polyvariant.res create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute.res create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute2.res create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_unmatched_cases.res create mode 100644 jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_with_payload.res diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_open_polyvariant.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_open_polyvariant.res.expected new file mode 100644 index 0000000000..09d50b5705 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_coercion_open_polyvariant.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_open_polyvariant.res:5:19-30 + + 3 │ let p = #One + 4 │ + 5 │ let v: variant = (p :> variant) + 6 │ + + Type [> #One] is not a subtype of variant \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute.res.expected new file mode 100644 index 0000000000..1cb2f9c5ca --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_polyvariant_mismatch_as_attribute.res:7:19-30 + + 5 │ let p: poly = #One + 6 │ + 7 │ let v: variant = (p :> variant) + 8 │ + + Type poly = [#One | #Two] is not a subtype of variant \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute2.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute2.res.expected new file mode 100644 index 0000000000..08645d2909 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_mismatch_as_attribute2.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_polyvariant_mismatch_as_attribute2.res:7:19-30 + + 5 │ let p: poly = #One + 6 │ + 7 │ let v: variant = (p :> variant) + 8 │ + + Type poly = [#One | #Two] is not a subtype of variant \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_unmatched_cases.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_unmatched_cases.res.expected new file mode 100644 index 0000000000..945199bd84 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_unmatched_cases.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_polyvariant_unmatched_cases.res:7:19-30 + + 5 │ let p: poly = #One + 6 │ + 7 │ let v: variant = (p :> variant) + 8 │ + + Type poly = [#One | #Two] is not a subtype of variant \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_with_payload.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_with_payload.res.expected new file mode 100644 index 0000000000..27dba4e3f0 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/variant_coercion_polyvariant_with_payload.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_polyvariant_with_payload.res:7:19-30 + + 5 │ let p: poly = #One + 6 │ + 7 │ let v: variant = (p :> variant) + 8 │ + + Type poly = [#One | #Two(string)] is not a subtype of variant \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_open_polyvariant.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_open_polyvariant.res new file mode 100644 index 0000000000..572de278a1 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_coercion_open_polyvariant.res @@ -0,0 +1,5 @@ +type variant = One | Two + +let p = #One + +let v: variant = (p :> variant) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute.res new file mode 100644 index 0000000000..11a48d12b2 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute.res @@ -0,0 +1,7 @@ +type poly = [#One | #Two] + +type variant = One | @as("two") Two + +let p: poly = #One + +let v: variant = (p :> variant) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute2.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute2.res new file mode 100644 index 0000000000..3d97a3a8cf --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_mismatch_as_attribute2.res @@ -0,0 +1,7 @@ +type poly = [#One | #Two] + +type variant = One | @as(2) Two + +let p: poly = #One + +let v: variant = (p :> variant) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_unmatched_cases.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_unmatched_cases.res new file mode 100644 index 0000000000..0299777fb5 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_unmatched_cases.res @@ -0,0 +1,7 @@ +type poly = [#One | #Two] + +type variant = One + +let p: poly = #One + +let v: variant = (p :> variant) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_with_payload.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_with_payload.res new file mode 100644 index 0000000000..cfc9501a97 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/variant_coercion_polyvariant_with_payload.res @@ -0,0 +1,7 @@ +type poly = [#One | #Two(string)] + +type variant = One | Two + +let p: poly = #One + +let v: variant = (p :> variant) diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js index 595af3d1a6..1cea8b731b 100644 --- a/jscomp/test/VariantCoercion.js +++ b/jscomp/test/VariantCoercion.js @@ -77,7 +77,9 @@ let CoerceFromPolyvariantToVariant = { withAs: "One", withAsP: "One", withMoreVariantConstructors: "One", - withMoreVariantConstructorsP: "One" + withMoreVariantConstructorsP: "One", + withUnboxedCatchAll: "One", + withUnboxedCatchAllP: "One" }; let a$2 = "Three"; From 892f2aa2e78a5e60d9af2ef2088c0d7152ffb28b Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 27 Aug 2024 10:32:07 +0200 Subject: [PATCH 6/6] changelog --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 189d7119b2..811f920637 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,10 @@ # 12.0.0-alpha.2 (Unreleased) +#### :rocket: New Feature + +- Allow coercing polyvariants to variants when we can guarantee that the runtime representation matches. https://github.com/rescript-lang/rescript-compiler/pull/6981 + #### :nail_care: Polish - Improve formatting in the generated js code. https://github.com/rescript-lang/rescript-compiler/pull/6932