From 25ec6cd903df38692605c14a803c2ea3289bc99d Mon Sep 17 00:00:00 2001 From: tsnobip Date: Sun, 19 Apr 2026 11:38:54 +0200 Subject: [PATCH 1/2] allow mutation of private record fields with `@allowMutation` should be reversed at some point to become the default behavior you could opt-out with `@DisallowMutation` --- CHANGELOG.md | 1 + compiler/ml/builtin_attributes.ml | 7 ++++++ compiler/ml/builtin_attributes.mli | 2 ++ compiler/ml/typecore.ml | 16 ++++++++++++- compiler/ml/typedecl.ml | 9 +++++++ ...on_private_abstract_attribute.res.expected | 9 +++++++ ...n_private_record_construction.res.expected | 10 ++++++++ ...rivate_record_immutable_field.res.expected | 10 ++++++++ ...utation_private_record_update.res.expected | 10 ++++++++ ...ion_private_variant_attribute.res.expected | 9 +++++++ ...ation_public_record_attribute.res.expected | 9 +++++++ ...utation_without_allowMutation.res.expected | 10 ++++++++ ...lowMutation_private_abstract_attribute.res | 2 ++ ...owMutation_private_record_construction.res | 10 ++++++++ ...utation_private_record_immutable_field.res | 11 +++++++++ .../allowMutation_private_record_update.res | 11 +++++++++ ...llowMutation_private_variant_attribute.res | 2 ++ .../allowMutation_public_record_attribute.res | 2 ++ ..._record_mutation_without_allowMutation.res | 10 ++++++++ .../tests/src/allowMutationPrivateRecord.mjs | 24 +++++++++++++++++++ .../tests/src/allowMutationPrivateRecord.res | 8 +++++++ .../tests/src/allowMutationPrivateRecord.resi | 9 +++++++ .../src/allowMutationPrivateRecord_test.mjs | 17 +++++++++++++ .../src/allowMutationPrivateRecord_test.res | 12 ++++++++++ 24 files changed, 219 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/super_errors/expected/allowMutation_private_abstract_attribute.res.expected create mode 100644 tests/build_tests/super_errors/expected/allowMutation_private_record_construction.res.expected create mode 100644 tests/build_tests/super_errors/expected/allowMutation_private_record_immutable_field.res.expected create mode 100644 tests/build_tests/super_errors/expected/allowMutation_private_record_update.res.expected create mode 100644 tests/build_tests/super_errors/expected/allowMutation_private_variant_attribute.res.expected create mode 100644 tests/build_tests/super_errors/expected/allowMutation_public_record_attribute.res.expected create mode 100644 tests/build_tests/super_errors/expected/private_record_mutation_without_allowMutation.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/allowMutation_private_abstract_attribute.res create mode 100644 tests/build_tests/super_errors/fixtures/allowMutation_private_record_construction.res create mode 100644 tests/build_tests/super_errors/fixtures/allowMutation_private_record_immutable_field.res create mode 100644 tests/build_tests/super_errors/fixtures/allowMutation_private_record_update.res create mode 100644 tests/build_tests/super_errors/fixtures/allowMutation_private_variant_attribute.res create mode 100644 tests/build_tests/super_errors/fixtures/allowMutation_public_record_attribute.res create mode 100644 tests/build_tests/super_errors/fixtures/private_record_mutation_without_allowMutation.res create mode 100644 tests/tests/src/allowMutationPrivateRecord.mjs create mode 100644 tests/tests/src/allowMutationPrivateRecord.res create mode 100644 tests/tests/src/allowMutationPrivateRecord.resi create mode 100644 tests/tests/src/allowMutationPrivateRecord_test.mjs create mode 100644 tests/tests/src/allowMutationPrivateRecord_test.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 6aa51477a94..8c89d284bb6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,7 @@ - Rewatch: add `--prod` flag to `build`, `watch`, and `clean` to skip dev-dependencies and dev sources (`"type": "dev"`), enabling builds in environments where dev packages aren't installed (e.g. after `pnpm install --prod`). https://github.com/rescript-lang/rescript/pull/8347 - Add `Dict.assignMany`, `Dict.concat`, `Dict.concatMany`, `Dict.concatAll`, `Array.concatAll` to the stdlib. https://github.com/rescript-lang/rescript/pull/8364 +- Allow mutation of private record fields with @allowMutation https://github.com/rescript-lang/rescript/pull/8366 #### :bug: Bug fix diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml index a4d073104b4..877d1963b86 100644 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -240,6 +240,13 @@ let immediate = | {txt = "ocaml.immediate" | "immediate"; _}, _ -> true | _ -> false) +let has_allow_mutation attr = + List.exists + (function + | {txt = "allowMutation"; _}, _ -> true + | _ -> false) + attr + (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" attributes cannot be input by the user, they are added by the compiler when applying the default setting. This is done to record diff --git a/compiler/ml/builtin_attributes.mli b/compiler/ml/builtin_attributes.mli index 63bf7623315..dd679333497 100644 --- a/compiler/ml/builtin_attributes.mli +++ b/compiler/ml/builtin_attributes.mli @@ -93,5 +93,7 @@ val explicit_arity : Parsetree.attributes -> bool val immediate : Parsetree.attributes -> bool +val has_allow_mutation : Parsetree.attributes -> bool + val has_unboxed : Parsetree.attributes -> bool val has_boxed : Parsetree.attributes -> bool diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index f069a9412e0..5b96ea7306c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -314,6 +314,14 @@ let extract_concrete_record env ty = | p0, p, {type_kind = Type_record (fields, repr)} -> (p0, p, fields, repr) | _ -> raise Not_found +let private_record_allows_mutation env label = + match extract_concrete_typedecl env label.lbl_res with + | _, _, {type_kind = Type_record _; type_private = Private; type_attributes} + -> + Builtin_attributes.has_allow_mutation type_attributes + | _ -> false + | exception Not_found -> false + let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with | p0, p, {type_kind = Type_variant cstrs} -> (p0, p, cstrs) @@ -3463,7 +3471,13 @@ and type_label_exp ~call_context create env loc ty_expected end_def (); (* Generalize information merged from ty_expected *) generalize_structure ty_arg); - if label.lbl_private = Private then + let allow_private_assignment = + match call_context with + | `SetRecordField when not create -> + private_record_allows_mutation env label + | _ -> false + in + if label.lbl_private = Private && not allow_private_assignment then if create then raise (Error (loc, env, Private_type ty_expected)) else raise (Error (lid.loc, env, Private_label (lid.txt, ty_expected))); let arg = diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 0f44d4595f4..4da9f45f3e5 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -381,6 +381,15 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = ( sdecl.ptype_loc, Invalid_attribute "@notUndefined can only be used on abstract types" ))); + (if Builtin_attributes.has_allow_mutation sdecl.ptype_attributes then + match (sdecl.ptype_private, sdecl.ptype_kind) with + | Private, Ptype_record _ -> () + | _ -> + raise + (Error + ( sdecl.ptype_loc, + Invalid_attribute + "@allowMutation can only be used on private record types" ))); (* Bind type parameters *) reset_type_variables (); diff --git a/tests/build_tests/super_errors/expected/allowMutation_private_abstract_attribute.res.expected b/tests/build_tests/super_errors/expected/allowMutation_private_abstract_attribute.res.expected new file mode 100644 index 00000000000..107dea8190c --- /dev/null +++ b/tests/build_tests/super_errors/expected/allowMutation_private_abstract_attribute.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/allowMutation_private_abstract_attribute.res:2:1-20 + + 1 │ @allowMutation + 2 │ type t = private int + 3 │ + + @allowMutation can only be used on private record types \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/allowMutation_private_record_construction.res.expected b/tests/build_tests/super_errors/expected/allowMutation_private_record_construction.res.expected new file mode 100644 index 00000000000..f4d2a59656c --- /dev/null +++ b/tests/build_tests/super_errors/expected/allowMutation_private_record_construction.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/allowMutation_private_record_construction.res:10:30-39 + + 8 │ } + 9 │ + 10 │ let _item: PrivateRecord.t = {value: 1} + 11 │ + + Cannot create values of the private type PrivateRecord.t \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/allowMutation_private_record_immutable_field.res.expected b/tests/build_tests/super_errors/expected/allowMutation_private_record_immutable_field.res.expected new file mode 100644 index 00000000000..bf1a495122e --- /dev/null +++ b/tests/build_tests/super_errors/expected/allowMutation_private_record_immutable_field.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/allowMutation_private_record_immutable_field.res:11:1-21 + + 9 │ + 10 │ let item = PrivateRecord.make(1) + 11 │ item.name = "changed" + 12 │ + + The record field name is not mutable \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/allowMutation_private_record_update.res.expected b/tests/build_tests/super_errors/expected/allowMutation_private_record_update.res.expected new file mode 100644 index 00000000000..2a7f9f7e975 --- /dev/null +++ b/tests/build_tests/super_errors/expected/allowMutation_private_record_update.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/allowMutation_private_record_update.res:11:16-34 + + 9 │ + 10 │ let item = PrivateRecord.make(1) + 11 │ let _updated = {...item, value: 2} + 12 │ + + Cannot create values of the private type PrivateRecord.t \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/allowMutation_private_variant_attribute.res.expected b/tests/build_tests/super_errors/expected/allowMutation_private_variant_attribute.res.expected new file mode 100644 index 00000000000..9928291eaba --- /dev/null +++ b/tests/build_tests/super_errors/expected/allowMutation_private_variant_attribute.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/allowMutation_private_variant_attribute.res:2:1-22 + + 1 │ @allowMutation + 2 │ type t = private A | B + 3 │ + + @allowMutation can only be used on private record types \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/allowMutation_public_record_attribute.res.expected b/tests/build_tests/super_errors/expected/allowMutation_public_record_attribute.res.expected new file mode 100644 index 00000000000..8c7f3110d48 --- /dev/null +++ b/tests/build_tests/super_errors/expected/allowMutation_public_record_attribute.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/allowMutation_public_record_attribute.res:2:1-29 + + 1 │ @allowMutation + 2 │ type t = {mutable value: int} + 3 │ + + @allowMutation can only be used on private record types \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/private_record_mutation_without_allowMutation.res.expected b/tests/build_tests/super_errors/expected/private_record_mutation_without_allowMutation.res.expected new file mode 100644 index 00000000000..1650667d847 --- /dev/null +++ b/tests/build_tests/super_errors/expected/private_record_mutation_without_allowMutation.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/private_record_mutation_without_allowMutation.res:10:6-10 + + 8 │ + 9 │ let item = PrivateRecord.make(1) + 10 │ item.value = 2 + 11 │ + + Cannot assign field value of the private type PrivateRecord.t \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/allowMutation_private_abstract_attribute.res b/tests/build_tests/super_errors/fixtures/allowMutation_private_abstract_attribute.res new file mode 100644 index 00000000000..cb6e2710e3d --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/allowMutation_private_abstract_attribute.res @@ -0,0 +1,2 @@ +@allowMutation +type t = private int diff --git a/tests/build_tests/super_errors/fixtures/allowMutation_private_record_construction.res b/tests/build_tests/super_errors/fixtures/allowMutation_private_record_construction.res new file mode 100644 index 00000000000..7a1ec724aa9 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/allowMutation_private_record_construction.res @@ -0,0 +1,10 @@ +module PrivateRecord: { + @allowMutation + type t = private {mutable value: int} + let make: int => t +} = { + type t = {mutable value: int} + let make = value => {value: value} +} + +let _item: PrivateRecord.t = {value: 1} diff --git a/tests/build_tests/super_errors/fixtures/allowMutation_private_record_immutable_field.res b/tests/build_tests/super_errors/fixtures/allowMutation_private_record_immutable_field.res new file mode 100644 index 00000000000..5a23fdc32e5 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/allowMutation_private_record_immutable_field.res @@ -0,0 +1,11 @@ +module PrivateRecord: { + @allowMutation + type t = private {mutable value: int, name: string} + let make: int => t +} = { + type t = {mutable value: int, name: string} + let make = value => {value, name: "stable"} +} + +let item = PrivateRecord.make(1) +item.name = "changed" diff --git a/tests/build_tests/super_errors/fixtures/allowMutation_private_record_update.res b/tests/build_tests/super_errors/fixtures/allowMutation_private_record_update.res new file mode 100644 index 00000000000..09aba6dcb5f --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/allowMutation_private_record_update.res @@ -0,0 +1,11 @@ +module PrivateRecord: { + @allowMutation + type t = private {mutable value: int} + let make: int => t +} = { + type t = {mutable value: int} + let make = value => {value: value} +} + +let item = PrivateRecord.make(1) +let _updated = {...item, value: 2} diff --git a/tests/build_tests/super_errors/fixtures/allowMutation_private_variant_attribute.res b/tests/build_tests/super_errors/fixtures/allowMutation_private_variant_attribute.res new file mode 100644 index 00000000000..d9120dbfc8c --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/allowMutation_private_variant_attribute.res @@ -0,0 +1,2 @@ +@allowMutation +type t = private A | B diff --git a/tests/build_tests/super_errors/fixtures/allowMutation_public_record_attribute.res b/tests/build_tests/super_errors/fixtures/allowMutation_public_record_attribute.res new file mode 100644 index 00000000000..46cd4adecf5 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/allowMutation_public_record_attribute.res @@ -0,0 +1,2 @@ +@allowMutation +type t = {mutable value: int} diff --git a/tests/build_tests/super_errors/fixtures/private_record_mutation_without_allowMutation.res b/tests/build_tests/super_errors/fixtures/private_record_mutation_without_allowMutation.res new file mode 100644 index 00000000000..c375d8e6b3e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/private_record_mutation_without_allowMutation.res @@ -0,0 +1,10 @@ +module PrivateRecord: { + type t = private {mutable value: int} + let make: int => t +} = { + type t = {mutable value: int} + let make = value => {value: value} +} + +let item = PrivateRecord.make(1) +item.value = 2 diff --git a/tests/tests/src/allowMutationPrivateRecord.mjs b/tests/tests/src/allowMutationPrivateRecord.mjs new file mode 100644 index 00000000000..6de7f921e70 --- /dev/null +++ b/tests/tests/src/allowMutationPrivateRecord.mjs @@ -0,0 +1,24 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function make(value) { + return { + value: value, + name: "stable" + }; +} + +function value(t) { + return t.value; +} + +function name(t) { + return t.name; +} + +export { + make, + value, + name, +} +/* No side effect */ diff --git a/tests/tests/src/allowMutationPrivateRecord.res b/tests/tests/src/allowMutationPrivateRecord.res new file mode 100644 index 00000000000..bf8e308c438 --- /dev/null +++ b/tests/tests/src/allowMutationPrivateRecord.res @@ -0,0 +1,8 @@ +type t = { + mutable value: int, + name: string, +} + +let make = value => {value, name: "stable"} +let value = t => t.value +let name = t => t.name diff --git a/tests/tests/src/allowMutationPrivateRecord.resi b/tests/tests/src/allowMutationPrivateRecord.resi new file mode 100644 index 00000000000..01ac08b6458 --- /dev/null +++ b/tests/tests/src/allowMutationPrivateRecord.resi @@ -0,0 +1,9 @@ +@allowMutation +type t = private { + mutable value: int, + name: string, +} + +let make: int => t +let value: t => int +let name: t => string diff --git a/tests/tests/src/allowMutationPrivateRecord_test.mjs b/tests/tests/src/allowMutationPrivateRecord_test.mjs new file mode 100644 index 00000000000..3aa45d47b64 --- /dev/null +++ b/tests/tests/src/allowMutationPrivateRecord_test.mjs @@ -0,0 +1,17 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; +import * as AllowMutationPrivateRecord from "./allowMutationPrivateRecord.mjs"; + +Mocha.describe("AllowMutationPrivateRecord_test", () => { + Mocha.test("mutates a mutable field exposed by an @allowMutation private record", () => { + let item = AllowMutationPrivateRecord.make(1); + item.value = 2; + Test_utils.eq("File \"allowMutationPrivateRecord_test.res\", line 8, characters 7-14", item.value, 2); + Test_utils.eq("File \"allowMutationPrivateRecord_test.res\", line 9, characters 7-14", AllowMutationPrivateRecord.value(item), 2); + Test_utils.eq("File \"allowMutationPrivateRecord_test.res\", line 10, characters 7-14", item.name, "stable"); + }); +}); + +/* Not a pure module */ diff --git a/tests/tests/src/allowMutationPrivateRecord_test.res b/tests/tests/src/allowMutationPrivateRecord_test.res new file mode 100644 index 00000000000..5ab791cf4fb --- /dev/null +++ b/tests/tests/src/allowMutationPrivateRecord_test.res @@ -0,0 +1,12 @@ +open Mocha +open Test_utils + +describe(__MODULE__, () => { + test("mutates a mutable field exposed by an @allowMutation private record", () => { + let item = AllowMutationPrivateRecord.make(1) + item.value = 2 + eq(__LOC__, item.value, 2) + eq(__LOC__, AllowMutationPrivateRecord.value(item), 2) + eq(__LOC__, item.name, "stable") + }) +}) From 57f0c887a40bfef8f3120153175714180ab842bd Mon Sep 17 00:00:00 2001 From: tsnobip Date: Sun, 19 Apr 2026 14:27:11 +0200 Subject: [PATCH 2/2] simplify check of private assignment --- compiler/ml/typecore.ml | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 5b96ea7306c..1d985033934 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -313,15 +313,6 @@ let extract_concrete_record env ty = match extract_concrete_typedecl env ty with | p0, p, {type_kind = Type_record (fields, repr)} -> (p0, p, fields, repr) | _ -> raise Not_found - -let private_record_allows_mutation env label = - match extract_concrete_typedecl env label.lbl_res with - | _, _, {type_kind = Type_record _; type_private = Private; type_attributes} - -> - Builtin_attributes.has_allow_mutation type_attributes - | _ -> false - | exception Not_found -> false - let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with | p0, p, {type_kind = Type_variant cstrs} -> (p0, p, cstrs) @@ -3471,15 +3462,24 @@ and type_label_exp ~call_context create env loc ty_expected end_def (); (* Generalize information merged from ty_expected *) generalize_structure ty_arg); - let allow_private_assignment = - match call_context with - | `SetRecordField when not create -> - private_record_allows_mutation env label - | _ -> false - in - if label.lbl_private = Private && not allow_private_assignment then - if create then raise (Error (loc, env, Private_type ty_expected)) - else raise (Error (lid.loc, env, Private_label (lid.txt, ty_expected))); + (if label.lbl_private = Private then + if create then raise (Error (loc, env, Private_type ty_expected)) + else + let allow_private_assignment = + match extract_concrete_typedecl env label.lbl_res with + | ( _, + _, + { + type_kind = Type_record _; + type_private = Private; + type_attributes; + } ) -> + Builtin_attributes.has_allow_mutation type_attributes + | _ -> false + | exception Not_found -> false + in + if not allow_private_assignment then + raise (Error (lid.loc, env, Private_label (lid.txt, ty_expected)))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in let field_name = Longident.last lid.txt in