Fix exception record field regression

Author: fhammerschmidt

compiler/ml/typedecl.ml

@@ -312,6 +312,23 @@ let transl_constructor_arguments env closed = function
             let cty = transl_simple_type env closed obj_ty in
             (Types.Cstr_tuple [cty.ctyp_type], Cstr_tuple [cty])))))
 
+let rewrite_optional_inline_record_fields = function
+  | Pcstr_tuple _ as args -> args
+  | Pcstr_record lds ->
+    Pcstr_record
+      (Ext_list.map lds (fun ld ->
+           if ld.pld_optional then
+             let typ = ld.pld_type in
+             let typ =
+               {
+                 typ with
+                 ptyp_desc =
+                   Ptyp_constr ({txt = Lident "option"; loc = typ.ptyp_loc}, [typ]);
+               }
+             in
+             {ld with pld_type = typ}
+           else ld))
+
 let make_constructor env type_path type_params sargs sret_type =
   match sret_type with
   | None ->
@@ -440,28 +457,7 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id =
            Location.prerr_warning loc Warnings.Constraint_on_gadt);
       let scstrs =
         Ext_list.map scstrs (fun ({pcd_args} as cstr) ->
-            match pcd_args with
-            | Pcstr_tuple _ -> cstr
-            | Pcstr_record lds ->
-              {
-                cstr with
-                pcd_args =
-                  Pcstr_record
-                    (Ext_list.map lds (fun ld ->
-                         if ld.pld_optional then
-                           let typ = ld.pld_type in
-                           let typ =
-                             {
-                               typ with
-                               ptyp_desc =
-                                 Ptyp_constr
-                                   ( {txt = Lident "option"; loc = typ.ptyp_loc},
-                                     [typ] );
-                             }
-                           in
-                           {ld with pld_type = typ}
-                         else ld));
-              })
+            {cstr with pcd_args = rewrite_optional_inline_record_fields pcd_args})
       in
       let all_constrs = ref StringSet.empty in
       List.iter
@@ -1627,6 +1623,7 @@ let transl_extension_constructor env type_path type_params typext_params priv
   let args, ret_type, kind =
     match sext.pext_kind with
     | Pext_decl (sargs, sret_type) ->
+      let sargs = rewrite_optional_inline_record_fields sargs in
       let targs, tret_type, args, ret_type, _ =
         make_constructor env type_path typext_params sargs sret_type
       in

tests/tests/src/record_extension_test.mjs

@@ -77,48 +77,76 @@ let B = /* @__PURE__ */Primitive_exceptions.create("Record_extension_test.B");
 
 let C = /* @__PURE__ */Primitive_exceptions.create("Record_extension_test.C");
 
+let D = /* @__PURE__ */Primitive_exceptions.create("Record_extension_test.D");
+
 function u(f) {
   try {
     return f();
   } catch (raw_x) {
     let x = Primitive_exceptions.internalToException(raw_x);
     if (x.RE_EXN_ID === A) {
       return x.name + x.x | 0;
-    } else if (x.RE_EXN_ID === B) {
+    }
+    if (x.RE_EXN_ID === B) {
       return x._1 + x._2 | 0;
-    } else if (x.RE_EXN_ID === C) {
+    }
+    if (x.RE_EXN_ID === C) {
       return x.name;
-    } else {
+    }
+    if (x.RE_EXN_ID !== D) {
       return -1;
     }
+    let message = x.message;
+    let code = x.code;
+    if (message !== undefined) {
+      return code + message.length | 0;
+    } else {
+      return code;
+    }
   }
 }
 
-Mocha.describe("File \"record_extension_test.res\", line 68, characters 9-16", () => {
+Mocha.describe("File \"record_extension_test.res\", line 71, characters 9-16", () => {
   Mocha.test("record extension with exceptions", () => {
-    Test_utils.eq("File \"record_extension_test.res\", line 70, characters 7-14", u(() => {
+    Test_utils.eq("File \"record_extension_test.res\", line 73, characters 7-14", u(() => {
       throw {
         RE_EXN_ID: A,
         name: 1,
         x: 1,
         Error: new Error()
       };
     }), 2);
-    Test_utils.eq("File \"record_extension_test.res\", line 71, characters 7-14", u(() => {
+    Test_utils.eq("File \"record_extension_test.res\", line 74, characters 7-14", u(() => {
       throw {
         RE_EXN_ID: B,
         _1: 1,
         _2: 2,
         Error: new Error()
       };
     }), 3);
-    Test_utils.eq("File \"record_extension_test.res\", line 72, characters 7-14", u(() => {
+    Test_utils.eq("File \"record_extension_test.res\", line 75, characters 7-14", u(() => {
       throw {
         RE_EXN_ID: C,
         name: 4,
         Error: new Error()
       };
     }), 4);
+    Test_utils.eq("File \"record_extension_test.res\", line 76, characters 7-14", u(() => {
+      throw {
+        RE_EXN_ID: D,
+        code: 1,
+        message: "A",
+        Error: new Error()
+      };
+    }), 2);
+    Test_utils.eq("File \"record_extension_test.res\", line 77, characters 7-14", u(() => {
+      throw {
+        RE_EXN_ID: D,
+        code: 3,
+        message: undefined,
+        Error: new Error()
+      };
+    }), 3);
   });
 });
 
@@ -132,6 +160,7 @@ export {
   A,
   B,
   C,
+  D,
   u,
 }
 /*  Not a pure module */

tests/tests/src/record_extension_test.res

@@ -56,12 +56,15 @@ let f2_with = x =>
 exception A({name: int, x: int})
 exception B(int, int)
 exception C({name: int})
+exception D({code: int, message?: string})
 
 let u = f =>
   try f() catch {
   | A({name, x}) => name + x
   | B(a, b) => a + b
   | C(x) => x.name
+  | D({code, message}) => code + String.length(message)
+  | D({code}) => code
   | _ => -1
   }
 
@@ -70,5 +73,7 @@ describe(__LOC__, () => {
     eq(__LOC__, u(() => throw(A({name: 1, x: 1}))), 2)
     eq(__LOC__, u(() => throw(B(1, 2))), 3)
     eq(__LOC__, u(() => throw(C({name: 4}))), 4)
+    eq(__LOC__, u(() => throw(D({code: 1, message: "A"}))), 2)
+    eq(__LOC__, u(() => throw(D({code: 3}))), 3)
   })
 })