parsetree.{row,object}_field: move attributes in the wrapper record

The concrete syntax only allows attributes on tags/constructors/fields
(Rtag, Otag), not on inherited subtypes (Rinherit, Oinherit); we add
this as new enforced invariant in ast_invariants.

ocamldoc/odoc_sig.ml

@@ -291,15 +291,15 @@ module Analyser =
             let fields = List.map (fun {pof_desc; _} -> pof_desc) fields in
             let rec f = function
               | [] -> []
-              | Otag ({txt=""},_,_) :: _ ->
+              | Otag ({txt=""},_) :: _ ->
                 (* Fields with no name have been eliminated previously. *)
                 assert false
-              | Otag ({txt=name}, _atts, ct) :: [] ->
+              | Otag ({txt=name}, ct) :: [] ->
                 let pos = Loc.ptyp_end ct in
                 let (_,comment_opt) = just_after_special pos pos_end in
                 [name, comment_opt]
-              | Otag ({txt=name}, _, ct) ::
-                  ((Oinherit ct2 | Otag (_, _, ct2)) as ele2) :: q ->
+              | Otag ({txt=name}, ct) ::
+                  ((Oinherit ct2 | Otag (_, ct2)) as ele2) :: q ->
                 let pos = Loc.ptyp_end ct in
                 let pos2 = Loc.ptyp_start ct2 in
                 let (_,comment_opt) = just_after_special pos pos2 in
@@ -308,7 +308,7 @@ module Analyser =
             in
             let is_named_field field =
               match field with
-              | Otag ({txt=""},_,_) -> false
+              | Otag ({txt=""},_) -> false
               | _ -> true
             in
             (0, f @@ List.filter is_named_field fields)

parsing/ast_helper.ml

@@ -114,16 +114,16 @@ module Typ = struct
       {t with ptyp_desc = desc}
     and loop_row_field field =
       let prf_desc = match field.prf_desc with
-        | Rtag(label,attrs,flag,lst) ->
-            Rtag(label,attrs,flag,List.map loop lst)
+        | Rtag(label,flag,lst) ->
+            Rtag(label,flag,List.map loop lst)
         | Rinherit t ->
             Rinherit (loop t)
       in
       { field with prf_desc; }
     and loop_object_field field =
       let pof_desc = match field.pof_desc with
-        | Otag(label, attrs, t) ->
-            Otag(label, attrs, loop t)
+        | Otag(label, t) ->
+            Otag(label, loop t)
         | Oinherit t ->
             Oinherit (loop t)
       in
@@ -581,24 +581,26 @@ end
 
 (** Row fields *)
 module Rf = struct
-  let mk ?(loc = !default_loc) desc = {
+  let mk ?(loc = !default_loc) ?(attrs = []) desc = {
     prf_desc = desc;
     prf_loc = loc;
+    prf_attributes = attrs;
   }
-  let tag ?(loc = !default_loc) ?(attrs = []) label const tys =
-    mk ~loc (Rtag (label, attrs, const, tys))
-  let inherit_ ?(loc = !default_loc) ty =
-    mk ~loc (Rinherit ty)
+  let tag ?loc ?attrs label const tys =
+    mk ?loc ?attrs (Rtag (label, const, tys))
+  let inherit_?loc ty =
+    mk ?loc (Rinherit ty)
 end
 
 (** Object fields *)
 module Of = struct
-  let mk ?(loc = !default_loc) desc = {
+  let mk ?(loc = !default_loc) ?(attrs=[]) desc = {
     pof_desc = desc;
     pof_loc = loc;
+    pof_attributes = attrs;
   }
-  let tag ?(loc = !default_loc) ?(attrs = []) label ty =
-    mk ~loc (Otag (label, attrs, ty))
-  let inherit_ ?(loc = !default_loc) ty =
-    mk ~loc (Oinherit ty)
+  let tag ?loc ?attrs label ty =
+    mk ?loc ?attrs (Otag (label, ty))
+  let inherit_ ?loc ty =
+    mk ?loc (Oinherit ty)
 end

parsing/ast_helper.mli

@@ -454,7 +454,7 @@ module Cstr:
 (** Row fields *)
 module Rf:
   sig
-    val mk: ?loc:loc -> row_field_desc -> row_field
+    val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field
     val tag: ?loc:loc -> ?attrs:attrs ->
       label with_loc -> bool -> core_type list -> row_field
     val inherit_: ?loc:loc -> core_type -> row_field
@@ -463,7 +463,8 @@ module Rf:
 (** Object fields *)
 module Of:
   sig
-    val mk: ?loc:loc -> object_field_desc -> object_field
+    val mk: ?loc:loc -> ?attrs:attrs ->
+      object_field_desc -> object_field
     val tag: ?loc:loc -> ?attrs:attrs ->
       label with_loc -> core_type -> object_field
     val inherit_: ?loc:loc -> core_type -> object_field

parsing/ast_invariants.ml

@@ -145,6 +145,30 @@ let iterator =
     | Psig_type (_, []) -> empty_type loc
     | _ -> ()
   in
+  let row_field self field =
+    super.row_field self field;
+    let loc = field.prf_loc in
+    match field.prf_desc with
+    | Rtag _ -> ()
+    | Rinherit _ ->
+      if field.prf_attributes = []
+      then ()
+      else err loc
+          "In variant types, attaching attributes to inherited \
+           subtypes is not allowed."
+  in
+  let object_field self field =
+    super.object_field self field;
+    let loc = field.pof_loc in
+    match field.pof_desc with
+    | Otag _ -> ()
+    | Oinherit _ ->
+      if field.pof_attributes = []
+      then ()
+      else err loc
+          "In object types, attaching attributes to inherited \
+           subtypes is not allowed."
+  in
   { super with
     type_declaration
   ; typ
@@ -158,6 +182,8 @@ let iterator =
   ; with_constraint
   ; structure_item
   ; signature_item
+  ; row_field
+  ; object_field
   }
 
 let structure st = iterator.structure iterator st

parsing/ast_iterator.ml

@@ -88,21 +88,23 @@ module T = struct
   let row_field sub {
       prf_desc;
       prf_loc;
+      prf_attributes;
     } =
     sub.location sub prf_loc;
+    sub.attributes sub prf_attributes;
     match prf_desc with
-    | Rtag (_, attrs, _, tl) ->
-        sub.attributes sub attrs; List.iter (sub.typ sub) tl
+    | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl
     | Rinherit t -> sub.typ sub t
 
   let object_field sub {
       pof_desc;
       pof_loc;
+      pof_attributes;
     } =
     sub.location sub pof_loc;
+    sub.attributes sub pof_attributes;
     match pof_desc with
-    | Otag (_, attrs, t) ->
-        sub.attributes sub attrs; sub.typ sub t
+    | Otag (_, t) -> sub.typ sub t
     | Oinherit t -> sub.typ sub t
 
   let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =

parsing/ast_mapper.ml

@@ -88,28 +88,28 @@ module T = struct
   let row_field sub {
       prf_desc;
       prf_loc;
+      prf_attributes;
     } =
     let loc = sub.location sub prf_loc in
+    let attrs = sub.attributes sub prf_attributes in
     let desc = match prf_desc with
-      | Rtag (l, attrs, b, tl) ->
-          let attrs = sub.attributes sub attrs in
-          Rtag (map_loc sub l, attrs, b, List.map (sub.typ sub) tl)
+      | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl)
       | Rinherit t -> Rinherit (sub.typ sub t)
     in
-    Rf.mk ~loc desc
+    Rf.mk ~loc ~attrs desc
 
   let object_field sub {
       pof_desc;
       pof_loc;
+      pof_attributes;
     } =
     let loc = sub.location sub pof_loc in
+    let attrs = sub.attributes sub pof_attributes in
     let desc = match pof_desc with
-      | Otag (l, attrs, t) ->
-          let attrs = sub.attributes sub attrs in
-          Otag (map_loc sub l, attrs, sub.typ sub t)
+      | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t)
       | Oinherit t -> Oinherit (sub.typ sub t)
     in
-    Of.mk ~loc desc
+    Of.mk ~loc ~attrs desc
 
   let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
     let open Typ in

parsing/depend.ml

@@ -105,14 +105,14 @@ let rec add_type bv ty =
   | Ptyp_object (fl, _) ->
       List.iter
        (fun {pof_desc; _} -> match pof_desc with
-         | Otag (_, _, t) -> add_type bv t
+         | Otag (_, t) -> add_type bv t
          | Oinherit t -> add_type bv t) fl
   | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
   | Ptyp_alias(t, _) -> add_type bv t
   | Ptyp_variant(fl, _, _) ->
       List.iter
         (fun {prf_desc; _} -> match prf_desc with
-          | Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
+          | Rtag(_, _, stl) -> List.iter (add_type bv) stl
           | Rinherit sty -> add_type bv sty)
         fl
   | Ptyp_poly(_, t) -> add_type bv t

parsing/parsetree.mli

@@ -148,10 +148,11 @@ and package_type = Longident.t loc * (Longident.t loc * core_type) list
 and row_field = {
   prf_desc : row_field_desc;
   prf_loc : Location.t;
+  prf_attributes : attributes;
 }
 
 and row_field_desc =
-  | Rtag of label loc * attributes * bool * core_type list
+  | Rtag of label loc * bool * core_type list
         (* [`A]                   ( true,  [] )
            [`A of T]              ( false, [T] )
            [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
@@ -170,10 +171,11 @@ and row_field_desc =
 and object_field = {
   pof_desc : object_field_desc;
   pof_loc : Location.t;
+  pof_attributes : attributes;
 }
 
 and object_field_desc =
-  | Otag of label loc * attributes * core_type
+  | Otag of label loc * core_type
   | Oinherit of core_type
 
 (* Patterns *)

parsing/pprintast.ml

@@ -288,13 +288,13 @@ and core_type1 ctxt f x =
     | Ptyp_variant (l, closed, low) ->
         let type_variant_helper f x =
           match x.prf_desc with
-          | Rtag (l, attrs, _, ctl) ->
+          | Rtag (l, _, ctl) ->
               pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
                 (fun f l -> match l with
                    |[] -> ()
                    | _ -> pp f "@;of@;%a"
                             (list (core_type ctxt) ~sep:"&")  ctl) ctl
-                (attributes ctxt) attrs
+                (attributes ctxt) x.prf_attributes
           | Rinherit ct -> core_type ctxt f ct in
         pp f "@[<2>[%a%a]@]"
           (fun f l ->
@@ -315,9 +315,10 @@ and core_type1 ctxt f x =
                    (list string_quot) xs) low
     | Ptyp_object (l, o) ->
         let core_field_type f x = match x.pof_desc with
-          | Otag (l, attrs, ct) ->
+          | Otag (l, ct) ->
+            (* Cf #7200 *)
             pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
-              (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
+              (core_type ctxt) ct (attributes ctxt) x.pof_attributes
           | Oinherit ct ->
             pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
         in

parsing/printast.ml

@@ -165,9 +165,9 @@ let rec core_type i ppf x =
       let i = i + 1 in
       List.iter (fun field ->
         match field.pof_desc with
-          | Otag (l, attrs, t) ->
+          | Otag (l, t) ->
             line i ppf "method %s\n" l.txt;
-            attributes i ppf attrs;
+            attributes i ppf field.pof_attributes;
             core_type (i + 1) ppf t
           | Oinherit ct ->
               line i ppf "Oinherit\n";
@@ -894,9 +894,9 @@ and label_x_expression i ppf (l,e) =
 
 and label_x_bool_x_core_type_list i ppf x =
   match x.prf_desc with
-    Rtag (l, attrs, b, ctl) ->
+    Rtag (l, b, ctl) ->
       line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
-      attributes (i+1) ppf attrs;
+      attributes (i+1) ppf x.prf_attributes;
       list (i+1) core_type ppf ctl
   | Rinherit (ct) ->
       line i ppf "Rinherit\n";

typing/printtyped.ml

@@ -190,10 +190,11 @@ let rec core_type i ppf x =
   | Ttyp_object (l, c) ->
       line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
       let i = i + 1 in
-      List.iter (fun {of_desc; _} -> match of_desc with
-        | OTtag (s, attrs, t) ->
+      List.iter (fun {of_desc; of_attributes; _} ->
+        match of_desc with
+        | OTtag (s, t) ->
             line i ppf "method %s\n" s.txt;
-            attributes i ppf attrs;
+            attributes i ppf of_attributes;
             core_type (i + 1) ppf t
         | OTinherit ct ->
             line i ppf "OTinherit\n";
@@ -883,9 +884,9 @@ and ident_x_expression_def i ppf (l, e) =
 
 and label_x_bool_x_core_type_list i ppf x =
   match x.rf_desc with
-  | Ttag (l, attrs, b, ctl) ->
+  | Ttag (l, b, ctl) ->
       line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
-      attributes (i+1) ppf attrs;
+      attributes (i+1) ppf x.rf_attributes;
       list (i+1) core_type ppf ctl
   | Tinherit (ct) ->
       line i ppf "Tinherit\n";

typing/tast_mapper.ml

@@ -614,16 +614,16 @@ let class_structure sub x =
 
 let row_field sub x =
   let rf_desc = match x.rf_desc with
-    | Ttag (label, attrs, b, list) ->
-        Ttag (label, attrs, b, List.map (sub.typ sub) list)
+    | Ttag (label, b, list) ->
+        Ttag (label, b, List.map (sub.typ sub) list)
     | Tinherit ct -> Tinherit (sub.typ sub ct)
   in
   { x with rf_desc; }
 
 let object_field sub x =
   let of_desc = match x.of_desc with
-    | OTtag (label, attrs, ct) ->
-        OTtag (label, attrs, (sub.typ sub ct))
+    | OTtag (label, ct) ->
+        OTtag (label, (sub.typ sub ct))
     | OTinherit ct -> OTinherit (sub.typ sub ct)
   in
   { x with of_desc; }

typing/typedtree.ml

@@ -389,19 +389,21 @@ and package_type = {
 and row_field = {
   rf_desc : row_field_desc;
   rf_loc : Location.t;
+  rf_attributes : attributes;
 }
 
 and row_field_desc =
-    Ttag of string loc * attributes * bool * core_type list
+    Ttag of string loc * bool * core_type list
   | Tinherit of core_type
 
 and object_field = {
   of_desc : object_field_desc;
   of_loc : Location.t;
+  of_attributes : attributes;
 }
 
 and object_field_desc =
-  | OTtag of string loc * attributes * core_type
+  | OTtag of string loc * core_type
   | OTinherit of core_type
 
 and value_description =