Make some locations more accurate (#8987)

Changes

@@ -393,6 +393,9 @@ Working version
 
 ### Internal/compiler-libs changes:
 
+- #8987: Make some locations more accurate
+  (Thomas Refis, review by Gabriel Scherer)
+
 - #9216: add Lambda.duplicate which refreshes bound identifiers
   (Gabriel Scherer, review by Pierre Chambart and Vincent Laviron)
 

parsing/parser.mly

@@ -211,7 +211,7 @@ let mkexp_opt_constraint ~loc e = function
 
 let mkpat_opt_constraint ~loc p = function
   | None -> p
-  | Some typ -> mkpat ~loc (Ppat_constraint(p, typ))
+  | Some typ -> ghpat ~loc (Ppat_constraint(p, typ))
 
 let syntax_error () =
   raise Syntaxerr.Escape_error
@@ -236,9 +236,7 @@ let bracket = "[", "]"
 let lident x =  Lident x
 let ldot x y = Ldot(x,y)
 let dotop_fun ~loc dotop =
-  (* We could use ghexp here, but sticking to mkexp for parser.mly
+  ghexp ~loc (Pexp_ident (ghloc ~loc dotop))
-     compatibility. TODO improve parser.mly *)
-  mkexp ~loc (Pexp_ident (ghloc ~loc dotop))
 
 let array_function ~loc str name =
   ghloc ~loc (Ldot(Lident str,
@@ -336,24 +334,27 @@ let lapply ~loc p1 p2 =
   else raise (Syntaxerr.Error(
                   Syntaxerr.Applicative_path (make_loc loc)))
 
-let exp_of_longident ~loc lid =
-  mkexp ~loc (Pexp_ident {lid with txt = Lident(Longident.last lid.txt)})
-
 (* [loc_map] could be [Location.map]. *)
 let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
   { x with txt = f x.txt }
 
+let make_ghost x = { x with loc = { x.loc with loc_ghost = true }}
+
 let loc_last (id : Longident.t Location.loc) : string Location.loc =
   loc_map Longident.last id
 
 let loc_lident (id : string Location.loc) : Longident.t Location.loc =
   loc_map (fun x -> Lident x) id
 
+let exp_of_longident ~loc lid =
+  let lid = make_ghost (loc_map (fun id -> Lident (Longident.last id)) lid) in
+  ghexp ~loc (Pexp_ident lid)
+
 let exp_of_label ~loc lbl =
   mkexp ~loc (Pexp_ident (loc_lident lbl))
 
-let pat_of_label ~loc lbl =
+let pat_of_label lbl =
-  mkpat ~loc (Ppat_var (loc_last lbl))
+  Pat.mk ~loc:lbl.loc  (Ppat_var (loc_last lbl))
 
 let mk_newtypes ~loc newtypes exp =
   let mkexp = mkexp ~loc in
@@ -1186,10 +1187,10 @@ parse_any_longident:
 functor_arg:
     (* An anonymous and untyped argument. *)
     LPAREN RPAREN
-      { Unit }
+      { $startpos, Unit }
   | (* An argument accompanied with an explicit type. *)
     LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
-      { Named (x, mty) }
+      { $startpos, Named (x, mty) }
 ;
 
 module_name:
@@ -1217,8 +1218,8 @@ module_expr:
       { unclosed "struct" $loc($1) "end" $loc($4) }
   | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
       { wrap_mod_attrs ~loc:$sloc attrs (
-          List.fold_left (fun acc arg ->
+          List.fold_left (fun acc (startpos, arg) ->
-            mkmod ~loc:$sloc (Pmod_functor (arg, acc))
+            mkmod ~loc:(startpos, $endpos) (Pmod_functor (arg, acc))
           ) me args
         ) }
   | me = paren_module_expr
@@ -1377,8 +1378,9 @@ module_binding_body:
   | mkmod(
       COLON mty = module_type EQUAL me = module_expr
         { Pmod_constraint(me, mty) }
-    | arg = functor_arg body = module_binding_body
+    | arg_and_pos = functor_arg body = module_binding_body
-        { Pmod_functor(arg, body) }
+        { let (_, arg) = arg_and_pos in
+          Pmod_functor(arg, body) }
   ) { $1 }
 ;
 
@@ -1511,8 +1513,8 @@ module_type:
     MINUSGREATER mty = module_type
       %prec below_WITH
       { wrap_mty_attrs ~loc:$sloc attrs (
-          List.fold_left (fun acc arg ->
+          List.fold_left (fun acc (startpos, arg) ->
-            mkmty ~loc:$sloc (Pmty_functor (arg, acc))
+            mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc))
           ) mty args
         ) }
   | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
@@ -1618,8 +1620,9 @@ module_declaration_body:
     COLON mty = module_type
       { mty }
   | mkmty(
-      arg = functor_arg body = module_declaration_body
+      arg_and_pos = functor_arg body = module_declaration_body
-        { Pmty_functor(arg, body) }
+        { let (_, arg) = arg_and_pos in
+          Pmty_functor(arg, body) }
     )
     { $1 }
 ;
@@ -1768,7 +1771,7 @@ class_expr:
   | let_bindings(no_ext) IN class_expr
       { class_of_let_bindings ~loc:$sloc $1 $3 }
   | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr
-      { let loc = ($startpos($2), $endpos($4)) in
+      { let loc = ($startpos($2), $endpos($5)) in
         let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
         mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) }
   | class_expr attribute
@@ -1922,7 +1925,7 @@ class_signature:
   | class_signature attribute
       { Cty.attr $1 $2 }
   | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature
-      { let loc = ($startpos($2), $endpos($4)) in
+      { let loc = ($startpos($2), $endpos($5)) in
         let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
         mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) }
 ;
@@ -2341,8 +2344,7 @@ simple_expr:
   | extension
       { Pexp_extension $1 }
   | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"})
-      { (* TODO: review the location of Pexp_construct *)
+      { Pexp_open(od, mkexp ~loc:($loc($3)) (Pexp_construct($3, None))) }
-        Pexp_open(od, mkexp ~loc:$sloc (Pexp_construct($3, None))) }
   | mod_longident DOT LPAREN seq_expr error
       { unclosed "(" $loc($3) ")" $loc($5) }
   | LBRACE record_expr_content RBRACE
@@ -2352,8 +2354,8 @@ simple_expr:
       { unclosed "{" $loc($1) "}" $loc($3) }
   | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE
       { let (exten, fields) = $4 in
-        (* TODO: review the location of Pexp_construct *)
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos)
-        Pexp_open(od, mkexp ~loc:$sloc (Pexp_record(fields, exten))) }
+                        (Pexp_record(fields, exten))) }
   | mod_longident DOT LBRACE record_expr_content error
       { unclosed "{" $loc($3) "}" $loc($5) }
   | LBRACKETBAR expr_semi_list BARRBRACKET
@@ -2363,11 +2365,10 @@ simple_expr:
   | LBRACKETBAR BARRBRACKET
       { Pexp_array [] }
   | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET
-      { (* TODO: review the location of Pexp_array *)
+      { Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array($4))) }
-        Pexp_open(od, mkexp ~loc:$sloc (Pexp_array($4))) }
   | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET
       { (* TODO: review the location of Pexp_array *)
-        Pexp_open(od, mkexp ~loc:$sloc (Pexp_array [])) }
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array [])) }
   | mod_longident DOT
     LBRACKETBAR expr_semi_list error
       { unclosed "[|" $loc($3) "|]" $loc($5) }
@@ -2379,19 +2380,17 @@ simple_expr:
       { let list_exp =
           (* TODO: review the location of list_exp *)
           let tail_exp, _tail_loc = mktailexp $loc($5) $4 in
-          mkexp ~loc:$sloc tail_exp in
+          mkexp ~loc:($startpos($3), $endpos) tail_exp in
         Pexp_open(od, list_exp) }
   | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
-      { (* TODO: review the location of Pexp_construct *)
+      { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) }
-        Pexp_open(od, mkexp ~loc:$sloc (Pexp_construct($3, None))) }
   | mod_longident DOT
     LBRACKET expr_semi_list error
       { unclosed "[" $loc($3) "]" $loc($5) }
   | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
     package_type RPAREN
-      { (* TODO: review the location of Pexp_constraint *)
+      { let modexp =
-        let modexp =
+          mkexp_attrs ~loc:($startpos($3), $endpos)
-          mkexp_attrs ~loc:$sloc
             (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
         Pexp_open(od, modexp) }
   | mod_longident DOT
@@ -2680,7 +2679,7 @@ simple_pattern_not_ident:
       { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
   | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
       { mkpat_attrs ~loc:$sloc
-          (Ppat_constraint(mkpat ~loc:$sloc (Ppat_unpack $4), $6))
+          (Ppat_constraint(mkpat ~loc:$loc($4) (Ppat_unpack $4), $6))
           $3 }
   | mkpat(simple_pattern_not_ident_)
       { $1 }
@@ -2765,13 +2764,16 @@ pattern_comma_list(self):
   label = mkrhs(label_longident)
   octy = preceded(COLON, core_type)?
   opat = preceded(EQUAL, pattern)?
-    { let pat =
+    { let label, pat =
         match opat with
         | None ->
-            (* No pattern; this is a pun. Desugar it. *)
+            (* No pattern; this is a pun. Desugar it.
-            pat_of_label ~loc:$sloc label
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
         | Some pat ->
-            pat
+            label, pat
       in
       label, mkpat_opt_constraint ~loc:$sloc pat octy
     }
@@ -3022,7 +3024,7 @@ sig_exception_declaration:
   attrs2 = attributes
   attrs = post_item_attributes
     { let args, res = args_res in
-      let loc = make_loc $sloc in
+      let loc = make_loc ($startpos, $endpos(attrs2)) in
       let docs = symbol_docs $sloc in
       Te.mk_exception ~attrs
         (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)

testsuite/tests/generalized-open/gpr1506.ml

@@ -384,9 +384,9 @@ val print_list_of_int : Print_int.t list -> unit = <fun>
 let f () = let open functor(X: sig end) -> struct end in ();;
 
 [%%expect{|
-Line 1, characters 20-53:
+Line 1, characters 27-53:
 1 | let f () = let open functor(X: sig end) -> struct end in ();;
-                        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+                               ^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This module is not a structure; it has type
        functor (X : sig end) -> sig end
 |}]

testsuite/tests/parsetree/locations_test.ml

@@ -0,0 +1,112 @@
+(* TEST
+   flags = "-dparsetree"
+   * toplevel *)
+
+(* Using a toplevel test and not an expect test, because the locs get shifted
+   by the expect blocks and the output is therefore not stable. *)
+
+(* Attributes *)
+
+module type S = sig end [@attr payload];;
+
+
+module M = struct end [@attr payload];;
+
+type t = int [@attr payload];;
+
+3 [@attr payload];;
+
+exception Exn [@@attr payload];;
+
+(* Functors *)
+
+module type F = functor (A : S) (B : S) -> sig end;;
+
+module F = functor (A : S) (B : S) -> struct end;;
+
+(* with type *)
+
+module type S1 = sig type t end;;
+
+module type T1 = S1 with type t = int;;
+
+module type T1 = S1 with type t := int;;
+
+(* Constrained bindings *)
+
+let x : int = 3;;
+
+let x : type a. a -> a = fun x -> x;;
+
+let _ = object
+  method x : type a. a -> a =
+    fun x -> x
+end;;
+
+(* Punning. *)
+
+let x contents = { contents };;
+
+let x = { contents : int = 3 };;
+
+let x contents = { contents : int };;
+
+let x = function { contents } -> contents;;
+
+let x = function { contents : int } -> contents;;
+
+let x = function { contents : int = i } -> i;;
+
+(* Local open *)
+
+let x = M.{ contents = 3 };;
+
+let x = M.[ 3; 4 ];;
+
+let x = M.( 3; 4 );;
+
+(* Indexing operators *)
+
+  (* some prerequisites. *)
+
+let ( .@() ) x y = x + y
+let ( .@()<- ) x y z = x + y + z
+let ( .%.{} ) x y = x + y
+let ( .%.{}<- ) x y z = x + y + z
+let ( .%.[] ) x y = x + y
+let ( .%.[]<- ) x y z = x + y + z;;
+
+  (* the actual issue *)
+
+x.@(4);;
+x.@(4) <- 4;;
+
+x.%.{4};;
+x.%.{4} <- 4;;
+
+x.%.[4];;
+x.%.[4] <- 4;;
+
+(* Constrained unpacks *)
+
+let f = function (module M : S) -> ();;
+
+(* local opens in class and class types *)
+
+class c =
+  let open M in
+  object end
+;;
+
+class type ct =
+  let open M in
+  object end
+;;
+
+(* Docstrings *)
+
+(** Some docstring attached to x. *)
+let x =
+  42
+(** Another docstring attached to x. *)
+;;

testsuite/tests/parsing/attributes.compilers.reference

@@ -5,7 +5,7 @@
       attribute "foo"
         []
       ptyext_constructor =
-        extension_constructor (attributes.ml[8,120+0]..[8,120+28])
+        extension_constructor (attributes.ml[8,120+0]..[8,120+20])
           attribute "foo"
             []
           pext_name = "Foo"
@@ -19,7 +19,7 @@
       attribute "foo"
         []
       ptyext_constructor =
-        extension_constructor (attributes.ml[10,150+0]..[10,150+44])
+        extension_constructor (attributes.ml[10,150+0]..[10,150+36])
           attribute "foo"
             []
           pext_name = "Bar"
@@ -150,7 +150,7 @@
               attribute "foo"
                 []
               ptyext_constructor =
-                extension_constructor (attributes.ml[37,450+2]..[37,450+46])
+                extension_constructor (attributes.ml[37,450+2]..[37,450+38])
                   attribute "foo"
                     []
                   pext_name = "Bar"

testsuite/tests/parsing/extensions.compilers.reference

@@ -234,7 +234,7 @@
           pattern (extensions.ml[20,445+54]..[20,445+59])
             Ppat_record Closed
             [
-              "x" (extensions.ml[20,445+56]..[20,445+57])
+              "x" (extensions.ml[20,445+56]..[20,445+57]) ghost
                 pattern (extensions.ml[20,445+56]..[20,445+57])
                   Ppat_var "x" (extensions.ml[20,445+56]..[20,445+57])
             ]

testsuite/tests/parsing/shortcut_ext_attr.compilers.reference

@@ -510,7 +510,7 @@
   structure_item (shortcut_ext_attr.ml[64,1353+0]..[67,1409+22])
     Pstr_module
     "M" (shortcut_ext_attr.ml[64,1353+7]..[64,1353+8])
-      module_expr (shortcut_ext_attr.ml[65,1364+2]..[67,1409+22])
+      module_expr (shortcut_ext_attr.ml[65,1364+16]..[67,1409+22])
         attribute "foo"
           []
         Pmod_functor "M" (shortcut_ext_attr.ml[65,1364+17]..[65,1364+18])
@@ -531,7 +531,7 @@
             []
   structure_item (shortcut_ext_attr.ml[70,1462+0]..[73,1535+19])
     Pstr_modtype "S" (shortcut_ext_attr.ml[70,1462+12]..[70,1462+13])
-      module_type (shortcut_ext_attr.ml[71,1478+2]..[73,1535+19])
+      module_type (shortcut_ext_attr.ml[71,1478+16]..[73,1535+19])
         attribute "foo"
           []
         Pmty_functor "M" (shortcut_ext_attr.ml[71,1478+17]..[71,1478+18])

testsuite/tests/typing-implicit_unpack/implicit_unpack.ml

@@ -50,9 +50,9 @@ val f : (module S with type t = int) -> int = <fun>
 
 let f (module M : S with type t = 'a) = M.x;; (* Error *)
 [%%expect{|
-Line 1, characters 6-37:
+Line 1, characters 14-15:
 1 | let f (module M : S with type t = 'a) = M.x;; (* Error *)
-          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+                  ^
 Error: The type of this packed module contains variables:
        (module S with type t = 'a)
 |}];;