sketch out variant-to-variant coercion

jscomp/ml/ctype.ml

@@ -3954,16 +3954,46 @@ 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
           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 _) ->

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

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