Keep cases handled by a default arm out of the arms a switch names

changes/untagged-default-arm.fix.md

@@ -0,0 +1 @@
+- Fix untagged variant switches with a default arm matching class instances in the object case and literals in a payload case of their kind.

compiler/core/lam_compile.ml

@@ -780,10 +780,34 @@ let compile output_prefix =
               | NonComplete, NonComplete -> true
               | _ -> false
             in
+            (* A literal handled by the default would otherwise pass the
+               check of a payload arm of its kind *)
+            let a_literal_reaches_an_arm () =
+              let arm_types =
+                Ext_list.filter_map sw_blocks (fun (key, _) ->
+                    match tag_of_switch_key key with
+                    | Some {tag_type = Some (Payload_shape block_type)} ->
+                      Some block_type
+                    | Some _ | None -> None)
+              in
+              Ext_list.exists literal_cases
+                (fun (literal : Variant_runtime.literal_tag) ->
+                  Ext_list.exists arm_types
+                    (fun (block_type : Variant_runtime.block_type) ->
+                      match (literal, block_type) with
+                      | String _, StringType
+                      | (Int _ | Float _), (IntType | FloatType)
+                      | BigInt _, BigintType
+                      | Bool _, BooleanType
+                      | _, UnknownType ->
+                        true
+                      | _, _ -> false))
+            in
             if
               untagged
               && List.length sw_consts = 0
               && eq_default sw_num_default sw_blocks_default
+              && not (a_literal_reaches_an_arm ())
             then
               let has_null_case = List.mem Variant_runtime.Null literal_cases in
               compile_cases ~untagged ~cxt
@@ -864,26 +888,25 @@ let compile output_prefix =
             | _ -> false)
           typeof_clauses
       in
-      let clauses_have_array_case =
-        List.exists
-          (function
-            | Variant_runtime.Payload_shape (InstanceType Array), _ -> true
-            | _ -> false)
-          not_typeof_clauses
-      in
-      let type_has_array_case =
-        List.exists
-          (function
-            | Variant_runtime.InstanceType Array -> true
-            | _ -> false)
-          block_cases
-      in
-      (* When there's an ObjectType typeof case, null and arrays can
-         incorrectly match it (typeof null === typeof [] === "object").
-         Guard against them when they should fall through to default. *)
+      (* When there's an ObjectType typeof case, null, arrays and class
+         instances can incorrectly match it (typeof null === typeof [] ===
+         "object"). Guard against them when they should fall through to
+         default: null, and the instance cases without an arm of their own. *)
       let needs_null_guard = has_object_typeof && has_null_case in
-      let needs_array_guard =
-        has_object_typeof && type_has_array_case && not clauses_have_array_case
+      let unmatched_instances =
+        if not has_object_typeof then []
+        else
+          Ext_list.filter_map block_cases (function
+            | Variant_runtime.InstanceType instance
+              when not
+                     (List.exists
+                        (function
+                          | Variant_runtime.Payload_shape (InstanceType i), _ ->
+                            i = instance
+                          | _ -> false)
+                        not_typeof_clauses) ->
+              Some instance
+            | _ -> None)
       in
       let rec build_if_chain remaining_clauses =
         match remaining_clauses with
@@ -898,12 +921,16 @@ let compile output_prefix =
           let typeof_switch () =
             S.string_switch ?default ?declaration (E.typeof e) typeof_clauses
           in
+          let guards =
+            (if needs_null_guard then [E.is_null e] else [])
+            @ List.map
+                (fun instance -> E.emit_check (IsInstanceOf (instance, Expr e)))
+                unmatched_instances
+          in
           let guard =
-            match (needs_null_guard, needs_array_guard) with
-            | true, true -> Some (E.or_ (E.is_null e) (E.is_array e))
-            | true, false -> Some (E.is_null e)
-            | false, true -> Some (E.is_array e)
-            | false, false -> None
+            match guards with
+            | [] -> None
+            | first :: rest -> Some (List.fold_left E.or_ first rest)
           in
           match (guard, default) with
           | Some guard, Some default_body ->

compiler/ml/UntaggedVariants.md

@@ -192,7 +192,10 @@ constructor:
 The "is a literal case" test is the smaller of two equivalent expressions: the
 disjunction of `x === literal` over the literal cases, or the conjunction of
 the negated payload checks (with a payload check replaced by the literal
-disjunction where a literal overlaps it).
+disjunction where a literal overlaps it). A `switch` whose arms name no
+literal case still tests the literals first when one of them would pass the
+check of a payload arm, such as `@as("lit")` beside a `string` arm, so that
+it reaches the default arm.
 
 - Implementation: `lam_compile.ml:compile_switch`,
   `ast_untagged_variants.ml:Dynamic_checks.is_a_literal_case`.
@@ -227,12 +230,13 @@ number, integral or not.
 
 ### 9. `null` and arrays are not objects
 
-`typeof null` and `typeof []` are `"object"`. The object case never receives
-`null` when the variant has an `@as(null)` case, and never receives an array
-when the variant has an array or tuple case: the two-arm form adds the checks
-of rule 8, and the `switch (typeof x)` form is preceded by
-`x === null` / `Array.isArray(x)` guards that send those values to the default
-arm when their own arm is absent.
+`typeof null` and `typeof []` are `"object"`, and so is the `typeof` of a
+class instance. The object case never receives `null` when the variant has an
+`@as(null)` case, and never receives a value of another instance case (array,
+tuple or class): the two-arm form adds the checks of rule 8, and the
+`switch (typeof x)` form is preceded by `x === null`, `Array.isArray(x)` and
+`x instanceof C` guards that send those values to the default arm when their
+own arm is absent.
 
 | Declaration | `switch` arms | Value | Arm |
 | --- | --- | --- | --- |
@@ -241,9 +245,10 @@ arm when their own arm is absent.
 | | `GObject(_)`, `_` | `[]`, `null` | `_` |
 
 - Implementation: `lam_compile.ml:compile_untagged_cases` (`needs_null_guard`,
-  `needs_array_guard`), `Dynamic_checks.add_runtime_type_check`.
-- Tests: `spec_test` rule 9; `UntaggedVariants.res` (`ObjectAndNull`, `Json`).
-- Shaped by #6219, #7303, #8253, #8255, #8279.
+  `unmatched_instances`), `Dynamic_checks.add_runtime_type_check`.
+- Tests: `spec_test` rule 9; `UntaggedVariants.res` (`ObjectAndNull`, `Json`);
+  `tests/tests/src/untagged_default_arm_test.res`.
+- Shaped by #6219, #7303, #8253, #8255, #8279, #8995.
 
 ### 10. Values outside every case
 

tests/tests/src/untagged_default_arm_test.mjs

@@ -0,0 +1,63 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+import * as Mocha from "mocha";
+import * as Test_utils from "./test_utils.mjs";
+
+function id(x) {
+  return x;
+}
+
+function objectOrString(value) {
+  if (value instanceof RegExp || value instanceof Date) {
+    return "other";
+  }
+  switch (typeof value) {
+    case "object" :
+      return "O";
+    case "string" :
+      return "S";
+    default:
+      return "other";
+  }
+}
+
+function textOrRecord(value) {
+  if (value === "lit") {
+    return "other";
+  }
+  switch (typeof value) {
+    case "string" :
+      return "text";
+    case "object" :
+      return "record";
+    default:
+      return "other";
+  }
+}
+
+Mocha.describe("Untagged_default_arm_test", () => {
+  Mocha.test("an instance handled by the default is not an object case", () => {
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 31, characters 7-14", "other", objectOrString(id(new Date())));
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 32, characters 7-14", "other", objectOrString(id(/a/)));
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 33, characters 7-14", "O", objectOrString(id({
+      x: 1
+    })));
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 34, characters 7-14", "S", objectOrString(id("s")));
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 35, characters 7-14", "other", objectOrString(id(1)));
+  });
+  Mocha.test("a literal handled by the default is not a string case", () => {
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 39, characters 7-14", "other", textOrRecord(id("lit")));
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 40, characters 7-14", "text", textOrRecord(id("lit2")));
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 41, characters 7-14", "record", textOrRecord(id({
+      x: 1
+    })));
+    Test_utils.eq("File \"untagged_default_arm_test.res\", line 42, characters 7-14", "other", textOrRecord(id(1)));
+  });
+});
+
+export {
+  id,
+  objectOrString,
+  textOrRecord,
+}
+/*  Not a pure module */

tests/tests/src/untagged_default_arm_test.res

@@ -0,0 +1,44 @@
+open Mocha
+open Test_utils
+
+@inline(never) let id = x => x
+
+// A switch with a default arm keeps the cases it does not name out of the
+// arms it names (#8995)
+@unboxed
+type instances = D(Date.t) | R(RegExp.t) | O({x: int}) | S(string) | I(int) | F(int => int)
+
+let objectOrString = value =>
+  switch value {
+  | O(_) => "O"
+  | S(_) => "S"
+  | _ => "other"
+  }
+
+@unboxed
+type literals =
+  | @as("lit") Lit | Text(string) | Count(int) | Flag(bool) | Rec({x: int}) | Fn(int => int)
+
+let textOrRecord = value =>
+  switch value {
+  | Text(_) => "text"
+  | Rec(_) => "record"
+  | _ => "other"
+  }
+
+describe(__MODULE__, () => {
+  test("an instance handled by the default is not an object case", () => {
+    eq(__LOC__, "other", objectOrString(id(D(Date.make()))))
+    eq(__LOC__, "other", objectOrString(id(R(/a/))))
+    eq(__LOC__, "O", objectOrString(id(O({x: 1}))))
+    eq(__LOC__, "S", objectOrString(id(S("s"))))
+    eq(__LOC__, "other", objectOrString(id(I(1))))
+  })
+
+  test("a literal handled by the default is not a string case", () => {
+    eq(__LOC__, "other", textOrRecord(id(Lit)))
+    eq(__LOC__, "text", textOrRecord(id(Text("lit2"))))
+    eq(__LOC__, "record", textOrRecord(id(Rec({x: 1}))))
+    eq(__LOC__, "other", textOrRecord(id(Count(1))))
+  })
+})