Port Syntaxerr.Error to the new system. Trickier, because of special way to report some errors in the toplevel (is it really worth the trouble?).

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

8 files changed, 81 insertions, 60 deletions

diff --git a/driver/errors.ml b/driver/errors.ml
index 5faa274da..f7864ccd0 100644
--- a/driver/errors.ml
+++ b/driver/errors.ml
@@ -24,8 +24,6 @@ let report_error ppf exn =
   | Lexer.Error(err, loc) ->
       Location.print_error ppf loc;
       Lexer.report_error ppf err
-  | Syntaxerr.Error err ->
-      Syntaxerr.report_error ppf err
   | Pparse.Error err ->
       Pparse.report_error ppf err
   | Env.Error err ->
diff --git a/driver/opterrors.ml b/driver/opterrors.ml
index 965844c92..7a519b79b 100644
--- a/driver/opterrors.ml
+++ b/driver/opterrors.ml
@@ -23,8 +23,6 @@ let report_error ppf exn =
   | Lexer.Error(err, l) ->
       Location.print_error ppf l;
       Lexer.report_error ppf err
-  | Syntaxerr.Error err ->
-      Syntaxerr.report_error ppf err
   | Pparse.Error err ->
       Pparse.report_error ppf err
   | Env.Error err ->
diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml
index 846724c06..4b2af7f97 100644
--- a/ocamldoc/odoc_analyse.ml
+++ b/ocamldoc/odoc_analyse.ml
@@ -111,8 +111,6 @@ let process_error exn =
   | Lexer.Error(err, loc) ->
       Location.print_error ppf loc;
       Lexer.report_error ppf err
-  | Syntaxerr.Error err ->
-      Syntaxerr.report_error ppf err
   | Env.Error err ->
       Location.print_error_cur_file ppf;
       Env.report_error ppf err
diff --git a/parsing/location.ml b/parsing/location.ml
index 14d2f9513..0fbfd95f0 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -74,7 +74,7 @@ let num_loc_lines = ref 0 (* number of lines already printed after input *)
 
 (* Highlight the locations using standout mode. *)
 
-let highlight_terminfo ppf num_lines lb loc1 loc2 =
+let highlight_terminfo ppf num_lines lb locs =
   Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
   (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
   let pos0 = -lb.lex_abs_pos in
@@ -94,9 +94,9 @@ let highlight_terminfo ppf num_lines lb loc1 loc2 =
   print_string "# ";
   for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
     if !bol then (print_string "  "; bol := false);
-    if pos = loc1.loc_start.pos_cnum || pos = loc2.loc_start.pos_cnum then
+    if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
       Terminfo.standout true;
-    if pos = loc1.loc_end.pos_cnum || pos = loc2.loc_end.pos_cnum then
+    if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
       Terminfo.standout false;
     let c = lb.lex_buffer.[pos + pos0] in
     print_char c;
@@ -176,10 +176,10 @@ let highlight_dumb ppf lb loc =
 
 (* Highlight the location using one of the supported modes. *)
 
-let rec highlight_locations ppf loc1 loc2 =
+let rec highlight_locations ppf locs =
   match !status with
     Terminfo.Uninitialised ->
-      status := Terminfo.setup stdout; highlight_locations ppf loc1 loc2
+      status := Terminfo.setup stdout; highlight_locations ppf locs
   | Terminfo.Bad_term ->
       begin match !input_lexbuf with
         None -> false
@@ -187,6 +187,7 @@ let rec highlight_locations ppf loc1 loc2 =
           let norepeat =
             try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
           if norepeat then false else
+            let loc1 = List.hd locs in
             try highlight_dumb ppf lb loc1; true
             with Exit -> false
       end
@@ -194,7 +195,7 @@ let rec highlight_locations ppf loc1 loc2 =
       begin match !input_lexbuf with
         None -> false
       | Some lb ->
-          try highlight_terminfo ppf num_lines lb loc1 loc2; true
+          try highlight_terminfo ppf num_lines lb locs; true
           with Exit -> false
       end
 
@@ -237,7 +238,7 @@ let print_loc ppf loc =
   let (file, line, startchar) = get_pos_info loc.loc_start in
   let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
   if file = "//toplevel//" then begin
-    if highlight_locations ppf loc none then () else
+    if highlight_locations ppf [loc] then () else
       fprintf ppf "Characters %i-%i"
               loc.loc_start.pos_cnum loc.loc_end.pos_cnum
   end else begin
@@ -249,7 +250,7 @@ let print_loc ppf loc =
 
 let print ppf loc =
   if loc.loc_start.pos_fname = "//toplevel//"
-  && highlight_locations ppf loc none then ()
+  && highlight_locations ppf [loc] then ()
   else fprintf ppf "%a%s@." print_loc loc msg_colon
 ;;
 
@@ -293,9 +294,14 @@ type error =
     loc: t;
     msg: string;
     sub: error list;
+    if_highlight: string; (* alternative message if locations are highlighted *)
   }
 
-let error ?(loc = none) ?(sub = []) msg = {loc; msg; sub}
+let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
+  Printf.ksprintf (fun msg -> {loc; msg; sub; if_highlight})
+
+let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg =
+  {loc; msg; sub; if_highlight}
 
 let error_of_exn : (exn -> error option) list ref = ref []
 
@@ -311,16 +317,29 @@ let error_of_exn exn =
   in
   loop !error_of_exn
 
-let rec report_error ppf {loc; msg; sub} =
-  print ppf loc;
-  Format.pp_print_string ppf msg;
-  List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub
+let rec report_error ppf ({loc; msg; sub; if_highlight} as err) =
+  let highlighted =
+    if if_highlight <> "" then
+      let rec collect_locs locs {loc; sub; if_highlight; _} =
+        List.fold_left collect_locs (loc :: locs) sub
+      in
+      let locs = collect_locs [] err in
+      highlight_locations ppf locs
+    else
+      false
+  in
+  if highlighted then
+    Format.pp_print_string ppf if_highlight
+  else begin
+    print ppf loc;
+    Format.pp_print_string ppf msg;
+    List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub
+  end
 
 let error_of_printer loc print x =
   let buf = Buffer.create 64 in
   let ppf = Format.formatter_of_buffer buf in
-  Format.fprintf ppf "Error: ";
   print ppf x;
   pp_print_flush ppf ();
   let msg = Buffer.contents buf in
-  error ~loc msg
+  errorf ~loc "Error: %s" msg
diff --git a/parsing/location.mli b/parsing/location.mli
index a465b8a1f..09e065952 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -56,7 +56,7 @@ val prerr_warning: t -> Warnings.t -> unit
 val echo_eof: unit -> unit
 val reset: unit -> unit
 
-val highlight_locations: formatter -> t -> t -> bool
+val highlight_locations: formatter -> t list -> bool
 
 type 'a loc = {
   txt : 'a;
@@ -84,9 +84,12 @@ type error =
     loc: t;
     msg: string;
     sub: error list;
+    if_highlight: string; (* alternative message if locations are highlighted *)
   }
 
-val error: ?loc:t -> ?sub:error list -> string -> error
+val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
+
+val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string -> ('a, unit, string, error) format4 -> 'a
 
 val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error
 
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index b19a382d4..13212eecd 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -12,8 +12,6 @@
 
 (* Auxiliary type for reporting syntax errors *)
 
-open Format
-
 type error =
     Unclosed of Location.t * string * Location.t * string
   | Expecting of Location.t * string
@@ -22,44 +20,48 @@ type error =
   | Variable_in_scope of Location.t * string
   | Other of Location.t
 
-
-
 exception Error of error
 exception Escape_error
 
-let report_error ppf = function
+let prepare_error = function
   | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      if !Location.input_name = "//toplevel//"
-         && Location.highlight_locations ppf opening_loc closing_loc
-      then fprintf ppf "Syntax error: '%s' expected, \
-                   the highlighted '%s' might be unmatched" closing opening
-      else begin
-        fprintf ppf "%aSyntax error: '%s' expected@."
-          Location.print_error closing_loc closing;
-        fprintf ppf "%aThis '%s' might be unmatched"
-          Location.print_error opening_loc opening
-      end
+      Location.errorf ~loc:closing_loc
+        ~sub:[
+          Location.error ~loc:opening_loc
+            (Printf.sprintf "Error: This '%s' might be unmatched" opening)
+        ]
+        ~if_highlight:
+          (Printf.sprintf "Syntax error: '%s' expected, \
+                           the highlighted '%s' might be unmatched"
+             closing opening)
+        "Error: Syntax error: '%s' expected" closing
+
   | Expecting (loc, nonterm) ->
-      fprintf ppf
-        "%a@[Syntax error: %s expected.@]"
-        Location.print_error loc nonterm
+      Location.errorf ~loc "Error: Syntax error: %s expected." nonterm
   | Not_expecting (loc, nonterm) ->
-      fprintf ppf
-        "%a@[Syntax error: %s not expected.@]"
-        Location.print_error loc nonterm
+      Location.errorf ~loc "Error: Syntax error: %s not expected." nonterm
   | Applicative_path loc ->
-      fprintf ppf
-        "%aSyntax error: applicative paths of the form F(X).t \
+      Location.errorf ~loc
+        "Error: Syntax error: applicative paths of the form F(X).t \
          are not supported when the option -no-app-func is set."
-        Location.print_error loc
   | Variable_in_scope (loc, var) ->
-      fprintf ppf
-        "%a@[In this scoped type, variable '%s@ \
-         is reserved for the local type %s.@]"
-        Location.print_error loc var var
+      Location.errorf ~loc
+        "Error: In this scoped type, variable '%s@ \
+         is reserved for the local type %s."
+        var var
   | Other loc ->
-      fprintf ppf "%aSyntax error" Location.print_error loc
+      Location.error ~loc "Error: Syntax error"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (prepare_error err)
+      | _ -> None
+    )
+
 
+let report_error ppf err =
+  Location.report_error ppf (prepare_error err)
 
 let location_of_error = function
   | Unclosed(l,_,_,_)
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 2b0b9513c..233dba34d 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -211,9 +211,6 @@ let report_err source_file exn =
     | Lexer.Error(err, range) ->
         Format.fprintf Format.err_formatter "@[%a%a@]@."
         Location.print_error range  Lexer.report_error err
-    | Syntaxerr.Error err ->
-        Format.fprintf Format.err_formatter "@[%a@]@."
-        Syntaxerr.report_error err
     | Sys_error msg ->
         Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
     | Pparse.Error err ->
@@ -221,7 +218,12 @@ let report_err source_file exn =
                        "@[Preprocessing error on file %s@]@.@[%a@]@."
           source_file
           Pparse.report_error err
-    | x -> raise x
+    | x ->
+        match Location.error_of_exn x with
+        | Some err ->
+            Format.fprintf Format.err_formatter "@[%a@]@."
+              Location.report_error err
+        | None -> raise x
 
 let read_parse_and_extract parse_function extract_function magic source_file =
   Depend.free_structure_names := Depend.StringSet.empty;
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 77c50168a..acd99f200 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -504,14 +504,15 @@ let main () =
     | Lexer.Error(err, range) ->
         fprintf ppf "@[%a%a@]@."
         Location.print_error range  Lexer.report_error err
-    | Syntaxerr.Error err ->
-        fprintf ppf "@[%a@]@."
-        Syntaxerr.report_error err
     | Profiler msg ->
         fprintf ppf "@[%s@]@." msg
     | Sys_error msg ->
         fprintf ppf "@[I/O error:@ %s@]@." msg
-    | x -> raise x in
+    | x ->
+        match Location.error_of_exn x with
+        | Some err -> fprintf ppf "@[%a@]@." Location.report_error err
+        | None -> raise x
+    in
     report_error Format.err_formatter x;
     exit 2