Cherry-picking commit 14093 from trunk.

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

driver/errors.ml

@@ -39,8 +39,6 @@ let report_error ppf exn =
       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) ->
@@ -76,6 +74,10 @@ let report_error ppf exn =
   | 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
+  | x ->
+      match Location.error_of_exn x with
+      | Some err -> Location.report_error ppf err
+      | None -> fprintf ppf "@]"; raise x
+  in
 
   fprintf ppf "@[%a@]@." report exn

driver/opterrors.ml

@@ -38,8 +38,6 @@ let report_error ppf exn =
       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) ->
@@ -78,6 +76,10 @@ let report_error ppf exn =
   | 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
+  | x ->
+      match Location.error_of_exn x with
+      | Some err -> Location.report_error ppf err
+      | None -> fprintf ppf "@]"; raise x
+  in
 
   fprintf ppf "@[%a@]@." report exn

ocamldoc/odoc_analyse.ml

@@ -124,8 +124,6 @@ let process_error exn =
       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) ->
@@ -148,10 +146,13 @@ let process_error exn =
       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)
+      match Location.error_of_exn x with
+      | Some err -> Location.report_error ppf err
+      | None ->
+          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
 

parsing/location.ml

@@ -286,3 +286,41 @@ type 'a loc = {
 
 let mkloc txt loc = { txt ; loc }
 let mknoloc txt = mkloc txt none
+
+
+type error =
+  {
+    loc: t;
+    msg: string;
+    sub: error list;
+  }
+
+let error ?(loc = none) ?(sub = []) msg = {loc; msg; sub}
+
+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} =
+  print ppf loc;
+  Format.pp_print_string ppf msg;
+  List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub
+
+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

parsing/location.mli

@@ -75,3 +75,29 @@ val show_filename: string -> string
 
 
 val absname: bool ref
+
+
+(* Support for located errors *)
+
+type error =
+  {
+    loc: t;
+    msg: string;
+    sub: error list;
+  }
+
+val error: ?loc:t -> ?sub:error list -> string -> error
+
+val error_of_printer: t -> (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

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