From ed8d4a46c8a14d83fff94c020aaba4d5a7ca57e7 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 06:14:45 +0000 Subject: [PATCH] Compare the @as tags of variant cases with payloads across signatures Why: Interface inclusion compared the `@as` literal of nullary cases only. An implementation could swap the tags of two cases with payloads, and its clients then matched `M.A(_)` as `C` (#8956). The tags of tagged cases with a payload are compared as those of nullary cases are. An untagged case's `@as` does not change its representation and is not compared. Type declarations in messages now print the `@as` of a tagged case with a payload too, so the mismatch shows. Diagnostic added: Example: module M: { type t = A({x: int}) | C({x: int}) } = { type t = | @as("C") A({x: int}) | @as("A") C({x: int}) } After (diagnostic): 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}) The internal representations for case A are not equal. Fixes: #8956 Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- changes/variant-payload-tags-signature.fix.md | 1 + compiler/ml/UntaggedVariants.md | 24 +++++-------------- compiler/ml/includecore.ml | 12 +++++++++- compiler/ml/printtyp.ml | 12 ++++++++-- .../variant_payload_tag_mismatch.res.expected | 24 +++++++++++++++++++ .../fixtures/variant_payload_tag_mismatch.res | 14 +++++++++++ 6 files changed, 66 insertions(+), 21 deletions(-) create mode 100644 changes/variant-payload-tags-signature.fix.md create mode 100644 tests/build_tests/super_errors/expected/variant_payload_tag_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/variant_payload_tag_mismatch.res diff --git a/changes/variant-payload-tags-signature.fix.md b/changes/variant-payload-tags-signature.fix.md new file mode 100644 index 0000000000..3757d750ad --- /dev/null +++ b/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. diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index a3e21a8352..5d94bc6fc6 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/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 diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 712958ff8b..d775bfdd74 100644 --- a/compiler/ml/includecore.ml +++ b/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 diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 34788d96e7..a271e464b4 100644 --- a/compiler/ml/printtyp.ml +++ b/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)" diff --git a/tests/build_tests/super_errors/expected/variant_payload_tag_mismatch.res.expected b/tests/build_tests/super_errors/expected/variant_payload_tag_mismatch.res.expected new file mode 100644 index 0000000000..ce553258fa --- /dev/null +++ b/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. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/variant_payload_tag_mismatch.res b/tests/build_tests/super_errors/fixtures/variant_payload_tag_mismatch.res new file mode 100644 index 0000000000..fa7a6305b6 --- /dev/null +++ b/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" + }, +)