Make untagged variants understand payloads defined as records.

CHANGELOG.md

@@ -19,6 +19,7 @@
   - `node` (default): Drop extensions.
   - `node16`: Use TS output's extensions. Make it ESM-compatible.
   - `bundler`: Use TS input's extensions. Make it ESM-compatible.
+- Make untagged variants understand payloads defined as records. https://github.com/rescript-lang/rescript-compiler/pull/6208
 
 #### :boom: Breaking Change
 

jscomp/core/matching_polyfill.ml

@@ -25,7 +25,7 @@
 let names_from_construct_pattern (pat : Typedtree.pattern) =
   let rec resolve_path n (path : Path.t) =
     match Env.find_type path pat.pat_env with
-    | { type_kind = Type_variant cstrs; _ } -> Ast_untagged_variants.names_from_type_variant cstrs
+    | { type_kind = Type_variant cstrs; _ } -> Ast_untagged_variants.names_from_type_variant ~env:pat.pat_env cstrs
     | { type_kind = Type_abstract; type_manifest = Some t; _ } -> (
         match (Ctype.unalias t).desc with
         | Tconstr (pathn, _, _) ->

jscomp/ml/ast_untagged_variants.ml

@@ -92,7 +92,7 @@ let () =
         None
     )
 
-let get_untagged (cstr: Types.constructor_declaration) : block_type option =
+let get_untagged ~env (cstr: Types.constructor_declaration) : block_type option =
   match process_untagged cstr.cd_attributes, cstr.cd_args with
   | false, _ -> None
   | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_string ->
@@ -105,17 +105,21 @@ let get_untagged (cstr: Types.constructor_declaration) : block_type option =
       Some Array
   | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path. same path Predef.path_string ->
       Some StringType
-  | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] ->
-    (match Path.name path with
-    | "Js.Dict.t"
-    | "Js_dict.t" -> Some Object
-    | _ -> Some Unknown)
-  | true, Cstr_tuple (_ :: _ :: _) ->
+  | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when
+    let name = Path.name path in
+    name = "Js.Dict.t" || name = "Js_dict.t" ->
+      Some Object
+  | true, Cstr_tuple [ty] ->
+    let default = Some Unknown in
+    (match Ctype.extract_concrete_typedecl env ty with
+    | (_, _, {type_kind = Type_record (_, Record_unboxed _)}) -> default
+    | (_, _, {type_kind = Type_record (_, _)}) -> Some Object
+      | _ -> default
+      | exception _ -> default
+    )
+| true, Cstr_tuple (_ :: _ :: _) ->
       (* C(_, _) with at least 2 args is an object *)
       Some Object
-  | true, Cstr_tuple [_] ->
-      (* Every other single payload is unknown *)
-      Some Unknown
   | true, Cstr_record _ ->
       (* inline record is an object *)
       Some Object
@@ -209,13 +213,13 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * literal) list) ~(bloc
       invariant loc      
     | None -> ())
 
-let names_from_type_variant ?(isUntaggedDef=false) (cstrs : Types.constructor_declaration list) =
+let names_from_type_variant ?(isUntaggedDef=false) ~env (cstrs : Types.constructor_declaration list) =
   let get_cstr_name (cstr: Types.constructor_declaration) =
     (cstr.cd_loc,
       { name = Ident.name cstr.cd_id;
         literal_type = process_literal_type cstr.cd_attributes }) in
   let get_block cstr : block =
-    {literal = snd (get_cstr_name cstr); tag_name = get_tag_name cstr; block_type = get_untagged cstr} in
+    {literal = snd (get_cstr_name cstr); tag_name = get_tag_name cstr; block_type = get_untagged ~env cstr} in
   let consts, blocks =
     Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr ->
         if is_nullary_variant cstr.cd_args then
@@ -229,6 +233,6 @@ let names_from_type_variant ?(isUntaggedDef=false) (cstrs : Types.constructor_de
   let blocks = Ext_array.reverse_of_list blocks in
   Some { consts; blocks }
 
-let check_well_formed ~isUntaggedDef (cstrs: Types.constructor_declaration list) =
-  ignore (names_from_type_variant ~isUntaggedDef cstrs)
+let check_well_formed ~env ~isUntaggedDef (cstrs: Types.constructor_declaration list) =
+  ignore (names_from_type_variant ~env ~isUntaggedDef cstrs)
 

jscomp/ml/typedecl.ml

@@ -422,7 +422,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id =
         in
         let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
         let isUntaggedDef = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in
-        Ast_untagged_variants.check_well_formed ~isUntaggedDef cstrs;
+        Ast_untagged_variants.check_well_formed ~env ~isUntaggedDef cstrs;
         Ttype_variant tcstrs, Type_variant cstrs, sdecl
       | Ptype_record lbls_ ->
           let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in

jscomp/test/UntaggedVariants.res

@@ -235,3 +235,17 @@ module OverlapObject = {
     | Object(_) => "Object..."
     }
 }
+
+module RecordIsObject = {
+  // @unboxed
+  // this is not allowed
+  type r = {x:int}
+
+  @unboxed
+  type t = | Array(array<int>) | Record(r)
+
+  let classify = v => switch v {
+    | Record({x}) => x
+    | Array(a) => a[0]
+  }
+}