Check variants with some @unboxed constructors like untagged ones

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.

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

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.

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).

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<int>) | 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.

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

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

tests/build_tests/super_errors/fixtures/untagged_mixed_unknown_payload.res

@@ -0,0 +1,7 @@
+type t = | @unboxed A(list<int>) | B({x: int}) | C
+let f = x =>
+  switch x {
+  | A(_) => "a"
+  | B(_) => "b"
+  | C => "c"
+  }

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 */

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