allow mutation of private record fields with @allowMutation

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
 

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

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

compiler/ml/typecore.ml

@@ -313,7 +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 extract_concrete_variant env ty =
   match extract_concrete_typedecl env ty with
   | p0, p, {type_kind = Type_variant cstrs} -> (p0, p, cstrs)
@@ -3463,9 +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);
-  if label.lbl_private = Private 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

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 ();

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

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

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

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

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

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

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

tests/build_tests/super_errors/fixtures/allowMutation_private_abstract_attribute.res

@@ -0,0 +1,2 @@
+@allowMutation
+type t = private int

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}

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"

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}

tests/build_tests/super_errors/fixtures/allowMutation_private_variant_attribute.res

@@ -0,0 +1,2 @@
+@allowMutation
+type t = private A | B

tests/build_tests/super_errors/fixtures/allowMutation_public_record_attribute.res

@@ -0,0 +1,2 @@
+@allowMutation
+type t = {mutable value: int}

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

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 */

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

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

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 */

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")
+  })
+})