Integrate exception_registration banch.

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

asmcomp/asmgen.ml

@@ -140,3 +140,10 @@ let report_error ppf = function
   | Assembler_error file ->
       fprintf ppf "Assembler error, input left in file %a"
         Location.print_filename file
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

asmcomp/asmlibrarian.ml

@@ -69,3 +69,10 @@ let report_error ppf = function
       fprintf ppf "Cannot find file %s" name
   | Archiver_error name ->
       fprintf ppf "Error while creating the library %s" name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

asmcomp/asmlink.ml

@@ -390,3 +390,10 @@ let report_error ppf = function
         Location.print_filename filename name
         Location.print_filename  filename
         name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

asmcomp/asmpackager.ml

@@ -204,3 +204,10 @@ let report_error ppf = function
       fprintf ppf "Error while assembling %s" file
   | Linking_error ->
       fprintf ppf "Error during partial linking"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

asmcomp/compilenv.ml

@@ -245,3 +245,10 @@ let report_error ppf = function
       fprintf ppf "%a@ contains the description for unit\
                    @ %s when %s was expected"
         Location.print_filename filename name modname
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

bytecomp/bytelibrarian.ml

@@ -117,3 +117,10 @@ let report_error ppf = function
   | Not_an_object_file name ->
       fprintf ppf "The file %a is not a bytecode object file"
         Location.print_filename name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

bytecomp/bytelink.ml

@@ -622,3 +622,10 @@ let report_error ppf = function
   | Not_compatible_32 ->
       fprintf ppf "Generated bytecode executable cannot be run\
                   \ on a 32-bit platform"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

bytecomp/bytepackager.ml

@@ -276,3 +276,10 @@ let report_error ppf = function
         Location.print_filename file name id
   | File_not_found file ->
       fprintf ppf "File %s not found" file
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

bytecomp/symtable.ml

@@ -372,3 +372,10 @@ let report_error ppf = function
       fprintf ppf "Cannot find or execute the runtime system %s" s
   | Uninitialized_global s ->
       fprintf ppf "The value of the global `%s' is not yet computed" s
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

bytecomp/translclass.ml

@@ -826,3 +826,12 @@ let report_error ppf = function
   | Tags (lab1, lab2) ->
       fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
         lab1 lab2 "Change one of them."
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )

bytecomp/translcore.ml

@@ -1120,3 +1120,12 @@ let report_error ppf = function
         "Ancestor names can only be used to select inherited methods"
   | Unknown_builtin_primitive prim_name ->
     fprintf ppf  "Unknown builtin primitive \"%s\"" prim_name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+          Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )

bytecomp/translmod.ml

@@ -810,3 +810,12 @@ let report_error ppf = function
         "@[Cannot safely evaluate the definition@ \
          of the recursively-defined module %a@]"
         Printtyp.ident id
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )

driver/errors.ml

@@ -10,72 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* WARNING: if you change something in this file, you must look at
+(* This module should be removed.  We keep it for now, to avoid
-   opterrors.ml and ocamldoc/odoc_analyse.ml
+   breaking external tools depending on it. *)
-   to see if you need to make the same changes there.
-*)
 
-open Format
+let report_error = Location.report_exception
-
-(* Report an error *)
-
-let report_error ppf exn =
-  let report ppf = function
-  | 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 ->
-      Location.print_error_cur_file ppf;
-      Env.report_error ppf err
-  | Cmi_format.Error err ->
-      Location.print_error_cur_file ppf;
-      Cmi_format.report_error ppf err
-  | Ctype.Tags(l, l') ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf
-      "In this program,@ variant constructors@ `%s and `%s@ \
-       have the same hash value.@ Change one of them." l l'
-  | Typecore.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typecore.report_error env ppf err
-  | Typetexp.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typetexp.report_error env ppf err
-  | Typedecl.Error(loc, err) ->
-      Location.print_error ppf loc; Typedecl.report_error ppf err
-  | Typeclass.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typeclass.report_error env ppf err
-  | Includemod.Error err ->
-      Location.print_error_cur_file ppf;
-      Includemod.report_error ppf err
-  | Typemod.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typemod.report_error env ppf err
-  | Translcore.Error(loc, err) ->
-      Location.print_error ppf loc; Translcore.report_error ppf err
-  | Translclass.Error(loc, err) ->
-      Location.print_error ppf loc; Translclass.report_error ppf err
-  | Translmod.Error(loc, err) ->
-      Location.print_error ppf loc; Translmod.report_error ppf err
-  | Symtable.Error code ->
-      Location.print_error_cur_file ppf;
-      Symtable.report_error ppf code
-  | Bytelink.Error code ->
-      Location.print_error_cur_file ppf;
-      Bytelink.report_error ppf code
-  | Bytelibrarian.Error code ->
-      Location.print_error_cur_file ppf;
-      Bytelibrarian.report_error ppf code
-  | Bytepackager.Error code ->
-      Location.print_error_cur_file ppf;
-      Bytepackager.report_error ppf code
-  | Sys_error msg ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf "I/O error: %s" msg
-  | Warnings.Errors (n) ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
-  | x -> fprintf ppf "@]"; raise x in
-
-  fprintf ppf "@[%a@]@." report exn

driver/main.ml

@@ -184,7 +184,7 @@ let main () =
     end;
     exit 0
   with x ->
-    Errors.report_error ppf x;
+    Location.report_exception ppf x;
     exit 2
 
 let _ = main ()

driver/opterrors.ml

@@ -10,74 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* WARNING: if you change something in this file, you must look at
+(* This module should be removed.  We keep it for now, to avoid
-   errors.ml to see if you need to make the same changes there.
+   breaking external tools depending on it. *)
-*)
 
-open Format
+let report_error = Location.report_exception
-
-(* Report an error *)
-
-let report_error ppf exn =
-  let report ppf = function
-  | 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 ->
-      Location.print_error_cur_file ppf;
-      Env.report_error ppf err
-  | Cmi_format.Error err ->
-      Location.print_error_cur_file ppf;
-      Cmi_format.report_error ppf err
-  | Ctype.Tags(l, l') ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf
-      "In this program,@ variant constructors@ `%s and `%s@ \
-       have the same hash value.@ Change one of them." l l'
-  | Typecore.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typecore.report_error env ppf err
-  | Typetexp.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typetexp.report_error env ppf err
-  | Typedecl.Error(loc, err) ->
-      Location.print_error ppf loc; Typedecl.report_error ppf err
-  | Typeclass.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typeclass.report_error env ppf err
-  | Includemod.Error err ->
-      Location.print_error_cur_file ppf;
-      Includemod.report_error ppf err
-  | Typemod.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typemod.report_error env ppf err
-  | Translcore.Error(loc, err) ->
-      Location.print_error ppf loc; Translcore.report_error ppf err
-  | Translclass.Error(loc, err) ->
-      Location.print_error ppf loc; Translclass.report_error ppf err
-  | Translmod.Error(loc, err) ->
-      Location.print_error ppf loc; Translmod.report_error ppf err
-  | Compilenv.Error code ->
-      Location.print_error_cur_file ppf;
-      Compilenv.report_error ppf code
-  | Asmgen.Error code ->
-      Location.print_error_cur_file ppf;
-      Asmgen.report_error ppf code
-  | Asmlink.Error code ->
-      Location.print_error_cur_file ppf;
-      Asmlink.report_error ppf code
-  | Asmlibrarian.Error code ->
-      Location.print_error_cur_file ppf;
-      Asmlibrarian.report_error ppf code
-  | Asmpackager.Error code ->
-      Location.print_error_cur_file ppf;
-      Asmpackager.report_error ppf code
-  | Sys_error msg ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf "I/O error: %s" msg
-  | Warnings.Errors (n) ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
-  | x -> fprintf ppf "@]"; raise x in
-
-  fprintf ppf "@[%a@]@." report exn

driver/optmain.ml

@@ -201,7 +201,7 @@ let main () =
     end;
     exit 0
   with x ->
-    Opterrors.report_error ppf x;
+      Location.report_exception ppf x;
-    exit 2
+      exit 2
 
 let _ = main ()

driver/pparse.ml

@@ -59,7 +59,8 @@ let apply_rewriter magic fn_in ppx =
     Misc.remove_file fn_out;
     raise (Error (CannotRun comm));
   end;
-  if not (Sys.file_exists fn_out) then raise (Error (WrongMagic comm));
+  if not (Sys.file_exists fn_out) then
+    raise (Error (WrongMagic comm));
   (* check magic before passing to the next ppx *)
   let ic = open_in_bin fn_out in
   let buffer =
@@ -143,6 +144,12 @@ let report_error ppf = function
       fprintf ppf "External preprocessor does not produce a valid file@.\
                    Command line: %s@." cmd
 
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
 
 let parse_all parse_fun magic ppf sourcefile =
   Location.input_name := sourcefile;

ocamldoc/odoc_analyse.ml

@@ -100,60 +100,16 @@ module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever)
 (** The module used to analyse the parse tree and typed tree of an interface file.*)
 module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever)
 
-(** Handle an error. This is a partial copy of the compiler
+(** Handle an error. *)
-   driver/error.ml file. We do this because there are
+
-   some differences between the possibly raised exceptions
-   in the bytecode (error.ml) and opt (opterros.ml) compilers
-   and we don't want to take care of this. Besises, these
-   differences only concern code generation (i believe).*)
 let process_error exn =
-  let report ppf = function
+  match Location.error_of_exn exn with
-  | Lexer.Error(err, loc) ->
+  | Some err ->
-      Location.print_error ppf loc;
+      fprintf Format.err_formatter "@[%a@]@." Location.report_error err
-      Lexer.report_error ppf err
+  | None ->
-  | Syntaxerr.Error err ->
+      fprintf Format.err_formatter
-      Syntaxerr.report_error ppf err
+        "Compilation error(%s). Use the OCaml compiler to get more details.@."
-  | Env.Error err ->
+        (Printexc.to_string exn)
-      Location.print_error_cur_file ppf;
-      Env.report_error ppf err
-  | Cmi_format.Error err ->
-      Location.print_error_cur_file ppf;
-      Cmi_format.report_error ppf err
-  | Ctype.Tags(l, l') ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf
-      "In this program,@ variant constructors@ `%s and `%s@ \
-       have the same hash value." l l'
-  | Typecore.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typecore.report_error env ppf err
-  | Typetexp.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typetexp.report_error env ppf err
-  | Typedecl.Error(loc, err) ->
-      Location.print_error ppf loc; Typedecl.report_error ppf err
-  | Includemod.Error err ->
-      Location.print_error_cur_file ppf;
-      Includemod.report_error ppf err
-  | Typemod.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typemod.report_error env ppf err
-  | Translcore.Error(loc, err) ->
-      Location.print_error ppf loc; Translcore.report_error ppf err
-  | Sys_error msg ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf "I/O error: %s" msg
-  | Typeclass.Error(loc, env, err) ->
-      Location.print_error ppf loc; Typeclass.report_error env ppf err
-  | Translclass.Error(loc, err) ->
-      Location.print_error ppf loc; Translclass.report_error ppf err
-  | Warnings.Errors (n) ->
-      Location.print_error_cur_file ppf;
-      fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
-  | x ->
-      fprintf ppf "@]";
-      fprintf ppf
-        "Compilation error(%s). Use the OCaml compiler to get more details."
-        (Printexc.to_string x)
-  in
-  Format.fprintf Format.err_formatter "@[%a@]@." report exn
 
 (** Process the given file, according to its extension. Return the Module.t created, if any.*)
 let process_file ppf sourcefile =

parsing/lexer.mli

@@ -31,6 +31,7 @@ exception Error of error * Location.t
 open Format
 
 val report_error: formatter -> error -> unit
+ (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
 
 val in_comment : unit -> bool;;
 val in_string : unit -> bool;;

parsing/lexer.mll

@@ -242,7 +242,15 @@ let report_error ppf = function
   | Literal_overflow ty ->
       fprintf ppf "Integer literal exceeds the range of representable \
                    integers of type %s" ty
-;;
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (err, loc) ->
+          Some (Location.error_of_printer loc report_error err)
+      | _ ->
+          None
+    )
 
 }
 

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
 ;;
 
@@ -286,3 +287,82 @@ type 'a loc = {
 
 let mkloc txt loc = { txt ; loc }
 let mknoloc txt = mkloc txt none
+
+
+type error =
+  {
+    loc: t;
+    msg: string;
+    sub: error list;
+    if_highlight: string; (* alternative message if locations are highlighted *)
+  }
+
+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 []
+
+let register_error_of_exn f = error_of_exn := f :: !error_of_exn
+
+let error_of_exn exn =
+  let rec loop = function
+    | [] -> None
+    | f :: rest ->
+        match f exn with
+        | Some _ as r -> r
+        | None -> loop rest
+  in
+  loop !error_of_exn
+
+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
+  pp_print_string ppf "Error: ";
+  print ppf x;
+  pp_print_flush ppf ();
+  let msg = Buffer.contents buf in
+  errorf ~loc "%s" msg
+
+let error_of_printer_file print x =
+  error_of_printer (in_file !input_name) print x
+
+let () =
+  register_error_of_exn
+    (function
+      | Sys_error msg ->
+          Some (errorf ~loc:(in_file !input_name) "Error: I/O error: %s" msg)
+      | Warnings.Errors n ->
+          Some
+            (errorf ~loc:(in_file !input_name)
+               "Error: Some fatal warnings were triggered (%d occurrences)" n)
+      | _ ->
+          None
+    )
+
+
+let report_exception ppf exn =
+  match error_of_exn exn with
+  | Some err -> fprintf ppf "@[%a@]@." report_error err
+  | None -> raise exn

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;
@@ -75,3 +75,37 @@ val show_filename: string -> string
 
 
 val absname: bool ref
+
+
+(* Support for located errors *)
+
+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 -> ?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
+
+val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
+
+val error_of_exn: exn -> error option
+
+val register_error_of_exn: (exn -> error option) -> unit
+  (* Each compiler module which defines a custom type of exception
+     which can surface as a user-visible error should register
+     a "printer" for this exception using [register_error_of_exn].
+     The result of the printer is an [error] value containing
+     a location, a message, and optionally sub-messages (each of them
+     being located as well). *)
+
+val report_error: formatter -> error -> unit
+
+val report_exception: formatter -> exn -> unit
+  (* Reraise the exception if it is unknown. *)

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.errorf ~loc:closing_loc
-         && Location.highlight_locations ppf opening_loc closing_loc
+        ~sub:[
-      then fprintf ppf "Syntax error: '%s' expected, \
+          Location.error ~loc:opening_loc
-                   the highlighted '%s' might be unmatched" closing opening
+            (Printf.sprintf "Error: This '%s' might be unmatched" opening)
-      else begin
+        ]
-        fprintf ppf "%aSyntax error: '%s' expected@."
+        ~if_highlight:
-          Location.print_error closing_loc closing;
+          (Printf.sprintf "Syntax error: '%s' expected, \
-        fprintf ppf "%aThis '%s' might be unmatched"
+                           the highlighted '%s' might be unmatched"
-          Location.print_error opening_loc opening
+             closing opening)
-      end
+        "Error: Syntax error: '%s' expected" closing
-  | Expecting (loc, nonterm) ->
-      fprintf ppf
-        "%a@[Syntax error: %s expected.@]"
-        Location.print_error loc nonterm
-  | Not_expecting (loc, nonterm) ->
-      fprintf ppf
-        "%a@[Syntax error: %s not expected.@]"
-        Location.print_error loc nonterm
-  | Applicative_path loc ->
-      fprintf ppf
-        "%aSyntax 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
-  | Other loc ->
-      fprintf ppf "%aSyntax error" Location.print_error loc
 
+  | Expecting (loc, nonterm) ->
+      Location.errorf ~loc "Error: Syntax error: %s expected." nonterm
+  | Not_expecting (loc, nonterm) ->
+      Location.errorf ~loc "Error: Syntax error: %s not expected." nonterm
+  | Applicative_path loc ->
+      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."
+  | Variable_in_scope (loc, var) ->
+      Location.errorf ~loc
+        "Error: In this scoped type, variable '%s@ \
+         is reserved for the local type %s."
+        var var
+  | Other 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,_,_,_)

parsing/syntaxerr.mli

@@ -26,5 +26,6 @@ exception Error of error
 exception Escape_error
 
 val report_error: formatter -> error -> unit
+ (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
 
 val location_of_error: error -> Location.t

tools/ocamldep.ml

@@ -208,20 +208,14 @@ let print_raw_dependencies source_file deps =
 let report_err source_file exn =
   error_occurred := true;
   match exn with
-    | 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 ->
+    | x ->
-        Format.fprintf Format.err_formatter
+        match Location.error_of_exn x with
-                       "@[Preprocessing error on file %s@]@.@[%a@]@."
+        | Some err ->
-          source_file
+            Format.fprintf Format.err_formatter "@[%a@]@."
-          Pparse.report_error err
+              Location.report_error err
-    | x -> raise x
+        | None -> raise x
 
 let read_parse_and_extract parse_function extract_function magic source_file =
   Depend.free_structure_names := Depend.StringSet.empty;

tools/ocamlprof.ml

@@ -499,20 +499,11 @@ let main () =
                 "        Print version number and exit";
       ] process_anon_file usage;
     exit 0
-  with x ->
+  with
-    let report_error ppf = function
+  | Profiler msg ->
-    | Lexer.Error(err, range) ->
+      fprintf Format.err_formatter "@[%s@]@." msg;
-        fprintf ppf "@[%a%a@]@."
+      exit 2
-        Location.print_error range  Lexer.report_error err
+  | exn ->
-    | Syntaxerr.Error err ->
+      Location.report_exception Format.err_formatter exn
-        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
-    report_error Format.err_formatter x;
-    exit 2
 
 let _ = main ()

toplevel/opttoploop.ml

@@ -325,7 +325,7 @@ let use_file ppf name =
         with
         | Exit -> false
         | Sys.Break -> fprintf ppf "Interrupted.@."; false
-        | x -> Opterrors.report_error ppf x; false) in
+        | x -> Location.report_exception ppf x; false) in
     if must_close then close_in ic;
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
@@ -439,7 +439,7 @@ let loop ppf =
     | End_of_file -> exit 0
     | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
     | PPerror -> ()
-    | x -> Opterrors.report_error ppf x; Btype.backtrack snap
+    | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
 (* Execute a script *)

toplevel/opttopmain.ml

@@ -26,7 +26,7 @@ let prepare ppf =
     !Opttoploop.toplevel_startup_hook ();
     res
   with x ->
-    try Opterrors.report_error ppf x; false
+    try Location.report_exception ppf x; false
     with x ->
       Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
       false

toplevel/toploop.ml

@@ -349,7 +349,7 @@ let use_file ppf wrap_mod name =
         with
         | Exit -> false
         | Sys.Break -> fprintf ppf "Interrupted.@."; false
-        | x -> Errors.report_error ppf x; false) in
+        | x -> Location.report_exception ppf x; false) in
     if must_close then close_in ic;
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
@@ -468,7 +468,7 @@ let loop ppf =
     | End_of_file -> exit 0
     | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
     | PPerror -> ()
-    | x -> Errors.report_error ppf x; Btype.backtrack snap
+    | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
 (* Execute a script.  If [name] is "", read the script from stdin. *)

toplevel/topmain.ml

@@ -26,7 +26,7 @@ let prepare ppf =
     !Toploop.toplevel_startup_hook ();
     res
   with x ->
-    try Errors.report_error ppf x; false
+    try Location.report_exception ppf x; false
     with x ->
       Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
       false

typing/cmi_format.ml

@@ -91,3 +91,10 @@ let report_error ppf = function
   | Corrupted_interface filename ->
       fprintf ppf "Corrupted compiled interface@ %a"
         Location.print_filename filename
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

typing/ctype.ml

@@ -84,6 +84,19 @@ exception Unify of (type_expr * type_expr) list
 
 exception Tags of label * label
 
+let () =
+  Location.register_error_of_exn
+    (function
+      | Tags (l, l') ->
+          Some
+            Location.
+              (errorf ~loc:(in_file !input_name)
+                 "In this program,@ variant constructors@ `%s and `%s@ \
+                  have the same hash value.@ Change one of them." l l'
+              )
+      | _ -> None
+    )
+
 exception Subtype of
         (type_expr * type_expr) list * (type_expr * type_expr) list
 

typing/env.ml

@@ -60,6 +60,8 @@ type error =
 
 exception Error of error
 
+let error err = raise (Error err)
+
 module EnvLazy : sig
   type ('a,'b) t
 
@@ -289,7 +291,7 @@ let check_consistency filename crcs =
       (fun (name, crc) -> Consistbl.check crc_units name crc filename)
       crcs
   with Consistbl.Inconsistency(name, source, auth) ->
-    raise(Error(Inconsistent_import(name, auth, source)))
+    error (Inconsistent_import(name, auth, source))
 
 (* Reading persistent structures from .cmi files *)
 
@@ -310,12 +312,12 @@ let read_pers_struct modname filename = (
                ps_filename = filename;
                ps_flags = flags } in
     if ps.ps_name <> modname then
-      raise(Error(Illegal_renaming(modname, ps.ps_name, filename)));
+      error (Illegal_renaming(modname, ps.ps_name, filename));
     check_consistency filename ps.ps_crcs;
     List.iter
       (function Rectypes ->
         if not !Clflags.recursive_types then
-          raise(Error(Need_recursive_types(ps.ps_name, !current_unit))))
+          error (Need_recursive_types(ps.ps_name, !current_unit)))
       ps.ps_flags;
     Hashtbl.add persistent_structures modname (Some ps);
     ps
@@ -1603,3 +1605,11 @@ let report_error ppf = function
       fprintf ppf
         "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"
         export import "The compilation flag -rectypes is required"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
+

typing/includemod.ml

@@ -486,3 +486,14 @@ let report_error ppf errs =
   in
   let print_errs ppf = List.iter (include_err' ppf) in
   fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
+
+
+(* We could do a better job to split the individual error items
+   as sub-messages of the main interface mismatch on the whole unit. *)
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
+

typing/typeclass.ml

@@ -1784,3 +1784,12 @@ let report_error env ppf = function
 
 let report_error env ppf err =
   Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | _ ->
+        None
+    )

typing/typecore.ml

@@ -3777,5 +3777,14 @@ let report_error env ppf = function
 let report_error env ppf err =
   wrap_printing_env env (fun () -> report_error env ppf err)
 
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | _ ->
+        None
+    )
+
 let () =
   Env.add_delayed_check_forward := add_delayed_check

typing/typecore.mli

@@ -111,6 +111,7 @@ type error =
 exception Error of Location.t * Env.t * error
 
 val report_error: Env.t -> formatter -> error -> unit
+ (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref

typing/typedecl.ml

@@ -1344,3 +1344,12 @@ let report_error ppf = function
         "cannot be checked"
   | Exception_constructor_with_result ->
       fprintf ppf "Exception constructors cannot specify a result type"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )

typing/typemod.ml

@@ -1569,3 +1569,12 @@ let report_error ppf = function
 
 let report_error env ppf err =
   Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | _ ->
+        None
+    )

typing/typetexp.ml

@@ -824,3 +824,13 @@ let report_error env ppf = function
       fprintf ppf "Illegal recursive module reference"
   | Extension s ->
       fprintf ppf "Uninterpreted extension '%s'." s
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | _ ->
+        None
+    )
+