handle inline records in variant coercion

Author: zth

jscomp/ml/ctype.ml

@@ -3979,16 +3979,23 @@ let rec subtype_rec env trace t1 t2 cstrs =
                   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_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
+                          let lst = subtype_list env trace tl1 tl2 cstrs in
+                          List.length lst = List.length cstrs
                         with | _ -> false end
                       else false
                   | _ -> false)
@@ -4003,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

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)

jscomp/test/VariantCoercion.js

@@ -17,10 +17,16 @@ 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
+  @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)
 }