fix error variant cstr arg of optional field

mununki · mununki · commit a9286bc966d7 · 2022-11-20T19:23:39.000+09:00
diff --git a/jscomp/ml/datarepr.ml b/jscomp/ml/datarepr.ml
@@ -113,6 +113,7 @@ let constructor_descrs ty_path decl cstrs =
       if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
       if cd_res = None then incr num_normal)
     cstrs;
+  let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "ns.optional") in
   let rec describe_constructors idx_const idx_nonconst = function
       [] -> []
     | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
@@ -131,11 +132,17 @@ let constructor_descrs ty_path decl cstrs =
           | _  -> (Cstr_block idx_nonconst,
                    describe_constructors idx_const (idx_nonconst+1) rem) in
         let cstr_name = Ident.name cd_id in
+        let optional_labels = match cd_args with
+          | Cstr_tuple _ -> []
+          | Cstr_record lbls ->
+            Ext_list.filter_map lbls (fun ({ld_id;ld_attributes; _}) ->
+              if has_optional ld_attributes then Some ld_id.name else None)
+        in
         let existentials, cstr_args, cstr_inlined =
           let representation =
             if decl.type_unboxed.unboxed
             then Record_unboxed true
-            else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts}
+            else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; optional_labels}
           in
           constructor_args decl.type_private cd_args cd_res
             (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation
diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml
@@ -1879,6 +1879,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
   let label_is_optional ld =
     match ld.lbl_repres with
     | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name
+    | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name
     | _ -> false in
   let process_optional_label (id, ld, e) =
     let exp_optional_attr =
diff --git a/jscomp/ml/types.ml b/jscomp/ml/types.ml
@@ -154,7 +154,7 @@ and record_representation =
   | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
-      { tag : int ; name : string; num_nonconsts : int}
+      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list}
   | Record_extension                      (* Inlined record under extension *)
   | Record_optional_labels of string list (* List of optional labels *)
 
@@ -348,10 +348,10 @@ let same_record_representation x y =
       match y with
       | Record_optional_labels lbls2 -> lbls = lbls2
       | _ -> false)
-  | Record_inlined {tag; name; num_nonconsts} -> (
+  | Record_inlined {tag; name; num_nonconsts; optional_labels} -> (
       match y with
       | Record_inlined y ->
-          tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts
+          tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts && optional_labels = y.optional_labels
       | _ -> false)
   | Record_extension -> y = Record_extension
   | Record_unboxed x -> ( match y with Record_unboxed y -> x = y | _ -> false)
diff --git a/jscomp/ml/types.mli b/jscomp/ml/types.mli
@@ -301,7 +301,7 @@ and record_representation =
   | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
-      { tag : int ; name : string; num_nonconsts : int}
+      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list}
   | Record_extension                      (* Inlined record under extension *)
   | Record_optional_labels of string list (* List of optional labels *)
 
diff --git a/jscomp/test/record_regression.js b/jscomp/test/record_regression.js
@@ -80,6 +80,11 @@ var h = newrecord$2;
 
 var h10 = newrecord$3;
 
+var foo = /* Foo */{
+  name: "foo",
+  age: undefined
+};
+
 exports.f1 = f1;
 exports.f2 = f2;
 exports.f3 = f3;
@@ -93,4 +98,5 @@ exports.h10 = h10;
 exports.h11 = h11;
 exports.po = po;
 exports.setAA = setAA;
+exports.foo = foo;
 /*  Not a pure module */
diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml
@@ -41404,7 +41404,7 @@ and record_representation =
   | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
-      { tag : int ; name : string; num_nonconsts : int}
+      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list}
   | Record_extension                      (* Inlined record under extension *)
   | Record_optional_labels of string list (* List of optional labels *)
 
@@ -41749,7 +41749,7 @@ and record_representation =
   | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
-      { tag : int ; name : string; num_nonconsts : int}
+      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list}
   | Record_extension                      (* Inlined record under extension *)
   | Record_optional_labels of string list (* List of optional labels *)
 
@@ -41943,10 +41943,10 @@ let same_record_representation x y =
       match y with
       | Record_optional_labels lbls2 -> lbls = lbls2
       | _ -> false)
-  | Record_inlined {tag; name; num_nonconsts} -> (
+  | Record_inlined {tag; name; num_nonconsts; optional_labels} -> (
       match y with
       | Record_inlined y ->
-          tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts
+          tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts && optional_labels = y.optional_labels
       | _ -> false)
   | Record_extension -> y = Record_extension
   | Record_unboxed x -> ( match y with Record_unboxed y -> x = y | _ -> false)
@@ -43435,6 +43435,7 @@ let constructor_descrs ty_path decl cstrs =
       if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
       if cd_res = None then incr num_normal)
     cstrs;
+  let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "ns.optional") in
   let rec describe_constructors idx_const idx_nonconst = function
       [] -> []
     | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
@@ -43453,11 +43454,17 @@ let constructor_descrs ty_path decl cstrs =
           | _  -> (Cstr_block idx_nonconst,
                    describe_constructors idx_const (idx_nonconst+1) rem) in
         let cstr_name = Ident.name cd_id in
+        let optional_labels = match cd_args with
+          | Cstr_tuple _ -> []
+          | Cstr_record lbls ->
+            Ext_list.filter_map lbls (fun ({ld_id;ld_attributes; _}) ->
+              if has_optional ld_attributes then Some ld_id.name else None)
+        in
         let existentials, cstr_args, cstr_inlined =
           let representation =
             if decl.type_unboxed.unboxed
             then Record_unboxed true
-            else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts}
+            else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; optional_labels}
           in
           constructor_args decl.type_private cd_args cd_res
             (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation
diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml
diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml
diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml
