Coerce polyvariant to variant (#6981)

zth · web-flow · commit c8ed22770702 · 2024-08-27T10:50:28.000+02:00
* wip coerce polyvariant to variant

* fix unboxed catch-all

* logic

* cleanup

* add fixture tests for polyvariant to variant coercion

* changelog
diff --git 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
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_open_polyvariant.res[0m:[2m5:19-30[0m
+
+  3 [2m│[0m let p = #One
+  4 [2m│[0m 
+  [1;31m5[0m [2m│[0m let v: variant = ([1;31mp :> variant[0m)
+  6 [2m│[0m 
+
+  Type [> #One] is not a subtype of variant
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_polyvariant_mismatch_as_attribute.res[0m:[2m7:19-30[0m
+
+  5 [2m│[0m let p: poly = #One
+  6 [2m│[0m 
+  [1;31m7[0m [2m│[0m let v: variant = ([1;31mp :> variant[0m)
+  8 [2m│[0m 
+
+  Type poly = [#One | #Two] is not a subtype of variant
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_polyvariant_mismatch_as_attribute2.res[0m:[2m7:19-30[0m
+
+  5 [2m│[0m let p: poly = #One
+  6 [2m│[0m 
+  [1;31m7[0m [2m│[0m let v: variant = ([1;31mp :> variant[0m)
+  8 [2m│[0m 
+
+  Type poly = [#One | #Two] is not a subtype of variant
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_polyvariant_unmatched_cases.res[0m:[2m7:19-30[0m
+
+  5 [2m│[0m let p: poly = #One
+  6 [2m│[0m 
+  [1;31m7[0m [2m│[0m let v: variant = ([1;31mp :> variant[0m)
+  8 [2m│[0m 
+
+  Type poly = [#One | #Two] is not a subtype of variant
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_polyvariant_with_payload.res[0m:[2m7:19-30[0m
+
+  5 [2m│[0m let p: poly = #One
+  6 [2m│[0m 
+  [1;31m7[0m [2m│[0m let v: variant = ([1;31mp :> variant[0m)
+  8 [2m│[0m 
+
+  Type poly = [#One | #Two(string)] is not a subtype of variant
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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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/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 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)
     | 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
@@ -151,3 +151,55 @@ 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 ~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)
+  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 ->
+          variant_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 _ ->
+                    (* 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.
+                      
+                      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 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
+    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
diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js
diff --git a/jscomp/test/VariantCoercion.res b/jscomp/test/VariantCoercion.res
@@ -92,3 +92,31 @@ 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)
+
+  type withUnboxedCatchAll = [#One | #someOtherThing]
+
+  @unboxed
+  type withUnboxedCatchAllP = One | @as("two") Two | Three | Other(string)
+
+  let withUnboxedCatchAll: withUnboxedCatchAll = #One
+  let withUnboxedCatchAllP = (withUnboxedCatchAll :> withUnboxedCatchAllP)
+}

-Original file line number
+Diff line change
@@ @@ -0,0 +1,10 @@ @@
++
 +  [1;31mWe've found a bug for you![0m
 +  [36m/.../fixtures/variant_coercion_open_polyvariant.res[0m:[2m5:19-30[0m
++
 +  3 [2m│[0m let p = #One
 +  4 [2m│[0m
 +  [1;31m5[0m [2m│[0m let v: variant = ([1;31mp :> variant[0m)
 +  6 [2m│[0m
++
 +  Type [> #One] is not a subtype of variant