diff --git a/changes/mixed-variant-checks.fix.md b/changes/mixed-variant-checks.fix.md new file mode 100644 index 0000000000..bcb7eec2cf --- /dev/null +++ b/changes/mixed-variant-checks.fix.md @@ -0,0 +1 @@ +- Check variants with some `@unboxed` constructors like untagged variants, so that cases a match cannot tell apart are rejected, and an untagged case's `@as` no longer clashes with a tagged case's tag. diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index e89c0660f5..fd3538bdc4 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -297,7 +297,30 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) Ext_list.rev_iter consts (fun (loc, literal) -> check_literal ~is_const:true ~loc literal); - if is_untagged_def then + (* A tagged block is told apart from the others by its tag; an untagged one + is its payload, whatever its [@as] *) + Ext_list.rev_iter blocks (fun (loc, block) -> + match block with + | Tagged {tag} -> check_literal ~is_const:false ~loc tag + | Untagged _ -> ()); + (* The payload kinds are checked as soon as one case is untagged, even when + the type itself is not [@unboxed] *) + let has_untagged_block = + List.exists + (function + | _, Untagged _ -> true + | _, Tagged _ -> false) + blocks + in + if is_untagged_def || has_untagged_block then ( + (* Tagged blocks are objects with a tag field: together one object case *) + if + List.exists + (function + | _, Tagged _ -> true + | _, Untagged _ -> false) + blocks + then incr object_types; Ext_list.rev_iter blocks (fun (loc, block) -> match block with | Untagged {tag; block_type} -> @@ -328,14 +351,7 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) incr boolean_types | StringType -> incr string_types); invariant loc tag.name - | Tagged _ -> ()) - else - Ext_list.rev_iter blocks (fun (loc, block) -> - let tag = - match block with - | Tagged {tag} | Untagged {tag} -> tag - in - check_literal ~is_const:false ~loc tag) + | Tagged _ -> ())) let get_cstr_loc_tag (cstr : Types.constructor_declaration) = (cstr.cd_loc, {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag}) diff --git a/tests/build_tests/super_errors/expected/untagged_mixed_object_and_tagged.res.expected b/tests/build_tests/super_errors/expected/untagged_mixed_object_and_tagged.res.expected new file mode 100644 index 0000000000..b8546679d2 --- /dev/null +++ b/tests/build_tests/super_errors/expected/untagged_mixed_object_and_tagged.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/untagged_mixed_object_and_tagged.res:1:10-31 + + 1 │ type t = | @unboxed A({x: int}) | B({y: int}) | C + 2 │ let f = x => + 3 │ switch x { + + This untagged variant definition is invalid: At most one case can be an object type. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/untagged_mixed_two_numbers.res.expected b/tests/build_tests/super_errors/expected/untagged_mixed_two_numbers.res.expected new file mode 100644 index 0000000000..0efbcc2da7 --- /dev/null +++ b/tests/build_tests/super_errors/expected/untagged_mixed_two_numbers.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/untagged_mixed_two_numbers.res:1:28-44 + + 1 │ type t = | @unboxed A(int) | @unboxed B(int) | C + 2 │ let f = x => + 3 │ switch x { + + This untagged variant definition is invalid: At most one case can be a number type (int or float). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/untagged_mixed_unknown_payload.res.expected b/tests/build_tests/super_errors/expected/untagged_mixed_unknown_payload.res.expected new file mode 100644 index 0000000000..c004087eed --- /dev/null +++ b/tests/build_tests/super_errors/expected/untagged_mixed_unknown_payload.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/untagged_mixed_unknown_payload.res:1:10-32 + + 1 │ type t = | @unboxed A(list) | B({x: int}) | C + 2 │ let f = x => + 3 │ switch x { + + This untagged variant definition is invalid: Case A has a payload that is not of one of the recognized shapes (object, array, etc). Then it must be the only case with payloads. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/untagged_mixed_object_and_tagged.res b/tests/build_tests/super_errors/fixtures/untagged_mixed_object_and_tagged.res new file mode 100644 index 0000000000..3373b6b72a --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/untagged_mixed_object_and_tagged.res @@ -0,0 +1,8 @@ +type t = | @unboxed A({x: int}) | B({y: int}) | C +let f = x => + switch x { + | A(_) => "a" + | B(_) => "b" + | C => "c" + } +let r = f(A({x: 1})) diff --git a/tests/build_tests/super_errors/fixtures/untagged_mixed_two_numbers.res b/tests/build_tests/super_errors/fixtures/untagged_mixed_two_numbers.res new file mode 100644 index 0000000000..4faca17526 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/untagged_mixed_two_numbers.res @@ -0,0 +1,7 @@ +type t = | @unboxed A(int) | @unboxed B(int) | C +let f = x => + switch x { + | A(_) => "a" + | B(_) => "b" + | C => "c" + } diff --git a/tests/build_tests/super_errors/fixtures/untagged_mixed_unknown_payload.res b/tests/build_tests/super_errors/fixtures/untagged_mixed_unknown_payload.res new file mode 100644 index 0000000000..19ab89d449 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/untagged_mixed_unknown_payload.res @@ -0,0 +1,7 @@ +type t = | @unboxed A(list) | B({x: int}) | C +let f = x => + switch x { + | A(_) => "a" + | B(_) => "b" + | C => "c" + } diff --git a/tests/tests/src/untagged_mixed_test.mjs b/tests/tests/src/untagged_mixed_test.mjs new file mode 100644 index 0000000000..e6c6dc5ede --- /dev/null +++ b/tests/tests/src/untagged_mixed_test.mjs @@ -0,0 +1,35 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +function kind(value) { + if (value === "C") { + return "c"; + } else if (typeof value === "number") { + return "a"; + } else { + return "b"; + } +} + +function id(x) { + return x; +} + +Mocha.describe("Untagged_mixed_test", () => { + Mocha.test("an untagged case's @as is not a tag", () => { + Test_utils.eq("File \"untagged_mixed_test.res\", line 20, characters 7-14", kind(id(1)), "a"); + Test_utils.eq("File \"untagged_mixed_test.res\", line 21, characters 7-14", kind(id({ + TAG: "x", + y: 1 + })), "b"); + Test_utils.eq("File \"untagged_mixed_test.res\", line 22, characters 7-14", kind(id("C")), "c"); + }); +}); + +export { + kind, + id, +} +/* Not a pure module */ diff --git a/tests/tests/src/untagged_mixed_test.res b/tests/tests/src/untagged_mixed_test.res new file mode 100644 index 0000000000..b92bb41f50 --- /dev/null +++ b/tests/tests/src/untagged_mixed_test.res @@ -0,0 +1,24 @@ +open Mocha +open Test_utils + +// In a variant with some @unboxed cases, the @as of an untagged case does not +// change its representation, so it does not clash with a tagged case's tag +// (#9020) +type t = | @unboxed @as("x") A(int) | @as("x") B({y: int}) | C + +let kind = value => + switch value { + | A(_) => "a" + | B(_) => "b" + | C => "c" + } + +@inline(never) let id = x => x + +describe(__MODULE__, () => { + test("an untagged case's @as is not a tag", () => { + eq(__LOC__, kind(id(A(1))), "a") + eq(__LOC__, kind(id(B({y: 1}))), "b") + eq(__LOC__, kind(id(C)), "c") + }) +})