From cb3c962277307fcb949aca73da4608a528b43c60 Mon Sep 17 00:00:00 2001 From: Florian Hammerschmidt Date: Sun, 29 Mar 2026 13:30:09 +0200 Subject: [PATCH 1/2] Fix exception record field regression --- compiler/ml/typedecl.ml | 41 ++++++++++----------- tests/tests/src/record_extension_test.mjs | 43 +++++++++++++++++++---- tests/tests/src/record_extension_test.res | 5 +++ 3 files changed, 60 insertions(+), 29 deletions(-) diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index da35de5288d..7f664bcd982 100644 --- a/compiler/ml/typedecl.ml +++ b/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 diff --git a/tests/tests/src/record_extension_test.mjs b/tests/tests/src/record_extension_test.mjs index 6ebd0e4889f..581feb83a03 100644 --- a/tests/tests/src/record_extension_test.mjs +++ b/tests/tests/src/record_extension_test.mjs @@ -77,6 +77,8 @@ 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(); @@ -84,19 +86,29 @@ function u(f) { 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, @@ -104,7 +116,7 @@ Mocha.describe("File \"record_extension_test.res\", line 68, characters 9-16", ( 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, @@ -112,13 +124,29 @@ Mocha.describe("File \"record_extension_test.res\", line 68, characters 9-16", ( 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 */ diff --git a/tests/tests/src/record_extension_test.res b/tests/tests/src/record_extension_test.res index b1f2c4b1820..ebcd0fba29b 100644 --- a/tests/tests/src/record_extension_test.res +++ b/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) }) }) From a6b20c67e86dd8ba2dff474f3f66015ddae02c0b Mon Sep 17 00:00:00 2001 From: Florian Hammerschmidt Date: Sun, 29 Mar 2026 13:48:35 +0200 Subject: [PATCH 2/2] Format --- compiler/ml/typedecl.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 7f664bcd982..0f44d4595f4 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -323,7 +323,8 @@ let rewrite_optional_inline_record_fields = function { typ with ptyp_desc = - Ptyp_constr ({txt = Lident "option"; loc = typ.ptyp_loc}, [typ]); + Ptyp_constr + ({txt = Lident "option"; loc = typ.ptyp_loc}, [typ]); } in {ld with pld_type = typ} @@ -457,7 +458,10 @@ 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) -> - {cstr with pcd_args = rewrite_optional_inline_record_fields pcd_args}) + { + cstr with + pcd_args = rewrite_optional_inline_record_fields pcd_args; + }) in let all_constrs = ref StringSet.empty in List.iter