Fix option unboxing logic in the presence of untagged variants

Fixes #6222

Author: cristianoc

CHANGELOG.md

@@ -19,6 +19,7 @@
 #### :bug: Bug Fix
 
 - Remove unnecessary require and import statements when using dynamic imports. https://github.com/rescript-lang/rescript-compiler/pull/6232
+- Fix option unboxing logic in the presence of untagged variants. https://github.com/rescript-lang/rescript-compiler/pull/6233
 
 #### :nail_care: Polish
 

jscomp/ml/ast_untagged_variants.ml

@@ -99,6 +99,12 @@ let () =
         None
     )
 
+let type_is_builtin_object (t:Types.type_expr) = match t.desc with
+ | Tconstr (path, _, _) ->
+  let name = Path.name path in
+  name = "Js.Dict.t" || name = "Js_dict.t"
+| _ -> false
+
 let get_block_type ~env (cstr: Types.constructor_declaration) : block_type option =
   match process_untagged cstr.cd_attributes, cstr.cd_args with
   | false, _ -> None
@@ -112,9 +118,7 @@ let get_block_type ~env (cstr: Types.constructor_declaration) : block_type optio
       Some ArrayType
   | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path. same path Predef.path_string ->
       Some StringType
-  | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when
-    let name = Path.name path in
-    name = "Js.Dict.t" || name = "Js_dict.t" ->
+  | true, Cstr_tuple [{desc = Tconstr _} as t] when type_is_builtin_object t ->
       Some ObjectType
   | true, Cstr_tuple [ty] ->
     let default = Some UnknownType in
@@ -242,6 +246,12 @@ let names_from_type_variant ?(isUntaggedDef=false) ~env (cstrs : Types.construct
 let check_well_formed ~env ~isUntaggedDef (cstrs: Types.constructor_declaration list) =
   ignore (names_from_type_variant ~env ~isUntaggedDef cstrs)
 
+let has_undefined_literal attrs =
+  process_tag_type attrs = Some Undefined
+
+let block_is_object ~env attrs =
+  get_block_type ~env attrs = Some ObjectType
+
 module DynamicChecks = struct
 
   type op = EqEqEq | NotEqEq | Or | And

jscomp/ml/typeopt.ml

@@ -44,34 +44,57 @@ let scrape env ty =
      records the type at the definition type so for ['a option]
      it will always be [Tvar]
 *)
-let cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) =
+let rec cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) =
   match scrape env typ with
   |  Tconstr(p, _,_) ->
       (* all built in types could not inhabit none-like values:
          int, char, float, bool, unit, exn, array, list, nativeint,
          int32, int64, lazy_t, bytes
       *)
       (match Predef.type_is_builtin_path_but_option p with
-      | For_sure_yes ->  true
+      | For_sure_yes -> true
       | For_sure_no -> false
-      | NA -> 
-      
-        begin match (Env.find_type p env).type_kind with
+      | NA ->
+        let untagged = ref false in
+        begin match
+        let decl = Env.find_type p env in
+        let () =
+          if Ast_untagged_variants.has_untagged decl.type_attributes
+          then untagged := true in
+        decl.type_kind with
         | exception _ -> 
             false
-        | Types.Type_abstract | Types.Type_open -> false
-        | Types.Type_record _ -> true
-        | (Types.Type_variant
+        | Type_abstract | Type_open -> false
+        | Type_record _ -> true
+        | Type_variant
              ([{cd_id = {name="None"}; cd_args = Cstr_tuple [] };
                {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}]
              |
               [{cd_id = {name="Some"}; cd_args = Cstr_tuple [_] };
                {cd_id = {name = "None"}; cd_args = Cstr_tuple []}]
              | [{cd_id= {name = "()"}; cd_args = Cstr_tuple []}]               
-             ))
-        (* | Types.Type_variant  *)
+             )
              -> false (* conservative *)
-        | _ -> true
+        | Type_variant cdecls ->
+          let type_can_contain_undefined t =
+            not (Ast_untagged_variants.type_is_builtin_object t) &&
+            not (cannot_inhabit_none_like_value t env) in
+          let can_contain_undefined =
+            Ext_list.exists cdecls (fun cd ->
+              if Ast_untagged_variants.has_undefined_literal cd.cd_attributes
+              then true
+              else if !untagged then
+                match cd.cd_args with
+                | Cstr_tuple [t] ->
+                  type_can_contain_undefined  t
+                | Cstr_tuple [] -> false
+                | Cstr_tuple (_::_::_) -> false (* Not actually possible for untagged *)
+                | Cstr_record [{ld_type=t}] ->
+                  type_can_contain_undefined t
+                | Cstr_record ([] | _::_::_) -> false
+              else
+                false) in
+          not can_contain_undefined
         end)
   | Ttuple _
   | Tvariant _

jscomp/test/UntaggedVariants.js

@@ -261,3 +261,35 @@ module ArrayAndObject = {
     | Array(a) => a[0]
     }
 }
+
+module OptionUnboxingHeuristic = {
+  type hasNull = | @as(null) Null | B(int)
+  let testHasNull = (x: hasNull) => Some(x)
+
+  type hasUndefined = | @as(undefined) Undefined | B(int)
+  let testHasUndefined = (x: hasUndefined) => Some(x)
+
+  @unboxed
+  type untaggedWithOptionPayload = A | B(option<string>)
+  let untaggedWithOptionPayload = (x: untaggedWithOptionPayload) => Some(x)
+
+  @unboxed
+  type untaggedWithIntPayload = A | B(int)
+  let untaggedWithIntPayload = (x: untaggedWithIntPayload) => Some(x)
+
+  @unboxed
+  type untaggedInlineNoOption = A | B({x: int})
+  let untaggedInlineNoOptions = (x: untaggedInlineNoOption) => Some(x)
+
+  @unboxed
+  type untaggedInlineUnaryWihtExplicitOption = A | B({x: option<int>})
+  let untaggedInlineUnaryWihtExplicitOption = (x: untaggedInlineUnaryWihtExplicitOption) => Some(x)
+
+  @unboxed
+  type untaggedInlineUnaryWihtImplicitOption = A | B({x?: int})
+  let untaggedInlineUnaryWihtImplicitOption = (x: untaggedInlineUnaryWihtImplicitOption) => Some(x)
+
+  @unboxed
+  type untaggedInlineMultinaryOption = A | B({x: option<int>, y?: string})
+  let untaggedInlineMultinaryOption = (x: untaggedInlineMultinaryOption) => Some(x)
+}