Regression in pattern matching optional fields.

Fixes #7400

Fix regression in pattern  matching for optional fields.

There's an optimisation where `{field: VariantCase}` is compiled to `field:VariantCase` instead of `field:Some(VariantCase)` to avoid generating code that handles undefined, since `VariantCase` is going to be a string.
However, that optimisation happens early in the pattern matching compiler, and can end up interfering with other cases. For example, when `VariantCase` is the only case in a variant, and the following case is `_`, the compiler is induced in thinking that the variant case covers all cases, and the case for `_` is never generated.
Similar behaviour happens when handling the last case of a variant followed by `_`.

Author: cristianoc

CHANGELOG.md

@@ -31,6 +31,7 @@
 - Fix field flattening optimization to avoid creating unnecessary copies of allocating constants. https://github.com/rescript-lang/rescript-compiler/pull/7421
 - Fix leading comments removed when braces inside JSX contains `let` assignment. https://github.com/rescript-lang/rescript/pull/7424
 - Fix JSON escaping in code editor analysis: JSON was not always escaped properly, which prevented code actions from being available in certain situations https://github.com/rescript-lang/rescript/pull/7435
+- Fix regression in pattern matching for optional fields containing variants. https://github.com/rescript-lang/rescript/pull/7440
 
 #### :house: Internal
 

compiler/ml/matching.ml

@@ -2413,7 +2413,7 @@ let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats)
 
 (* Insertion of debugging events *)
 
-let[@inline] event_branch _repr lam = lam
+(* let[@inline] event_branch _repr lam = lam *)
 
 (*
    This exception is raised when the compiler cannot produce code
@@ -2602,8 +2602,8 @@ let rec compile_match repr partial ctx m =
   | {cases = ([], action) :: rem} ->
     if is_guarded action then
       let lambda, total = compile_match None partial ctx {m with cases = rem} in
-      (event_branch repr (patch_guarded lambda action), total)
-    else (event_branch repr action, jumps_empty)
+      (patch_guarded lambda action, total)
+    else (action, jumps_empty)
   | {args = (arg, str) :: argl} ->
     let v, newarg = arg_to_var arg m.cases in
     let first_match, rem =

compiler/ml/parmatch.ml

@@ -553,11 +553,6 @@ let all_record_args lbls =
             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, o)
             | Some cstr -> (
               match
                 Ast_untagged_variants.get_block_type ~env:pat.pat_env cstr

tests/tests/src/pattern_match_json.mjs

@@ -25,7 +25,11 @@ function decodeGroup(group) {
 }
 
 function decodeNull(x) {
-  let tmp = x.field;
+  let match = x.field;
+  if (match === undefined) {
+    return "no";
+  }
+  let tmp = Primitive_option.valFromOption(match);
   if (tmp === null) {
     return "yes it's null";
   } else {

tests/tests/src/pm_opt_fields_regression.mjs

@@ -0,0 +1,60 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+
+function bad1(schema) {
+  if (schema.format !== undefined) {
+    return "int32";
+  } else {
+    return "default";
+  }
+}
+
+function good1(schema) {
+  if (schema.format !== undefined) {
+    return "int32";
+  } else {
+    return "default";
+  }
+}
+
+let SingleFormatCase = {
+  bad1: bad1,
+  good1: good1
+};
+
+function bad2(schema) {
+  let match = schema.format;
+  if (match !== undefined) {
+    if (match === "Int32") {
+      return "int32";
+    } else {
+      return "dd";
+    }
+  } else {
+    return "default";
+  }
+}
+
+function good2(schema) {
+  let match = schema.format;
+  if (match !== undefined) {
+    if (match === "Int32") {
+      return "int32";
+    } else {
+      return "dd";
+    }
+  } else {
+    return "default";
+  }
+}
+
+let MultipleFormatCase = {
+  bad2: bad2,
+  good2: good2
+};
+
+export {
+  SingleFormatCase,
+  MultipleFormatCase,
+}
+/* No side effect */

tests/tests/src/pm_opt_fields_regression.res

@@ -0,0 +1,41 @@
+module SingleFormatCase = {
+  type format1 = Int32
+
+  type schema = {format?: format1}
+
+  let bad1 = schema => {
+    switch schema {
+    | {format: Int32} => "int32"
+    | _ => "default"
+    }
+  }
+
+  let good1 = schema => {
+    switch schema {
+    | {format: _} => "int32"
+    | _ => "default"
+    }
+  }
+}
+
+module MultipleFormatCase = {
+  type format2 = Int32 | DD
+
+  type schema = {format?: format2}
+
+  let bad2 = schema => {
+    switch schema {
+    | {format: Int32} => "int32"
+    | {format: DD} => "dd"
+    | _ => "default"
+    }
+  }
+
+  let good2 = schema => {
+    switch schema {
+    | {format: Int32} => "int32"
+    | {format: _} => "dd"
+    | _ => "default"
+    }
+  }
+}