PR#5212: Fix: ocamlbuild does not warn for bad input

Patch by Ygrek!

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13193 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -13,6 +13,7 @@ Bug fixes:
 - PR#4994: ocaml-mode doesn't work with xemacs21
 * PR#5119: camlp4 now raises a specific exception when 'DELETE_RULE' fails,
   rather than raising 'Not_found'
+- PR#5212: Improve ocamlbuild error messages of _tags parser
 - PR#5327: (Windows) Unix.select blocks if same socket listed in first and
   third arguments
 - PR#5343: ocaml -rectypes is unsound wrt module subtyping (was still unsound)

ocamlbuild/command.ml

@@ -101,7 +101,7 @@ let env_path = lazy begin
   let paths =
     try
       parse_path (Lexing.from_string path_var)
-    with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg))
+    with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos))
   in
   let norm_current_dir_name path =
     if path = "" then Filename.current_dir_name else path

ocamlbuild/configuration.ml

@@ -32,17 +32,17 @@ let (configs, add_config) =
      configs := config :: !configs;
      Hashtbl.clear cache)
 
-let parse_string s =
-  let conf = Lexers.conf_lines None 1 (Printf.sprintf "string: %S" s) (Lexing.from_string s) in
+let parse_lexbuf ?dir source lexbuf =
+  lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source };
+  let conf = Lexers.conf_lines dir lexbuf in
   add_config conf
 
+let parse_string s = parse_lexbuf (Printf.sprintf "String %S" s) (Lexing.from_string s)
+
 let parse_file ?dir file =
-  try
-    with_input_file file begin fun ic ->
-      let conf = Lexers.conf_lines dir 1 (Printf.sprintf "file: %S" file) (Lexing.from_channel ic) in
-      add_config conf
-    end
-  with Lexers.Error msg -> raise (Lexers.Error (file ^ ": " ^ msg))
+  with_input_file file begin fun ic ->
+    parse_lexbuf ?dir (Printf.sprintf "File %S" file) (Lexing.from_channel ic)
+  end
 
 let key_match = Glob.eval
 

ocamlbuild/findlib.ml

@@ -110,7 +110,7 @@ let rec query name =
           (* TODO: Improve to differenciate whether ocamlfind cannot be
              run or is not installed *)
           error Cannot_run_ocamlfind
-      | Lexers.Error s ->
+      | Lexers.Error (s,_) ->
           error (Cannot_parse_query (name, s))
 
 let split_nl s =

ocamlbuild/lexers.mli

@@ -12,7 +12,7 @@
 
 
 (* Original author: Nicolas Pouillard *)
-exception Error of string
+exception Error of (string * Lexing.position)
 
 type conf_values =
   { plus_tags   : string list;
@@ -36,7 +36,7 @@ val parse_environment_path : Lexing.lexbuf -> string list
 (* Same one, for Windows (PATH is ;-separated) *)
 val parse_environment_path_w : Lexing.lexbuf -> string list
 
-val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf
+val conf_lines : string option -> Lexing.lexbuf -> conf
 val path_scheme : bool -> Lexing.lexbuf ->
   [ `Word of string
   | `Var of (string * Glob.globber)

ocamlbuild/lexers.mll

@@ -13,7 +13,10 @@
 
 (* Original author: Nicolas Pouillard *)
 {
-exception Error of string
+exception Error of (string * Lexing.position)
+
+let error lexbuf fmt = Printf.ksprintf (fun s -> raise (Error (s,Lexing.lexeme_start_p lexbuf))) fmt
+
 open Glob_ast
 
 type conf_values =
@@ -42,45 +45,45 @@ let pattern = ([^ '(' ')' '\\' ] | '\\' [ '(' ')' ])*
 rule ocamldep_output = parse
   | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf }
   | eof { [] }
-  | _ { raise (Error "Expecting colon followed by space-separated module name list") }
+  | _ { error lexbuf "Expecting colon followed by space-separated module name list" }
 
 and space_sep_strings_nl = parse
   | space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf }
-  | space* newline { [] }
-  | _ { raise (Error "Expecting space-separated strings terminated with newline") }
+  | space* newline { Lexing.new_line lexbuf; [] }
+  | _ { error lexbuf "Expecting space-separated strings terminated with newline" }
 
 and space_sep_strings = parse
   | space* (not_blank+ as word) { word :: space_sep_strings lexbuf }
   | space* newline? eof { [] }
-  | _ { raise (Error "Expecting space-separated strings") }
+  | _ { error lexbuf "Expecting space-separated strings" }
 
 and blank_sep_strings = parse
   | blank* '#' not_newline* newline { blank_sep_strings lexbuf }
   | blank* '#' not_newline* eof { [] }
   | blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf }
   | blank* eof { [] }
-  | _ { raise (Error "Expecting blank-separated strings") }
+  | _ { error lexbuf "Expecting blank-separated strings" }
 
 and comma_sep_strings = parse
   | space* (not_space_nor_comma+ as word) space* eof { [word] }
   | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf }
   | space* eof { [] }
-  | _ { raise (Error "Expecting comma-separated strings (1)") }
+  | _ { error lexbuf "Expecting comma-separated strings (1)" }
 and comma_sep_strings_aux = parse
   | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf }
   | space* eof { [] }
-  | _ { raise (Error "Expecting comma-separated strings (2)") }
+  | _ { error lexbuf "Expecting comma-separated strings (2)" }
 
 and comma_or_blank_sep_strings = parse
   | space* (not_space_nor_comma+ as word) space* eof { [word] }
   | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
   | space* eof { [] }
-  | _ { raise (Error "Expecting (comma|blank)-separated strings (1)") }
+  | _ { error lexbuf "Expecting (comma|blank)-separated strings (1)" }
 and comma_or_blank_sep_strings_aux = parse
   | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
   | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
   | space* eof { [] }
-  | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") }
+  | _ { error lexbuf "Expecting (comma|blank)-separated strings (2)" }
 
 and parse_environment_path_w = parse
   | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
@@ -89,7 +92,7 @@ and parse_environment_path_w = parse
 and parse_environment_path_aux_w = parse
   | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
   | eof { [] }
-  | _ { raise (Error "Impossible: expecting colon-separated strings") }
+  | _ { error lexbuf "Impossible: expecting colon-separated strings" }
 
 and parse_environment_path = parse
   | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf }
@@ -98,31 +101,35 @@ and parse_environment_path = parse
 and parse_environment_path_aux = parse
   | ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf }
   | eof { [] }
-  | _ { raise (Error "Impossible: expecting colon-separated strings") }
+  | _ { error lexbuf "Impossible: expecting colon-separated strings" }
 
-and conf_lines dir pos err = parse
-  | space* '#' not_newline* newline { conf_lines dir (pos + 1) err lexbuf }
+and conf_lines dir = parse
+  | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf }
   | space* '#' not_newline* eof { [] }
-  | space* newline { conf_lines dir (pos + 1) err lexbuf }
+  | space* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf }
   | space* eof { [] }
   | space* (not_newline_nor_colon+ as k) space* ':' space*
       {
-        let bexpr = Glob.parse ?dir k in
-        let v1 = conf_value pos err empty lexbuf in
-        let v2 = conf_values pos err v1 lexbuf in
-        let rest = conf_lines dir (pos + 1) err lexbuf in (bexpr, v2) :: rest
+        let bexpr =
+          try Glob.parse ?dir k
+          with exn -> error lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn)
+        in
+        let v1 = conf_value empty lexbuf in
+        let v2 = conf_values v1 lexbuf in
+        Lexing.new_line lexbuf; (* FIXME values may have escaped newlines *)
+        let rest = conf_lines dir lexbuf in (bexpr,v2) :: rest
       }
-  | _ { raise (Error(Printf.sprintf "Bad key in configuration line at line %d (from %s)" pos err)) }
+  | _ { error lexbuf "Invalid line syntax" }
 
-and conf_value pos err x = parse
+and conf_value x = parse
   | '-'  (tag as tag) { { (x) with minus_tags = tag :: x.minus_tags } }
   | '+'? (tag as tag) { { (x) with plus_tags = tag :: x.plus_tags } }
-  | (_ | eof) { raise (Error(Printf.sprintf "Bad value in configuration line at line %d (from %s)" pos err)) }
+  | (_ | eof) { error lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" }
 
-and conf_values pos err x = parse
-  | space_or_esc_nl* ',' space_or_esc_nl* { conf_values pos err (conf_value pos err x lexbuf) lexbuf }
+and conf_values x = parse
+  | space_or_esc_nl* ',' space_or_esc_nl* { conf_values (conf_value x lexbuf) lexbuf }
   | (newline | eof) { x }
-  | (_ | eof) { raise (Error(Printf.sprintf "Bad values in configuration line at line %d (from %s)" pos err)) }
+  | (_ | eof) { error lexbuf "Only ',' separated tags are alllowed" }
 
 and path_scheme patt_allowed = parse
   | ([^ '%' ]+ as prefix)
@@ -133,14 +140,13 @@ and path_scheme patt_allowed = parse
       { if patt_allowed then
           let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in
           `Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf
-        else raise (Error(
-          Printf.sprintf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)"
-            var patt)) }
+        else
+          error lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt }
   | '%'
       { `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf }
   | eof
       { [] }
-  | _ { raise (Error("Bad pathanme scheme")) }
+  | _ { error lexbuf "Bad pathanme scheme" }
 
 and unescape = parse
   | '\\' (['(' ')'] as c)        { c :: unescape lexbuf }
@@ -156,11 +162,11 @@ and ocamlfind_query = parse
     "linkopts:" space* (not_newline* as lo) newline+
     "location:" space* (not_newline* as l) newline+
     { n, d, v, a, lo, l }
-  | _ { raise (Error "Bad ocamlfind query") }
+  | _ { error lexbuf "Bad ocamlfind query" }
 
 and trim_blanks = parse
   | blank* (not_blank* as word) blank* { word }
-  | _ { raise (Error "Bad input for trim_blanks") }
+  | _ { error lexbuf "Bad input for trim_blanks" }
 
 and tag_gen = parse
   | (normal+ as name) ('(' ([^')']* as param) ')')? { name, param }

ocamlbuild/main.ml

@@ -277,8 +277,9 @@ let main () =
       | Ocaml_utils.Ocamldep_error msg ->
           Log.eprintf "Ocamldep error: %s" msg;
           exit rc_ocamldep_error
-      | Lexers.Error msg ->
-          Log.eprintf "Lexical analysis error: %s" msg;
+      | Lexers.Error (msg,pos) ->
+          let module L = Lexing in
+          Log.eprintf "%s, line %d, column %d: Lexing error: %s." pos.L.pos_fname pos.L.pos_lnum (pos.L.pos_cnum - pos.L.pos_bol) msg;
           exit rc_lexing_error
       | Arg.Bad msg ->
           Log.eprintf "%s" msg;

ocamlbuild/ocaml_utils.ml

@@ -145,7 +145,7 @@ let read_path_dependencies =
     with_input_file depends begin fun ic ->
       let ocamldep_output =
         try Lexers.ocamldep_output (Lexing.from_channel ic)
-        with Lexers.Error msg -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in
+        with Lexers.Error (msg,_) -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in
       let deps =
         List.fold_right begin fun (path, deps) acc ->
           let module_name' = module_name_of_pathname path in

ocamlbuild/testsuite/level0.ml

@@ -64,10 +64,16 @@ test "camlp4.opt"
   ~matching:[M.x "dummy.native" ~output:"Hello"]
   ~targets:("dummy.native",[]) ();;
 
-test "TagsErrorMessage"
-  ~description:"Confirm relevance of an error message due to erronous _tags"
-  ~failing_msg:"Failure: lexing: empty token."
-  ~tree:[T.f "_tags" ~content:"* : not_hygienic"]
-  ~targets:("none.native",[]) ();;
+let tag_pat_msgs =
+  ["*:a", "File \"_tags\", line 1, column 0: Lexing error: Invalid globbing pattern \"*\".";
+   "\n<*{>:a", "File \"_tags\", line 2, column 0: Lexing error: Invalid globbing pattern \"<*{>\".";
+   "<*>: ~@a,# ~a", "File \"_tags\", line 1, column 10: Lexing error: Only ',' separated tags are alllowed."];;
+
+List.iteri (fun i (content,failing_msg) ->
+  test (Printf.sprintf "TagsErrorMessage_%d" (i+1))
+    ~description:"Confirm relevance of an error message due to erronous _tags"
+    ~failing_msg
+    ~tree:[T.f "_tags" ~content; T.f "dummy.ml"]
+    ~targets:("dummy.native",[]) ()) tag_pat_msgs;;
 
 run ~root:"_test";;