Fix issue with overlapping array and object in untagged variants.

Author: cristianoc

CHANGELOG.md

@@ -30,6 +30,7 @@
 - Make "rescript format" work with node 10 again and set minimum required node version to 10 in package.json. https://github.com/rescript-lang/rescript-compiler/pull/6186
 - Fix partial application for uncurried functions with labeled args https://github.com/rescript-lang/rescript-compiler/pull/6198
 - Add error messages for dangling doc comments/attributes and mutable in record type definition. https://github.com/rescript-lang/rescript-compiler/pull/6206
+- Fix issue with overlapping array and object in untagged variants https://github.com/rescript-lang/rescript-compiler/pull/6219
 
 # 11.0.0-alpha.4
 

jscomp/core/lam_compile.ml

@@ -625,11 +625,11 @@ and use_compile_literal_cases table ~(get_tag : _ -> Ast_untagged_variants.tag o
   ) table (Some [])
 and compile_cases
   ?(untagged=false) ~cxt ~(switch_exp : E.t) ?(default = NonComplete)
-  ?(get_tag = fun _ -> None) cases : initialization =
+  ?(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 ~default string_cases
+      then compile_untagged_cases ~cxt ~switch_exp ~block_cases ~default string_cases
       else compile_string_cases ~cxt ~switch_exp ~default string_cases
     | None ->
       cases |> compile_general_cases
@@ -688,13 +688,13 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
         block
         @
         if sw_consts_full && sw_consts = [] then
-          compile_cases
+          compile_cases ~block_cases
             ~untagged ~cxt
             ~switch_exp:(if untagged then e else E.tag ~name:tag_name e)
             ~default:sw_blocks_default
             ~get_tag:get_block_tag sw_blocks
         else if sw_blocks_full && sw_blocks = [] then
-          compile_cases ~cxt ~switch_exp:e ~default:sw_num_default ~get_tag:get_const_tag sw_consts
+          compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default ~get_tag:get_const_tag sw_consts
         else
           (* [e] will be used twice  *)
           let dispatch e =
@@ -706,11 +706,12 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
               else
                E.is_int_tag ~has_null_undefined_other:(has_null_undefined_other sw_names) e in
             S.if_ is_a_literal_case
-              (compile_cases ~cxt ~switch_exp:e ~default:sw_num_default ~get_tag:get_const_tag sw_consts)
+              (compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default ~get_tag:get_const_tag sw_consts)
             ~else_:
               (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)
           in
@@ -749,13 +750,13 @@ and compile_string_cases ~cxt ~switch_exp ~default cases: initialization  =
       S.string_switch ?default ?declaration e clauses)
     ~switch_exp
     ~default
-and compile_untagged_cases ~cxt ~switch_exp ~default cases =
+and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases 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 (Expr x) (Expr y)
+      Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type ~block_cases (Expr x) (Expr y)
     | _, Some tag_type ->
-      Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type (Expr y) (Expr x)
+      Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type ~block_cases (Expr y) (Expr x)
     | _ ->
       Ast_untagged_variants.DynamicChecks.(==) (Expr x) (Expr y)
     in

jscomp/ml/ast_untagged_variants.ml

@@ -328,11 +328,17 @@ module DynamicChecks = struct
     else (* (undefiled + other) || other *)
       typeof e != object_
 
-  let add_runtime_type_check ~tag_type x y = match tag_type with
+  let add_runtime_type_check ~tag_type ~(block_cases: block_type list) x y =
+    let has_array() = Ext_list.exists block_cases (fun t -> t = ArrayType) in
+    match tag_type with
     | Untagged IntType
     | Untagged StringType
-    | Untagged FloatType
-    | Untagged ObjectType -> typeof y == x 
+    | Untagged FloatType -> typeof y == x
+    | Untagged ObjectType ->
+      if has_array() then
+        typeof y == x &&& not (is_array y)
+      else
+        typeof y == x
     | Untagged ArrayType -> is_array y
     | Untagged UnknownType ->
       (* This should not happen because unknown must be the only non-literal case *)

jscomp/test/UntaggedVariants.js

@@ -239,13 +239,25 @@ module OverlapObject = {
 module RecordIsObject = {
   // @unboxed
   // this is not allowed
-  type r = {x:int}
+  type r = {x: int}
 
   @unboxed
-  type t = | Array(array<int>) | Record(r)
+  type t = Array(array<int>) | Record(r)
 
-  let classify = v => switch v {
+  let classify = v =>
+    switch v {
     | Record({x}) => x
     | Array(a) => a[0]
-  }
-}
+    }
+}
+
+module ArrayAndObject = {
+  @unboxed
+  type t = Record({x: int}) | Array(array<int>)
+
+  let classify = v =>
+    switch v {
+    | Record({x}) => x
+    | Array(a) => a[0]
+    }
+}