Coerce polyvariant to variant (rescript-lang#6981)

* wip coerce polyvariant to variant

* fix unboxed catch-all

* logic

* cleanup

* add fixture tests for polyvariant to variant coercion

* changelog

Author: zth

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

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

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

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

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

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

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)

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)

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)

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)

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)

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 
       -> 

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

jscomp/test/VariantCoercion.js

@@ -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)
+}