From 179dbd78fe82436cc55776f3b239b2e6d5110e28 Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <rudi.grinberg@gmail.com>
Date: Fri, 4 Jan 2019 16:35:23 -0500
Subject: [PATCH] Improve printing of fatal errors

Currently, some fatal errors aren't printed because things fail before the
printers are all registered. This PR registers the printers as early as
possible. This way, all exceptions are properly printed.

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
---
 src/errors.ml      | 5 ++---
 src/stdune/exn.ml  | 6 ++++++
 src/stdune/loc.mli | 2 ++
 src/stdune/loc0.ml | 7 +++++++
 4 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/src/errors.ml b/src/errors.ml
index 198553c307c5..40da4dd5f258 100644
--- a/src/errors.ml
+++ b/src/errors.ml
@@ -118,9 +118,8 @@ let print ppf loc =
              print_ellipsis padding_width;
              print_lines last_shown_lines padding_width)
   in
-  Format.fprintf ppf
-    "@{<loc>File \"%s\", line %d, characters %d-%d:@}@\n%a"
-    start.pos_fname start.pos_lnum start_c stop_c
+  Format.fprintf ppf "%a%a"
+    Loc.print loc
     pp_file_excerpt ()
 
 (* This is ugly *)
diff --git a/src/stdune/exn.ml b/src/stdune/exn.ml
index 246075c19975..29476b060d61 100644
--- a/src/stdune/exn.ml
+++ b/src/stdune/exn.ml
@@ -10,6 +10,12 @@ external raise         : exn -> _ = "%raise"
 external raise_notrace : exn -> _ = "%raise_notrace"
 external reraise       : exn -> _ = "%reraise"
 
+let () =
+  Printexc.register_printer (function
+    | Code_error s -> Some (Format.asprintf "%a" Sexp.pp s)
+    | Loc_error (loc, s) -> Some (Format.asprintf "%a%s" Loc0.print loc s)
+    | _ -> None)
+
 let fatalf ?loc fmt =
   Format.ksprintf (fun s ->
     match loc with
diff --git a/src/stdune/loc.mli b/src/stdune/loc.mli
index 0c31f2d006f7..4f7c7a38e963 100644
--- a/src/stdune/loc.mli
+++ b/src/stdune/loc.mli
@@ -21,3 +21,5 @@ val of_pos : (string * int * int * int) -> t
 
 val to_file_colon_line : t -> string
 val pp_file_colon_line : Format.formatter -> t -> unit
+
+val print : Format.formatter -> t -> unit
diff --git a/src/stdune/loc0.ml b/src/stdune/loc0.ml
index 91e3160be90d..e3e2df2b79cd 100644
--- a/src/stdune/loc0.ml
+++ b/src/stdune/loc0.ml
@@ -2,3 +2,10 @@ type t =
   { start : Lexing.position
   ; stop  : Lexing.position
   }
+
+let print ppf { start; stop } =
+  let start_c = start.pos_cnum - start.pos_bol in
+  let stop_c  = stop.pos_cnum  - start.pos_bol in
+  Format.fprintf ppf
+    "@{<loc>File \"%s\", line %d, characters %d-%d:@}@\n"
+    start.pos_fname start.pos_lnum start_c stop_c