Optional fields pattern matching: untagged variants

CHANGELOG.md

@@ -56,7 +56,7 @@
 - Improve code generation or pattern matching of untagged variants. https://github.com/rescript-lang/rescript-compiler/pull/7128
 - Improve negation handling in combination with and/or to simplify generated code (especially coming out of pattern matching). https://github.com/rescript-lang/rescript-compiler/pull/7138
 - optimize JavaScript code generation by using x == null checks and improving type-based optimizations for string/number literals. https://github.com/rescript-lang/rescript-compiler/pull/7141
-- Improve pattern matching on optional fields. https://github.com/rescript-lang/rescript-compiler/pull/7143
+- Improve pattern matching on optional fields. https://github.com/rescript-lang/rescript-compiler/pull/7143 https://github.com/rescript-lang/rescript-compiler/pull/7144
 
 
 #### :house: Internal

compiler/ml/ast_untagged_variants.ml

@@ -91,6 +91,19 @@ type switch_names = {consts: tag array; blocks: block array}
 
 let untagged = "unboxed"
 
+let block_type_can_be_undefined = function
+  | IntType | StringType | FloatType | BigintType | BooleanType | InstanceType _
+  | FunctionType | ObjectType ->
+    false
+  | UnknownType -> true
+
+let tag_can_be_undefined tag =
+  match tag.tag_type with
+  | None -> false
+  | Some (String _ | Int _ | Float _ | BigInt _ | Bool _ | Null) -> false
+  | Some (Untagged block_type) -> block_type_can_be_undefined block_type
+  | Some Undefined -> true
+
 let has_untagged (attrs : Parsetree.attributes) =
   Ext_list.exists attrs (function {txt}, _ -> txt = untagged)
 
@@ -328,23 +341,35 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
           invariant loc block.tag.name
         | None -> ())
 
+let get_cstr_loc_tag (cstr : Types.constructor_declaration) =
+  ( cstr.cd_loc,
+    {
+      name = Ident.name cstr.cd_id;
+      tag_type = process_tag_type cstr.cd_attributes;
+    } )
+
+let constructor_declaration_from_constructor_description ~env
+    (cd : Types.constructor_description) : Types.constructor_declaration option
+    =
+  match cd.cstr_res.desc with
+  | Tconstr (path, _, _) -> (
+    match Env.find_type path env with
+    | {type_kind = Type_variant cstrs} ->
+      Ext_list.find_opt cstrs (fun cstr ->
+          if cstr.cd_id.name = cd.cstr_name then Some cstr else None)
+    | _ -> None)
+  | _ -> None
+
 let names_from_type_variant ?(is_untagged_def = false) ~env
     (cstrs : Types.constructor_declaration list) =
-  let get_cstr_name (cstr : Types.constructor_declaration) =
-    ( cstr.cd_loc,
-      {
-        name = Ident.name cstr.cd_id;
-        tag_type = process_tag_type cstr.cd_attributes;
-      } )
-  in
   let get_block (cstr : Types.constructor_declaration) : block =
-    let tag = snd (get_cstr_name cstr) in
+    let tag = snd (get_cstr_loc_tag cstr) in
     {tag; tag_name = get_tag_name cstr; block_type = get_block_type ~env cstr}
   in
   let consts, blocks =
     Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr ->
         if is_nullary_variant cstr.cd_args then
-          (get_cstr_name cstr :: consts, blocks)
+          (get_cstr_loc_tag cstr :: consts, blocks)
         else (consts, (cstr.cd_loc, get_block cstr) :: blocks))
   in
   check_invariant ~is_untagged_def ~consts ~blocks;

compiler/ml/parmatch.ml

@@ -539,6 +539,33 @@ let all_record_args lbls =
                 [({pat_desc = Tpat_constant _} as c)] )
             when lbl_is_optional () ->
             (id, lbl, c)
+          | Tpat_construct
+              ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")},
+                _,
+                [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] )
+            when lbl_is_optional () -> (
+            let cdecl =
+              Ast_untagged_variants
+              .constructor_declaration_from_constructor_description
+                ~env:pat.pat_env cd
+            in
+            match cdecl with
+            | None -> x
+            | Some cstr
+              when Ast_untagged_variants.is_nullary_variant cstr.cd_args ->
+              let _, tag = Ast_untagged_variants.get_cstr_loc_tag cstr in
+              if Ast_untagged_variants.tag_can_be_undefined tag then x
+              else (id, lbl, pat_construct)
+            | Some cstr -> (
+              match
+                Ast_untagged_variants.get_block_type ~env:pat.pat_env cstr
+              with
+              | Some block_type
+                when not
+                       (Ast_untagged_variants.block_type_can_be_undefined
+                          block_type) ->
+                (id, lbl, pat_construct)
+              | _ -> x))
           | _ -> x
         in
         t.(lbl.lbl_pos) <- x)

tests/tests/src/pattern_match_json.mjs

@@ -0,0 +1,60 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+import * as Primitive_option from "rescript/lib/es6/Primitive_option.js";
+
+function decodeGroup(group) {
+  let id = group.id;
+  if (id == null) {
+    return [
+      "e",
+      "f"
+    ];
+  }
+  if (typeof id !== "string") {
+    return [
+      "e",
+      "f"
+    ];
+  }
+  let name = group.name;
+  if (typeof name !== "string") {
+    return [
+      "e",
+      "f"
+    ];
+  } else {
+    return [
+      id,
+      name
+    ];
+  }
+}
+
+function decodeNull(x) {
+  let tmp = x.field;
+  if (tmp === null) {
+    return "yes it's null";
+  } else {
+    return "no";
+  }
+}
+
+function decodeUndefined(x) {
+  let match = x.field;
+  if (match === undefined) {
+    return "no";
+  }
+  let tmp = Primitive_option.valFromOption(match);
+  if (tmp === undefined) {
+    return "yes it's undefined";
+  } else {
+    return "no";
+  }
+}
+
+export {
+  decodeGroup,
+  decodeNull,
+  decodeUndefined,
+}
+/* No side effect */

tests/tests/src/pattern_match_json.res

@@ -0,0 +1,33 @@
+@unboxed
+type rec t =
+  | Boolean(bool)
+  | @as(null) Null
+  | @as(undefined) Undefined
+  | String(string)
+  | Number(float)
+  | Object(Dict.t<t>)
+  | Array(array<t>)
+
+type group = {
+  id: string,
+  name: string,
+}
+
+let decodeGroup = group => {
+  switch group {
+  | dict{"id": String(id), "name": String(name)} => (id, name)
+  | _ => ("e", "f")
+  }
+}
+
+let decodeNull = x =>
+  switch x {
+  | dict{"field": Null} => "yes it's null"
+  | _ => "no"
+  }
+
+let decodeUndefined = x =>
+  switch x {
+  | dict{"field": Undefined} => "yes it's undefined"
+  | _ => "no"
+  }