allow mutation of private record fields with @allowMutation

tsnobip · tsnobip · commit 3a8f357e19cd · 2026-04-19T11:38:54.000+02:00
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -0,0 +1,9 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/allowMutation_private_abstract_attribute.res[0m:[2m2:1-20[0m
+
+  1 [2m│[0m @allowMutation
+  [1;31m2[0m [2m│[0m [1;31mtype t = private int[0m
+  3 [2m│[0m 
+
+  @allowMutation can only be used on private record types
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/allowMutation_private_record_construction.res[0m:[2m10:30-39[0m
+
+   8 [2m│[0m }
+   9 [2m│[0m 
+  [1;31m10[0m [2m│[0m let _item: PrivateRecord.t = [1;31m{value: 1}[0m
+  11 [2m│[0m 
+
+  Cannot create values of the private type PrivateRecord.t
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/allowMutation_private_record_immutable_field.res[0m:[2m11:1-21[0m
+
+   9 [2m│[0m 
+  10 [2m│[0m let item = PrivateRecord.make(1)
+  [1;31m11[0m [2m│[0m [1;31mitem.name = "changed"[0m
+  12 [2m│[0m 
+
+  The record field name is not mutable
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/allowMutation_private_record_update.res[0m:[2m11:16-34[0m
+
+   9 [2m│[0m 
+  10 [2m│[0m let item = PrivateRecord.make(1)
+  [1;31m11[0m [2m│[0m let _updated = [1;31m{...item, value: 2}[0m
+  12 [2m│[0m 
+
+  Cannot create values of the private type PrivateRecord.t
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
@@ -0,0 +1,9 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/allowMutation_private_variant_attribute.res[0m:[2m2:1-22[0m
+
+  1 [2m│[0m @allowMutation
+  [1;31m2[0m [2m│[0m [1;31mtype t = private A | B[0m
+  3 [2m│[0m 
+
+  @allowMutation can only be used on private record types
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
@@ -0,0 +1,9 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/allowMutation_public_record_attribute.res[0m:[2m2:1-29[0m
+
+  1 [2m│[0m @allowMutation
+  [1;31m2[0m [2m│[0m [1;31mtype t = {mutable value: int}[0m
+  3 [2m│[0m 
+
+  @allowMutation can only be used on private record types
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
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/private_record_mutation_without_allowMutation.res[0m:[2m10:6-10[0m
+
+   8 [2m│[0m 
+   9 [2m│[0m let item = PrivateRecord.make(1)
+  [1;31m10[0m [2m│[0m item.[1;31mvalue[0m = 2
+  11 [2m│[0m 
+
+  Cannot assign field value of the private type PrivateRecord.t
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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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")
+  })
+})

-Original file line number
+Diff line change
@@ @@ -0,0 +1,9 @@ @@
++
 +  [1;31mWe've found a bug for you![0m
 +  [36m/.../fixtures/allowMutation_private_abstract_attribute.res[0m:[2m2:1-20[0m
++
 +  1 [2m│[0m @allowMutation
 +  [1;31m2[0m [2m│[0m [1;31mtype t = private int[0m
 +  3 [2m│[0m
++
 +  @allowMutation can only be used on private record types
-Original file line number
+Diff line change
@@ @@ -0,0 +1,10 @@ @@
++
 +  [1;31mWe've found a bug for you![0m
 +  [36m/.../fixtures/allowMutation_private_record_construction.res[0m:[2m10:30-39[0m
++
 +   8 [2m│[0m }
 +   9 [2m│[0m
 +  [1;31m10[0m [2m│[0m let _item: PrivateRecord.t = [1;31m{value: 1}[0m
 +  11 [2m│[0m
++
 +  Cannot create values of the private type PrivateRecord.t