remove annotation and make it a warning instead

Author: tsnobip

compiler/ext/warnings.ml

@@ -74,6 +74,7 @@ type t =
   | Bs_toplevel_expression_unit of
       (string * top_level_unit_help) option (* 109 *)
   | Bs_todo of string option (* 110 *)
+  | Bs_private_record_mutation of string (* 111 *)
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
    the numbers of existing warnings.
@@ -126,8 +127,9 @@ let number = function
   | Bs_integer_literal_overflow -> 107
   | Bs_toplevel_expression_unit _ -> 109
   | Bs_todo _ -> 110
+  | Bs_private_record_mutation _ -> 111
 
-let last_warning_number = 110
+let last_warning_number = 111
 
 let letter_all =
   let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
@@ -453,6 +455,8 @@ let message = function
     ^ "\n\n\
       \  This code is not implemented yet and will crash at runtime. Make sure \
        you implement this before running the code."
+  | Bs_private_record_mutation field_name ->
+    Printf.sprintf "Mutation of private record field %S." field_name
 
 let sub_locs = function
   | Deprecated (_, def, use, _) ->
@@ -564,6 +568,7 @@ let descriptions =
     );
     (109, "Toplevel expression has unit type");
     (110, "Todo found");
+    (111, "Mutation of private record field");
   ]
 
 let help_warnings () =

compiler/ext/warnings.mli

@@ -67,6 +67,7 @@ type t =
   | Bs_toplevel_expression_unit of
       (string * top_level_unit_help) option (* 109 *)
   | Bs_todo of string option (* 110 *)
+  | Bs_private_record_mutation of string (* 111 *)
 
 val parse_options : bool -> string -> unit
 

compiler/ml/builtin_attributes.ml

@@ -240,13 +240,6 @@ 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,7 +93,5 @@ 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

@@ -57,7 +57,6 @@ type error =
       string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
   | Undefined_method of type_expr * string * string list option
   | Private_type of type_expr
-  | Private_label of Longident.t * type_expr
   | Not_subtype of
       Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option
   | Too_many_arguments of bool * type_expr
@@ -316,6 +315,13 @@ 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 is_private_record_field env label =
+  match extract_concrete_typedecl env label.lbl_res with
+  | _, _, {type_kind = Type_record _; type_private = Private} -> true
+  | _ -> 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)
@@ -2952,6 +2958,9 @@ and type_expect_ ?deprecated_context ~context ?in_function ?(recarg = Rejected)
     unify_exp ~context:None env record ty_record;
     if label.lbl_mut = Immutable then
       raise (Error (loc, env, Label_not_mutable lid.txt));
+    if label.lbl_private = Private && is_private_record_field env label then
+      Location.prerr_warning lid.loc
+        (Warnings.Bs_private_record_mutation (Longident.last lid.txt));
     Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes
       (Longident.last lid.txt);
     rue
@@ -3636,24 +3645,8 @@ 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
-       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))));
+  if label.lbl_private = Private && create then
+    raise (Error (loc, env, Private_type ty_expected));
   let arg =
     let snap = if vars = [] then None else Some (Btype.snapshot ()) in
     let field_name = Longident.last lid.txt in
@@ -4842,9 +4835,6 @@ let report_error env loc ppf error =
       "In this type, the locally bound module name %s escapes its scope" id
   | Private_type ty ->
     fprintf ppf "Cannot create values of the private type %a" type_expr ty
-  | Private_label (lid, ty) ->
-    fprintf ppf "Cannot assign field %a of the private type %a" longident lid
-      type_expr ty
   | Not_a_variant_type lid ->
     fprintf ppf "The type %a@ is not a variant type" longident lid
   | Incoherent_label_order ->

compiler/ml/typecore.mli

@@ -90,7 +90,6 @@ type error =
       string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
   | Undefined_method of type_expr * string * string list option
   | Private_type of type_expr
-  | Private_label of Longident.t * type_expr
   | Not_subtype of
       Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option
   | Too_many_arguments of bool * type_expr

compiler/ml/typedecl.ml

@@ -387,16 +387,6 @@ 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 ();
   Ctype.begin_def ();