Pattern matching for @nullable records.

This gives pattern matching that mimics expression constructor, where the variable by default is not optional.
The generated code seems fine, thought the checks for exhaustiveness are not kicking in.

See #5452

Author: cristianoc

jscomp/ml/typecore.ml

@@ -1149,6 +1149,19 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           Some (p0, p), expected_ty
         with Not_found -> None, newvar ()
       in
+      let label_is_optional ld =
+        match ld.lbl_repres with
+        | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name
+        | _ -> false in
+      let process_optional_label (id, ld, pat) =
+        let exp_optional_attr =
+          Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
+        in
+        if label_is_optional ld && not exp_optional_attr then
+          let ppat_desc = Ppat_construct ({id with txt = Longident.Lident "Some"}, Some pat)
+          in {pat with ppat_desc}
+        else pat
+      in    
       let type_label_pat (label_lid, label, sarg) k =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
@@ -1159,6 +1172,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           raise(Error(label_lid.loc, !env,
                       Label_mismatch(label_lid.txt, trace)))
         end;
+        let sarg = process_optional_label (label_lid, label, sarg) in
         type_pat sarg ty_arg (fun arg ->
           if vars <> [] then begin
             end_def ();

jscomp/test/res_debug.js

@@ -15,6 +15,15 @@ var newrecord = Caml_obj.obj_dup(v0);
 
 newrecord.x = 3;
 
+function testMatch(v) {
+  var y = v.y;
+  if (y !== undefined) {
+    return y;
+  } else {
+    return 42;
+  }
+}
+
 var v2 = newrecord;
 
 var v1 = {
@@ -30,6 +39,7 @@ exports.f = f;
 exports.v0 = v0;
 exports.v2 = v2;
 exports.v1 = v1;
+exports.testMatch = testMatch;
 exports.h = h;
 exports.hey = hey;
 /*  Not a pure module */

jscomp/test/res_debug.res

@@ -44,6 +44,14 @@ let v1 : r = { x : 3
   , z : 3
 }
 
+@@warning("-56") // Turn off match case unreachable
+
+let testMatch = v =>
+  switch v {
+  | {y} => y
+  | {y: @optional None} => 42
+  }
+
 let h = '😊'
 let hey = "hello, 世界"
 // failed to type check

lib/4.06.1/unstable/js_compiler.ml

@@ -40052,6 +40052,19 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           Some (p0, p), expected_ty
         with Not_found -> None, newvar ()
       in
+      let label_is_optional ld =
+        match ld.lbl_repres with
+        | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name
+        | _ -> false in
+      let process_optional_label (id, ld, pat) =
+        let exp_optional_attr =
+          Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
+        in
+        if label_is_optional ld && not exp_optional_attr then
+          let ppat_desc = Ppat_construct ({id with txt = Longident.Lident "Some"}, Some pat)
+          in {pat with ppat_desc}
+        else pat
+      in    
       let type_label_pat (label_lid, label, sarg) k =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
@@ -40062,6 +40075,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           raise(Error(label_lid.loc, !env,
                       Label_mismatch(label_lid.txt, trace)))
         end;
+        let sarg = process_optional_label (label_lid, label, sarg) in
         type_pat sarg ty_arg (fun arg ->
           if vars <> [] then begin
             end_def ();

lib/4.06.1/unstable/js_playground_compiler.ml

@@ -40052,6 +40052,19 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           Some (p0, p), expected_ty
         with Not_found -> None, newvar ()
       in
+      let label_is_optional ld =
+        match ld.lbl_repres with
+        | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name
+        | _ -> false in
+      let process_optional_label (id, ld, pat) =
+        let exp_optional_attr =
+          Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
+        in
+        if label_is_optional ld && not exp_optional_attr then
+          let ppat_desc = Ppat_construct ({id with txt = Longident.Lident "Some"}, Some pat)
+          in {pat with ppat_desc}
+        else pat
+      in    
       let type_label_pat (label_lid, label, sarg) k =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
@@ -40062,6 +40075,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           raise(Error(label_lid.loc, !env,
                       Label_mismatch(label_lid.txt, trace)))
         end;
+        let sarg = process_optional_label (label_lid, label, sarg) in
         type_pat sarg ty_arg (fun arg ->
           if vars <> [] then begin
             end_def ();

lib/4.06.1/whole_compiler.ml

@@ -214583,6 +214583,19 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           Some (p0, p), expected_ty
         with Not_found -> None, newvar ()
       in
+      let label_is_optional ld =
+        match ld.lbl_repres with
+        | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name
+        | _ -> false in
+      let process_optional_label (id, ld, pat) =
+        let exp_optional_attr =
+          Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
+        in
+        if label_is_optional ld && not exp_optional_attr then
+          let ppat_desc = Ppat_construct ({id with txt = Longident.Lident "Some"}, Some pat)
+          in {pat with ppat_desc}
+        else pat
+      in    
       let type_label_pat (label_lid, label, sarg) k =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
@@ -214593,6 +214606,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           raise(Error(label_lid.loc, !env,
                       Label_mismatch(label_lid.txt, trace)))
         end;
+        let sarg = process_optional_label (label_lid, label, sarg) in
         type_pat sarg ty_arg (fun arg ->
           if vars <> [] then begin
             end_def ();