Compare the @as tags of variant cases with payloads across signatures

changes/variant-payload-tags-signature.fix.md

@@ -0,0 +1 @@
+- Reject an implementation whose variant cases with a payload have other `@as` tags than the interface states, and print those tags in type declarations.

compiler/ml/UntaggedVariants.md

@@ -338,8 +338,10 @@ value. An inline-record field whose runtime name equals the tag field is an
 error.
 
 An interface and its implementation must agree on `@unboxed`, on `@tag`, and
-on the literal of every nullary case. They are not compared on the `@as` of
-cases with a payload (see Known bugs).
+on the literal of every nullary case and of every tagged case with a payload.
+The `@as` of an untagged case with a payload does not change its
+representation (rule 2) and is not compared. Type declarations in messages
+print the `@as` of nullary and tagged cases.
 
 - Implementation: `variant_layout.ml:layout_from_type_variant`,
   `ast_untagged_variants.ml:process_tag_name`, `check_tag_field_conflicts`;
@@ -348,8 +350,8 @@ cases with a payload (see Known bugs).
   `variant_tag_overlaps_with_field.res`, `UntaggedInvalidVariantTagAnnotation.res`,
   `UntaggedImplIntf.res`; `tests/build_tests/super_errors_multi/fixtures/`
   `Iface_unboxed_variant_mismatch`, `Iface_tag_name_mismatch`,
-  `Iface_variant_representation_mismatch`.
-- Shaped by #6498, #6513, #6669, #7875.
+  `Iface_variant_representation_mismatch`; `variant_payload_tag_mismatch.res`.
+- Shaped by #6498, #6513, #6669, #7875, #8956.
 
 ## Known bugs
 
@@ -390,20 +392,6 @@ let f = v => switch v { | I8(_) => "i8" | U8(_) => "u8" }
 Console.log(f(I8(Uint8Array.fromArray([1]))))   // u8
 ```
 
-**Payload-case tags are not compared across a signature.** Rule 14 compares
-only the literals of nullary cases.
-
-```rescript
-module M: {
-  type t = A({x: int}) | C({x: int})
-  let a: t
-} = {
-  type t = | @as("C") A({x: int}) | @as("A") C({x: int})
-  let a = A({x: 1})
-}
-Console.log(switch M.a { | M.A(_) => "A" | M.C(_) => "C" })   // C
-```
-
 ## Open questions
 
 These are the decisions a general mechanism for recognizing payloads by class

compiler/ml/includecore.ml

@@ -271,7 +271,17 @@ and compare_variants ~loc env params1 params2 ~layout1 ~layout2 n
             let tag_type2 = Variant_runtime.constructor_tag layout2 (n - 1) in
             if tag_type1 <> tag_type2 then [Variant_representation cd1.cd_id]
             else []
-          | false -> r
+          | false -> (
+            (* A tagged case with a payload carries its tag in the object;
+               an untagged one is its payload, whatever its [@as] *)
+            match
+              ( Variant_runtime.constructor_at layout1 (n - 1),
+                Variant_runtime.constructor_at layout2 (n - 1) )
+            with
+            | Block (Tagged {tag = tag1}), Block (Tagged {tag = tag2})
+              when tag1.literal <> tag2.literal ->
+              [Variant_representation cd1.cd_id]
+            | _ -> r)
       in
       if r <> [] then r
       else

compiler/ml/printtyp.ml

@@ -909,9 +909,17 @@ and tree_of_constructor_arguments ?printing_context = function
 
 and tree_of_constructor ?printing_context ~layout ~position cd =
   let name = Ident.name cd.cd_id in
-  let nullary = Ast_untagged_variants.is_nullary_variant cd.cd_args in
+  (* The [@as] of a nullary case or of a tagged case with a payload sets its
+     runtime tag; an untagged case is its payload *)
+  let tagged =
+    Ast_untagged_variants.is_nullary_variant cd.cd_args
+    ||
+    match Variant_runtime.constructor_at layout position with
+    | Block (Tagged _) -> true
+    | Block (Untagged _) | Constant _ -> false
+  in
   let repr =
-    if not nullary then None
+    if not tagged then None
     else
       let as_annotation = function
         | Variant_runtime.Null -> "@as(null)"

tests/build_tests/super_errors/expected/variant_payload_tag_mismatch.res.expected

@@ -0,0 +1,24 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_payload_tag_mismatch.res:5:5-8:1
+
+   3 │   type t = A({x: int}) | C({x: int})
+   4 │   let a: t
+   5 │ } = {
+   6 │   type t = | @as("C") A({x: int}) | @as("A") C({x: int})
+   7 │   let a = A({x: 1})
+   8 │ }
+   9 │ Console.log(
+  10 │   switch M.a {
+
+  Signature mismatch:
+  ...
+  Type declarations do not match:
+    type t = @as("C") A({x: int}) | @as("A") C({x: int})
+  is not included in
+    type t = A({x: int}) | C({x: int})
+  /.../fixtures/variant_payload_tag_mismatch.res:3:3-36:
+    Expected declaration
+  /.../fixtures/variant_payload_tag_mismatch.res:6:3-56:
+    Actual declaration
+  The internal representations for case A are not equal.

tests/build_tests/super_errors/fixtures/variant_payload_tag_mismatch.res

@@ -0,0 +1,14 @@
+// Payload cases swapped by @as across a signature (#8956)
+module M: {
+  type t = A({x: int}) | C({x: int})
+  let a: t
+} = {
+  type t = | @as("C") A({x: int}) | @as("A") C({x: int})
+  let a = A({x: 1})
+}
+Console.log(
+  switch M.a {
+  | M.A(_) => "A"
+  | M.C(_) => "C"
+  },
+)