Branch for experimenting with a new way to define and use error printers.

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

10 files changed, 12 insertions, 91 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index a5355b2f5..f2ed6fd49 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 2ebbe5111..05cd295f4 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index ac43afab3..bb4ebc652 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/driver/errors.ml b/driver/errors.ml
index 5faa274da..14a1a23cb 100644
--- a/driver/errors.ml
+++ b/driver/errors.ml
@@ -39,6 +39,8 @@ 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) ->
@@ -74,10 +76,6 @@ 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 ->
-      match Location.error_of_exn x with
-      | Some err -> Location.report_error ppf err
-      | None -> fprintf ppf "@]"; raise x
-  in
+  | x -> fprintf ppf "@]"; raise x in
 
   fprintf ppf "@[%a@]@." report exn
diff --git a/driver/opterrors.ml b/driver/opterrors.ml
index 965844c92..56660cdb1 100644
--- a/driver/opterrors.ml
+++ b/driver/opterrors.ml
@@ -38,6 +38,8 @@ 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,10 +78,6 @@ 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 ->
-      match Location.error_of_exn x with
-      | Some err -> Location.report_error ppf err
-      | None -> fprintf ppf "@]"; raise x
-  in
+  | x -> fprintf ppf "@]"; raise x in
 
   fprintf ppf "@[%a@]@." report exn
diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml
index 846724c06..19621cb5e 100644
--- a/ocamldoc/odoc_analyse.ml
+++ b/ocamldoc/odoc_analyse.ml
@@ -124,6 +124,8 @@ 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) ->
@@ -146,13 +148,10 @@ let process_error exn =
       Location.print_error_cur_file ppf;
       fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
   | 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)
+      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
 
diff --git a/parsing/location.ml b/parsing/location.ml
index 14d2f9513..d3f89f440 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -286,41 +286,3 @@ 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
diff --git a/parsing/location.mli b/parsing/location.mli
index a465b8a1f..bae909020 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -75,29 +75,3 @@ 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
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 9b6567710..98c6bdf89 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -3778,13 +3778,4 @@ 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
diff --git a/typing/typecore.mli b/typing/typecore.mli
index edb8a53b8..71d75aa1b 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -111,7 +111,6 @@ 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