diff options
| -rw-r--r-- | Changes | 1 | ||||
| -rw-r--r-- | otherlibs/labltk/browser/searchpos.ml | 8 | ||||
| -rw-r--r-- | otherlibs/labltk/browser/typecheck.ml | 7 | ||||
| -rw-r--r-- | parsing/parser.mly | 16 | ||||
| -rw-r--r-- | parsing/syntaxerr.ml | 14 | ||||
| -rw-r--r-- | parsing/syntaxerr.mli | 3 |
6 files changed, 36 insertions, 13 deletions
@@ -29,6 +29,7 @@ Bug fixes: - PR#5763: ocamlbuild does not give correct flags when running menhir - PR#5784: -dclambda option is ignored - PR#5787: Bad behavior of 'Unused ...' warnings in the toplevel +- PR#5770: Syntax error messages involving unclosed parens are sometimes incorrect Internals: - Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index cf79d940d..7998c4bd6 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -394,13 +394,7 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = let pt = try Parse.interface (Lexing.from_string text) with Syntaxerr.Error e -> - let l = - match e with - Syntaxerr.Unclosed(l,_,_,_) -> l - | Syntaxerr.Applicative_path l -> l - | Syntaxerr.Variable_in_scope(l,_) -> l - | Syntaxerr.Other l -> l - in + let l = Syntaxerr.location_of_error e in Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum) ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; [] | Lexer.Error (_, l) -> diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index f557105f1..9859965d8 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/otherlibs/labltk/browser/typecheck.ml @@ -137,12 +137,7 @@ let f txt = Lexer.report_error Format.std_formatter err; l | Syntaxerr.Error err -> Syntaxerr.report_error Format.std_formatter err; - begin match err with - Syntaxerr.Unclosed(l,_,_,_) -> l - | Syntaxerr.Applicative_path l -> l - | Syntaxerr.Variable_in_scope(l,_) -> l - | Syntaxerr.Other l -> l - end + Syntaxerr.location_of_error err | Typecore.Error (l,err) -> Typecore.report_error Format.std_formatter err; l | Typeclass.Error (l,err) -> diff --git a/parsing/parser.mly b/parsing/parser.mly index 6dc5f10b1..c95e4bc3c 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -175,6 +175,9 @@ let unclosed opening_name opening_num closing_name closing_num = raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name, rhs_loc closing_num, closing_name))) +let expecting pos nonterm = + raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm))) + let bigarray_function str name = mkloc (Ldot(Ldot(Lident "Bigarray", str), name)) Location.none @@ -1248,6 +1251,8 @@ pattern: { $1 } | pattern AS val_ident { mkpat(Ppat_alias($1, mkrhs $3 3)) } + | pattern AS error + { expecting 3 "identifier" } | pattern_comma_list %prec below_COMMA { mkpat(Ppat_tuple(List.rev $1)) } | constr_longident pattern %prec prec_constr_appl @@ -1256,10 +1261,16 @@ pattern: { mkpat(Ppat_variant($1, Some $2)) } | pattern COLONCOLON pattern { mkpat_cons (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) } + | pattern COLONCOLON error + { expecting 3 "pattern" } | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN { mkpat_cons (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) } + | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error + { unclosed "(" 4 ")" 8 } | pattern BAR pattern { mkpat(Ppat_or($1, $3)) } + | pattern BAR error + { expecting 3 "pattern" } | LAZY simple_pattern { mkpat(Ppat_lazy $2) } ; @@ -1300,6 +1311,8 @@ simple_pattern: { mkpat(Ppat_constraint($2, $4)) } | LPAREN pattern COLON core_type error { unclosed "(" 1 ")" 5 } + | LPAREN pattern COLON error + { expecting 4 "type" } | LPAREN MODULE UIDENT RPAREN { mkpat(Ppat_unpack (mkrhs $3 3)) } | LPAREN MODULE UIDENT COLON package_type RPAREN @@ -1311,6 +1324,7 @@ simple_pattern: pattern_comma_list: pattern_comma_list COMMA pattern { $3 :: $1 } | pattern COMMA pattern { [$3; $1] } + | pattern COMMA error { expecting 3 "pattern" } ; pattern_semi_list: pattern { [$1] } @@ -1665,6 +1679,8 @@ ident: val_ident: LIDENT { $1 } | LPAREN operator RPAREN { $2 } + | LPAREN operator error { unclosed "(" 1 ")" 3 } + | LPAREN error { expecting 2 "operator" } ; operator: PREFIXOP { $1 } diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index bd5fafb25..5c17a99a3 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -16,11 +16,13 @@ open Format type error = Unclosed of Location.t * string * Location.t * string + | Expecting of Location.t * string | Applicative_path of Location.t | Variable_in_scope of Location.t * string | Other of Location.t + exception Error of error exception Escape_error @@ -36,6 +38,10 @@ let report_error ppf = function fprintf ppf "%aThis '%s' might be unmatched" Location.print_error opening_loc opening end + | Expecting (loc, nonterm) -> + fprintf ppf + "%a@[Syntax error: %s expected.@]" + Location.print_error loc nonterm | Applicative_path loc -> fprintf ppf "%aSyntax error: applicative paths of the form F(X).t \ @@ -48,3 +54,11 @@ let report_error ppf = function Location.print_error loc var var | Other loc -> fprintf ppf "%aSyntax error" Location.print_error loc + + +let location_of_error = function + | Unclosed(l,_,_,_) + | Applicative_path l + | Variable_in_scope(l,_) + | Other l + | Expecting (l, _) -> l diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 08de06de6..03cf532eb 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -16,6 +16,7 @@ open Format type error = Unclosed of Location.t * string * Location.t * string + | Expecting of Location.t * string | Applicative_path of Location.t | Variable_in_scope of Location.t * string | Other of Location.t @@ -24,3 +25,5 @@ exception Error of error exception Escape_error val report_error: formatter -> error -> unit + +val location_of_error: error -> Location.t |