Make some locations more accurate (#8987)
Thomas Refis
GitHub
parent
5e15dd8eb5
commit
efac790249
3
Changes
3
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)
|
||||
|
||||
|
|
|
|||
12983
boot/menhir/parser.ml
12983
boot/menhir/parser.ml
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||
compatibility. TODO improve parser.mly *)
|
||||
mkexp ~loc (Pexp_ident (ghloc ~loc dotop))
|
||||
ghexp ~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 =
|
||||
mkpat ~loc (Ppat_var (loc_last lbl))
|
||||
let pat_of_label 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 ->
|
||||
mkmod ~loc:$sloc (Pmod_functor (arg, acc))
|
||||
List.fold_left (fun acc (startpos, arg) ->
|
||||
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
|
||||
{ Pmod_functor(arg, body) }
|
||||
| arg_and_pos = functor_arg body = module_binding_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 ->
|
||||
mkmty ~loc:$sloc (Pmty_functor (arg, acc))
|
||||
List.fold_left (fun acc (startpos, arg) ->
|
||||
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
|
||||
{ Pmty_functor(arg, body) }
|
||||
arg_and_pos = functor_arg body = module_declaration_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:$sloc (Pexp_construct($3, None))) }
|
||||
{ Pexp_open(od, mkexp ~loc:($loc($3)) (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:$sloc (Pexp_record(fields, exten))) }
|
||||
Pexp_open(od, mkexp ~loc:($startpos($3), $endpos)
|
||||
(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:$sloc (Pexp_array($4))) }
|
||||
{ Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (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:$sloc (Pexp_construct($3, None))) }
|
||||
{ Pexp_open(od, mkexp ~loc:$loc($3) (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 =
|
||||
mkexp_attrs ~loc:$sloc
|
||||
{ let modexp =
|
||||
mkexp_attrs ~loc:($startpos($3), $endpos)
|
||||
(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. *)
|
||||
pat_of_label ~loc:$sloc label
|
||||
(* No pattern; this is a pun. Desugar it.
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|}]
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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. *)
|
||||
;;
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|}];;
|
||||
|
|
|
|||
Loading…
Reference in New Issue