Fix issue with untagged variants and object when null is one case.

Fixes #7289

The check emitted for case `Object` was simply `type of ... === "object"`, though that is insufficient when the variant has one case corresponding to `null`.
Now we check if such a variant case exists, and emit `... != null` in addition.

Author: cristianoc

compiler/core/lam_compile.ml

@@ -638,14 +638,14 @@ let compile output_prefix =
           Some ((String name, lam) :: string_table)
         | _, _ -> None)
       table (Some [])
-  and compile_cases ?(untagged = false) ~cxt ~(switch_exp : E.t)
-      ?(default = NonComplete) ?(get_tag = fun _ -> None) ?(block_cases = [])
-      cases : initialization =
+  and compile_cases ?(untagged = false) ?(has_null_case = false) ~cxt
+      ~(switch_exp : E.t) ?(default = NonComplete) ?(get_tag = fun _ -> None)
+      ?(block_cases = []) cases : initialization =
     match use_compile_literal_cases cases ~get_tag with
     | Some string_cases ->
       if untagged then
         compile_untagged_cases ~cxt ~switch_exp ~block_cases ~default
-          string_cases
+          ~has_null_case string_cases
       else compile_string_cases ~cxt ~switch_exp ~default string_cases
     | None ->
       cases
@@ -718,7 +718,7 @@ let compile output_prefix =
         else
           (* [e] will be used twice  *)
           let dispatch e =
-            let is_a_literal_case =
+            let is_a_literal_case () =
               if untagged then
                 E.is_a_literal_case
                   ~literal_cases:(get_literal_cases sw_names)
@@ -740,13 +740,17 @@ let compile output_prefix =
               && List.length sw_consts = 0
               && eq_default sw_num_default sw_blocks_default
             then
+              let literal_cases = get_literal_cases sw_names in
+              let has_null_case =
+                List.mem Ast_untagged_variants.Null literal_cases
+              in
               compile_cases ~untagged ~cxt
                 ~switch_exp:(if untagged then e else E.tag ~name:tag_name e)
-                ~block_cases ~default:sw_blocks_default ~get_tag:get_block_tag
-                sw_blocks
+                ~block_cases ~has_null_case ~default:sw_blocks_default
+                ~get_tag:get_block_tag sw_blocks
             else
               [
-                S.if_ is_a_literal_case
+                S.if_ (is_a_literal_case ())
                   (compile_cases ~cxt ~switch_exp:e ~block_cases
                      ~default:sw_num_default ~get_tag:get_const_tag sw_consts)
                   ~else_:
@@ -789,16 +793,17 @@ let compile output_prefix =
          ~switch:(fun ?default ?declaration e clauses ->
            S.string_switch ?default ?declaration e clauses)
          ~switch_exp ~default
-  and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases cases =
+  and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases
+      ~has_null_case cases =
     let mk_eq (i : Ast_untagged_variants.tag_type option) x j y =
       let check =
         match (i, j) with
         | Some tag_type, _ ->
           Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type
-            ~block_cases (Expr x) (Expr y)
+            ~has_null_case ~block_cases (Expr x) (Expr y)
         | _, Some tag_type ->
           Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type
-            ~block_cases (Expr y) (Expr x)
+            ~has_null_case ~block_cases (Expr y) (Expr x)
         | _ -> Ast_untagged_variants.DynamicChecks.( == ) (Expr x) (Expr y)
       in
       E.emit_check check

compiler/ml/ast_untagged_variants.ml

@@ -535,7 +535,8 @@ module DynamicChecks = struct
     else (* (undefiled + other) || other *)
       typeof e != object_
 
-  let add_runtime_type_check ~tag_type ~(block_cases : block_type list) x y =
+  let add_runtime_type_check ~tag_type ~has_null_case
+      ~(block_cases : block_type list) x y =
     let instances =
       Ext_list.filter_map block_cases (function
         | InstanceType i -> Some i
@@ -547,14 +548,16 @@ module DynamicChecks = struct
         | FunctionType ) ->
       typeof y == x
     | Untagged ObjectType ->
+      let object_case =
+        if has_null_case then typeof y == x &&& (y != nil) else typeof y == x
+      in
       if instances <> [] then
         let not_one_of_the_instances =
-          Ext_list.fold_right instances
-            (typeof y == x)
-            (fun i x -> x &&& not (is_instance i y))
+          Ext_list.fold_right instances object_case (fun i x ->
+              x &&& not (is_instance i y))
         in
         not_one_of_the_instances
-      else typeof y == x
+      else object_case
     | Untagged (InstanceType i) -> is_instance i y
     | Untagged UnknownType ->
       (* This should not happen because unknown must be the only non-literal case *)

tests/tests/src/core/Core_JsonTests.mjs

@@ -5,9 +5,9 @@ import * as Test from "./Test.mjs";
 function decodeJsonTest() {
   let json = {"someProp":{"otherProp": null, "thirdProp": [true, false]}};
   let decodedCorrectly;
-  if (typeof json === "object" && !Array.isArray(json)) {
+  if (typeof json === "object" && json !== null && !Array.isArray(json)) {
     let match = json["someProp"];
-    if (typeof match === "object" && !Array.isArray(match)) {
+    if (typeof match === "object" && match !== null && !Array.isArray(match)) {
       let match$1 = match["thirdProp"];
       if (Array.isArray(match$1) && match$1.length === 2) {
         let match$2 = match$1[0];

tests/tests/src/json_decorders.mjs

@@ -3,7 +3,7 @@
 import * as Stdlib_Array from "rescript/lib/es6/Stdlib_Array.js";
 
 function decodeUser(json) {
-  if (typeof json !== "object" || Array.isArray(json)) {
+  if (typeof json !== "object" || json === null || Array.isArray(json)) {
     return;
   }
   let id = json.id;
@@ -30,7 +30,7 @@ function decodeUser(json) {
 }
 
 function decodeGroup(json) {
-  if (typeof json !== "object" || Array.isArray(json)) {
+  if (typeof json !== "object" || json === null || Array.isArray(json)) {
     return;
   }
   let id = json.id;