Parsetree, typedtree: add locations to all nodes carrying attributes

Changes

@@ -288,6 +288,9 @@ Working version
   (Gabriel Radanne, help from Gabriel Scherer and Valentin Gatien-Baron,
    review by Mark Shinwell and Gabriel Radanne)
 
+- GPR#1903: parsetree, add locations to all nodes with attributes
+  (Gabriel Scherer, review by Thomas Refis)
+
 - GPR#1938: always check ast invariants after preprocessing
   (Florian Angeletti, review by Alain Frisch and Gabriel Scherer)
 

ocamldoc/odoc_sig.ml

@@ -288,17 +288,18 @@ module Analyser =
         | Some core_ty ->
           begin match core_ty.ptyp_desc with
           | Ptyp_object (fields, _) ->
+            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
@@ -307,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

@@ -19,9 +19,11 @@ open Asttypes
 open Parsetree
 open Docstrings
 
-type lid = Longident.t loc
-type str = string loc
+type 'a with_loc = 'a Location.loc
 type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
 type attrs = attribute list
 
 let default_loc = ref Location.none
@@ -110,18 +112,22 @@ module Typ = struct
             Ptyp_extension (s, arg)
       in
       {t with ptyp_desc = desc}
-    and loop_row_field  =
-      function
-        | Rtag(label,attrs,flag,lst) ->
-            Rtag(label,attrs,flag,List.map loop lst)
+    and loop_row_field field =
+      let prf_desc = match field.prf_desc with
+        | Rtag(label,flag,lst) ->
+            Rtag(label,flag,List.map loop lst)
         | Rinherit t ->
             Rinherit (loop t)
-    and loop_object_field =
-      function
-        | Otag(label, attrs, t) ->
-            Otag(label, attrs, loop t)
+      in
+      { field with prf_desc; }
+    and loop_object_field field =
+      let pof_desc = match field.pof_desc with
+        | Otag(label, t) ->
+            Otag(label, loop t)
         | Oinherit t ->
             Oinherit (loop t)
+      in
+      { field with pof_desc; }
     in
     loop t
 
@@ -509,19 +515,22 @@ end
 
 (** Type extensions *)
 module Te = struct
-  let mk ?(attrs = []) ?(docs = empty_docs)
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
         ?(params = []) ?(priv = Public) path constructors =
     {
      ptyext_path = path;
      ptyext_params = params;
      ptyext_constructors = constructors;
      ptyext_private = priv;
+     ptyext_loc = loc;
      ptyext_attributes = add_docs_attrs docs attrs;
     }
 
-  let mk_exception ?(attrs = []) ?(docs = empty_docs) constructor =
+  let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+      constructor =
     {
      ptyexn_constructor = constructor;
+     ptyexn_loc = loc;
      ptyexn_attributes = add_docs_attrs docs attrs;
     }
 
@@ -569,3 +578,29 @@ module Cstr = struct
      pcstr_fields = fields;
     }
 end
+
+(** Row fields *)
+module Rf = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) desc = {
+    prf_desc = desc;
+    prf_loc = loc;
+    prf_attributes = attrs;
+  }
+  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) ?(attrs=[]) desc = {
+    pof_desc = desc;
+    pof_loc = loc;
+    pof_attributes = attrs;
+  }
+  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

@@ -19,9 +19,11 @@ open Asttypes
 open Docstrings
 open Parsetree
 
-type lid = Longident.t loc
-type str = string loc
+type 'a with_loc = 'a Location.loc
 type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
 type attrs = attribute list
 
 (** {1 Default locations} *)
@@ -207,11 +209,11 @@ module Type:
 (** Type extensions *)
 module Te:
   sig
-    val mk: ?attrs:attrs -> ?docs:docs ->
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
       ?params:(core_type * variance) list -> ?priv:private_flag ->
       lid -> extension_constructor list -> type_extension
 
-    val mk_exception: ?attrs:attrs -> ?docs:docs ->
+    val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
       extension_constructor -> type_exception
 
     val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
@@ -448,3 +450,22 @@ module Cstr:
   sig
     val mk: pattern -> class_field list -> class_structure
   end
+
+(** Row fields *)
+module Rf:
+  sig
+    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
+  end
+
+(** Object fields *)
+module Of:
+  sig
+    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
+  end

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

@@ -59,6 +59,8 @@ type iterator = {
   structure: iterator -> structure -> unit;
   structure_item: iterator -> structure_item -> unit;
   typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
   type_declaration: iterator -> type_declaration -> unit;
   type_extension: iterator -> type_extension -> unit;
   type_exception: iterator -> type_exception -> unit;
@@ -83,14 +85,26 @@ let iter_loc sub {loc; txt = _} = sub.location sub loc
 module T = struct
   (* Type expressions for the core language *)
 
-  let row_field sub = function
-    | Rtag (_, attrs, _, tl) ->
-        sub.attributes sub attrs; List.iter (sub.typ sub) tl
+  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 (_, _, tl) -> List.iter (sub.typ sub) tl
     | Rinherit t -> sub.typ sub t
 
-  let object_field sub = function
-    | Otag (_, attrs, t) ->
-        sub.attributes sub attrs; 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 (_, t) -> sub.typ sub t
     | Oinherit t -> sub.typ sub t
 
   let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
@@ -150,14 +164,18 @@ module T = struct
       {ptyext_path; ptyext_params;
        ptyext_constructors;
        ptyext_private = _;
+       ptyext_loc;
        ptyext_attributes} =
     iter_loc sub ptyext_path;
     List.iter (sub.extension_constructor sub) ptyext_constructors;
     List.iter (iter_fst (sub.typ sub)) ptyext_params;
+    sub.location sub ptyext_loc;
     sub.attributes sub ptyext_attributes
 
-  let iter_type_exception sub {ptyexn_constructor; ptyexn_attributes} =
+  let iter_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
     sub.extension_constructor sub ptyexn_constructor;
+    sub.location sub ptyexn_loc;
     sub.attributes sub ptyexn_attributes
 
   let iter_extension_constructor_kind sub = function
@@ -259,7 +277,8 @@ module MT = struct
     | Psig_class_type l ->
         List.iter (sub.class_type_declaration sub) l
     | Psig_extension (x, attrs) ->
-        sub.extension sub x; sub.attributes sub attrs
+        sub.attributes sub attrs;
+        sub.extension sub x
     | Psig_attribute x -> sub.attribute sub x
 end
 
@@ -288,7 +307,7 @@ module M = struct
     sub.location sub loc;
     match desc with
     | Pstr_eval (x, attrs) ->
-        sub.expr sub x; sub.attributes sub attrs
+        sub.attributes sub attrs; sub.expr sub x
     | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
     | Pstr_primitive vd -> sub.value_description sub vd
     | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
@@ -303,7 +322,7 @@ module M = struct
         List.iter (sub.class_type_declaration sub) l
     | Pstr_include x -> sub.include_declaration sub x
     | Pstr_extension (x, attrs) ->
-        sub.extension sub x; sub.attributes sub attrs
+        sub.attributes sub attrs; sub.extension sub x
     | Pstr_attribute x -> sub.attribute sub x
 end
 
@@ -501,6 +520,8 @@ let default_iterator =
     type_declaration = T.iter_type_declaration;
     type_kind = T.iter_type_kind;
     typ = T.iter;
+    row_field = T.row_field;
+    object_field = T.object_field;
     type_extension = T.iter_type_extension;
     type_exception = T.iter_type_exception;
     extension_constructor = T.iter_extension_constructor;
@@ -509,8 +530,8 @@ let default_iterator =
                  pval_attributes} ->
         iter_loc this pval_name;
         this.typ this pval_type;
+        this.location this pval_loc;
         this.attributes this pval_attributes;
-        this.location this pval_loc
       );
 
     pat = P.iter;
@@ -520,23 +541,23 @@ let default_iterator =
       (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
          iter_loc this pmd_name;
          this.module_type this pmd_type;
+         this.location this pmd_loc;
          this.attributes this pmd_attributes;
-         this.location this pmd_loc
       );
 
     module_type_declaration =
       (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
          iter_loc this pmtd_name;
          iter_opt (this.module_type this) pmtd_type;
+         this.location this pmtd_loc;
          this.attributes this pmtd_attributes;
-         this.location this pmtd_loc
       );
 
     module_binding =
       (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
          iter_loc this pmb_name; this.module_expr this pmb_expr;
+         this.location this pmb_loc;
          this.attributes this pmb_attributes;
-         this.location this pmb_loc
       );
 
 

parsing/ast_iterator.mli

@@ -56,6 +56,8 @@ type iterator = {
   structure: iterator -> structure -> unit;
   structure_item: iterator -> structure_item -> unit;
   typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
   type_declaration: iterator -> type_declaration -> unit;
   type_extension: iterator -> type_extension -> unit;
   type_exception: iterator -> type_exception -> unit;