parsetree: make sure that all nodes that store attributes also store …

…a location

Florian Angeletti and myself ran into a problem when trying to use attributes
for ellision of parts of manual example. We wanted to be turn any ast-node
marked with the [@ellipsis] attribute into "..." in the rendering of the
corresponding code block, but for this we need the location of the
attributed node, and it turns out that some constructions supported
attributes without carrying a location:
- Rtag in row_field
- Otag in object_field
- type_exception record
- type_extension record

We added locations in all those positions, guaranteeing the invariant
that all nodes to which attributes can be attached have a precise
position.

Changes

@@ -188,6 +188,9 @@ Working version
 - GPR#1886: move the Location.absname reference to Clflags.absname
   (Armaël Guéneau, review by Jérémie Dimino)
 
+- GPR#1903: parsetree, add locations to all nodes with attributes
+  (Gabriel Scherer, review by Thomas Refis)
+
 ### Bug fixes:
 
 - MPR#7726, GPR#1676: Recursive modules, equi-recursive types and stack overflow

ocamldoc/odoc_sig.ml

@@ -288,6 +288,7 @@ module Analyser =
         | Some core_ty ->
           begin match core_ty.ptyp_desc with
           | Ptyp_object (fields, _) ->
+            let fields = List.map (fun {txt; loc=_} -> txt) fields in
             let rec f = function
               | [] -> []
               | Otag ({txt=""},_,_) :: _ ->

parsing/ast_helper.ml

@@ -21,6 +21,8 @@ open Docstrings
 
 type lid = Longident.t loc
 type str = string loc
+type ofield = object_field loc
+type rfield = row_field loc
 type loc = Location.t
 type attrs = attribute list
 
@@ -71,6 +73,7 @@ module Typ = struct
       if List.mem v vl then
         raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in
     let var_names = List.map (fun v -> v.txt) var_names in
+    let map_loc f {txt; loc} = {txt = f txt; loc} in
     let rec loop t =
       let desc =
         match t.ptyp_desc with
@@ -87,14 +90,14 @@ module Typ = struct
         | Ptyp_constr(longident, lst) ->
             Ptyp_constr(longident, List.map loop lst)
         | Ptyp_object (lst, o) ->
-            Ptyp_object (List.map loop_object_field lst, o)
+            Ptyp_object (List.map (map_loc loop_object_field) lst, o)
         | Ptyp_class (longident, lst) ->
             Ptyp_class (longident, List.map loop lst)
         | Ptyp_alias(core_type, string) ->
             check_variable var_names t.ptyp_loc string;
             Ptyp_alias(loop core_type, string)
         | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
-            Ptyp_variant(List.map loop_row_field row_field_list,
+            Ptyp_variant(List.map (map_loc loop_row_field) row_field_list,
                          flag, lbl_lst_option)
         | Ptyp_poly(string_lst, core_type) ->
           List.iter (fun v ->
@@ -106,7 +109,7 @@ module Typ = struct
             Ptyp_extension (s, arg)
       in
       {t with ptyp_desc = desc}
-    and loop_row_field  =
+    and loop_row_field =
       function
         | Rtag(label,attrs,flag,lst) ->
             Rtag(label,attrs,flag,List.map loop lst)
@@ -505,19 +508,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;
     }
 

parsing/ast_helper.mli

@@ -21,6 +21,8 @@ open Parsetree
 
 type lid = Longident.t loc
 type str = string loc
+type ofield = object_field loc
+type rfield = row_field loc
 type loc = Location.t
 type attrs = attribute list
 
@@ -60,11 +62,11 @@ module Typ :
                -> core_type
     val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
     val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
-    val object_: ?loc:loc -> ?attrs:attrs -> object_field list
+    val object_: ?loc:loc -> ?attrs:attrs -> ofield list
                    -> closed_flag -> core_type
     val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
     val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
-    val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
+    val variant: ?loc:loc -> ?attrs:attrs -> rfield list -> closed_flag
                  -> label list option -> core_type
     val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
     val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
@@ -202,11 +204,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 ->

parsing/ast_iterator.ml

@@ -79,6 +79,9 @@ let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
 let iter_opt f = function None -> () | Some x -> f x
 
 let iter_loc sub {loc; txt = _} = sub.location sub loc
+let under_loc f sub {loc; txt} =
+  sub.location sub loc;
+  f sub txt
 
 module T = struct
   (* Type expressions for the core language *)
@@ -105,12 +108,12 @@ module T = struct
     | Ptyp_constr (lid, tl) ->
         iter_loc sub lid; List.iter (sub.typ sub) tl
     | Ptyp_object (ol, _o) ->
-        List.iter (object_field sub) ol
+        List.iter (under_loc object_field sub) ol
     | Ptyp_class (lid, tl) ->
         iter_loc sub lid; List.iter (sub.typ sub) tl
     | Ptyp_alias (t, _) -> sub.typ sub t
     | Ptyp_variant (rl, _b, _ll) ->
-        List.iter (row_field sub) rl
+        List.iter (under_loc row_field sub) rl
     | Ptyp_poly (_, t) -> sub.typ sub t
     | Ptyp_package (lid, l) ->
         iter_loc sub lid;

parsing/ast_mapper.ml

@@ -80,6 +80,10 @@ let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 let map_opt f = function None -> None | Some x -> Some (f x)
 
 let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+let under_loc f sub {loc; txt} =
+  let loc = sub.location sub loc in
+  let txt = f sub txt in
+  {loc; txt}
 
 module T = struct
   (* Type expressions for the core language *)
@@ -108,12 +112,12 @@ module T = struct
     | Ptyp_constr (lid, tl) ->
         constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_object (l, o) ->
-        object_ ~loc ~attrs (List.map (object_field sub) l) o
+        object_ ~loc ~attrs (List.map (under_loc object_field sub) l) o
     | Ptyp_class (lid, tl) ->
         class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
     | Ptyp_variant (rl, b, ll) ->
-        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+        variant ~loc ~attrs (List.map (under_loc row_field sub) rl) b ll
     | Ptyp_poly (sl, t) -> poly ~loc ~attrs
                              (List.map (map_loc sub) sl) (sub.typ sub t)
     | Ptyp_package (lid, l) ->

parsing/depend.ml

@@ -106,13 +106,15 @@ let rec add_type bv ty =
   | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
   | Ptyp_object (fl, _) ->
       List.iter
-       (function Otag (_, _, t) -> add_type bv t
+       (fun {txt; loc = _} -> match txt with
+         | 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
-        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
+        (fun {txt; loc = _} -> match txt with
+          | Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
           | Rinherit sty -> add_type bv sty)
         fl
   | Ptyp_poly(_, t) -> add_type bv t

parsing/parser.mly

@@ -2323,15 +2323,19 @@ row_field_list:
   | row_field_list BAR row_field                { $3 :: $1 }
 ;
 row_field:
-    tag_field                                   { $1 }
-  | simple_core_type                            { Rinherit $1 }
+    tag_field                          { $1 }
+  | simple_core_type                   { mkloc (Rinherit $1) (symbol_rloc ()) }
 ;
 tag_field:
     name_tag OF opt_ampersand amper_type_list attributes
-      { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $5,
-               $3, List.rev $4) }
+      { let attrs = add_info_attrs (symbol_info ()) $5 in
+        mkloc
+          (Rtag (mkrhs $1 1, attrs, $3, List.rev $4))
+          (symbol_rloc ()) }
   | name_tag attributes
-      { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $2, true, []) }
+      { mkloc
+          (Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $2, true, []))
+          (symbol_rloc ()) }
 ;
 opt_ampersand:
     AMPERSAND                                   { true }
@@ -2351,27 +2355,29 @@ simple_core_type_or_tuple:
       { mktyp(Ptyp_tuple($1 :: List.rev $3)) }
 ;
 core_type_comma_list:
-    core_type                                   { [$1] }
-  | core_type_comma_list COMMA core_type        { $3 :: $1 }
+    core_type                              { [$1] }
+  | core_type_comma_list COMMA core_type   { $3 :: $1 }
 ;
 core_type_list:
-    simple_core_type                            { [$1] }
-  | core_type_list STAR simple_core_type        { $3 :: $1 }
+    simple_core_type                       { [$1] }
+  | core_type_list STAR simple_core_type   { $3 :: $1 }
 ;
 meth_list:
     field_semi meth_list
       { let (f, c) = $2 in ($1 :: f, c) }
   | inherit_field_semi meth_list
       { let (f, c) = $2 in ($1 :: f, c) }
-  | field_semi                                  { [$1], Closed }
-  | field                                       { [$1], Closed }
-  | inherit_field_semi                          { [$1], Closed }
-  | simple_core_type                            { [Oinherit $1], Closed }
-  | DOTDOT                                      { [], Open }
+  | field_semi                             { [$1], Closed }
+  | field                                  { [$1], Closed }
+  | inherit_field_semi                     { [$1], Closed }
+  | simple_core_type                       { [mkrhs (Oinherit $1) 1], Closed }
+  | DOTDOT                                 { [], Open }
 ;
 field:
   label COLON poly_type_no_attr attributes
-    { Otag (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3) }
+    { mkloc
+        (Otag (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3))
+        (symbol_rloc ()) }
 ;
 
 field_semi:
@@ -2381,11 +2387,13 @@ field_semi:
         | Some _ as info_before_semi -> info_before_semi
         | None -> symbol_info ()
       in
-      ( Otag (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3)) }
+      mkloc
+        (Otag (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3))
+        (symbol_rloc ()) }
 ;
 
 inherit_field_semi:
-  simple_core_type SEMI { Oinherit $1 }
+  simple_core_type SEMI { mkloc (Oinherit $1) (symbol_rloc ()) }
 
 label:
     LIDENT                                      { $1 }

parsing/parsetree.mli

@@ -93,7 +93,7 @@ and core_type_desc =
            T tconstr
            (T1, ..., Tn) tconstr
          *)
-  | Ptyp_object of object_field list * closed_flag
+  | Ptyp_object of object_field loc list * closed_flag
         (* < l1:T1; ...; ln:Tn >     (flag = Closed)
            < l1:T1; ...; ln:Tn; .. > (flag = Open)
          *)
@@ -104,7 +104,7 @@ and core_type_desc =
          *)
   | Ptyp_alias of core_type * string
         (* T as 'a *)
-  | Ptyp_variant of row_field list * closed_flag * label list option
+  | Ptyp_variant of row_field loc list * closed_flag * label list option
         (* [ `A|`B ]         (flag = Closed; labels = None)
            [> `A|`B ]        (flag = Open;   labels = None)
            [< `A|`B ]        (flag = Closed; labels = Some [])
@@ -148,12 +148,12 @@ and row_field =
            [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
            [`A of & T1 & .. & Tn] ( true,  [T1;...Tn] )
 
-          - The 2nd field is true if the tag contains a
+          - The 3rd field is true if the tag contains a
             constant (empty) constructor.
           - '&' occurs when several types are used for the same constructor
             (see 4.2 in the manual)
 
-          - TODO: switch to a record representation, and keep location
+          - TODO: switch to a record representation
         *)
   | Rinherit of core_type
         (* [ T ] *)
@@ -454,6 +454,7 @@ and type_extension =
      ptyext_params: (core_type * variance) list;
      ptyext_constructors: extension_constructor list;
      ptyext_private: private_flag;
+     ptyext_loc: Location.t;
      ptyext_attributes: attributes;   (* ... [@@id1] [@@id2] *)
     }
 (*
@@ -472,6 +473,7 @@ and extension_constructor =
 and type_exception =
   {
     ptyexn_constructor: extension_constructor;
+    ptyexn_loc: Location.t;
     ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *)
   }
 

parsing/pprintast.ml

@@ -226,6 +226,8 @@ let private_flag f = function
   | Public -> ()
   | Private -> pp f "private@ "
 
+let iter_loc f ctxt {txt; loc = _} = f ctxt txt
+
 let constant_string f s = pp f "%S" s
 let tyvar f str = pp f "'%s" str
 let tyvar_loc f str = pp f "'%s" str.txt
@@ -287,7 +289,7 @@ and core_type1 ctxt f x =
         let type_variant_helper f x =
           match x with
           | Rtag (l, attrs, _, ctl) ->
-              pp f "@[<2>%a%a@;%a@]" string_quot l.txt
+              pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
                 (fun f l -> match l with
                    |[] -> ()
                    | _ -> pp f "@;of@;%a"
@@ -305,7 +307,7 @@ and core_type1 ctxt f x =
                     | (Closed,None) -> ""
                     | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
                     | (Open,_) -> ">")
-                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+                   (list (iter_loc type_variant_helper) ~sep:"@;<1 -2>| ") l) l
           (fun f low -> match low with
              |Some [] |None -> ()
              |Some xs ->
@@ -326,7 +328,8 @@ and core_type1 ctxt f x =
               | [] -> pp f ".."
               | _ -> pp f " ;.."
         in
-        pp f "@[<hov2><@ %a%a@ > @]" (list core_field_type ~sep:";") l
+        pp f "@[<hov2><@ %a%a@ > @]"
+          (list (iter_loc core_field_type) ~sep:";") l
           field_var o (* Cf #7200 *)
     | Ptyp_class (li, l) ->   (*FIXME*)
         pp f "@[<hov2>%a#%a@]"

parsing/printast.ml

@@ -163,8 +163,8 @@ let rec core_type i ppf x =
   | Ptyp_object (l, c) ->
       line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
       let i = i + 1 in
-      List.iter (
-        function
+      List.iter (fun {txt; loc = _} ->
+        match txt with
           | Otag (l, attrs, t) ->
             line i ppf "method %s\n" l.txt;
             attributes i ppf attrs;
@@ -895,7 +895,7 @@ and label_x_expression i ppf (l,e) =
   expression (i+1) ppf e;
 
 and label_x_bool_x_core_type_list i ppf x =
-  match x with
+  match x.txt with
     Rtag (l, attrs, b, ctl) ->
       line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
       attributes (i+1) ppf attrs;

typing/printtyped.ml

@@ -188,7 +188,7 @@ 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 (function
+      List.iter (fun {txt; loc = _} -> match txt with
         | OTtag (s, attrs, t) ->
             line i ppf "method %s\n" s.txt;
             attributes i ppf attrs;
@@ -882,7 +882,7 @@ and ident_x_expression_def i ppf (l, e) =
   expression (i+1) ppf e;
 
 and label_x_bool_x_core_type_list i ppf x =
-  match x with
+  match x.txt with
     Ttag (l, attrs, b, ctl) ->
       line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
       attributes (i+1) ppf attrs;