Improve printing of fatal errors

src/errors.ml

@@ -38,90 +38,9 @@ let fail_opt t fmt =
   | None -> die fmt
   | Some t -> fail t fmt
 
-let file_line path n =
-  Io.with_file_in ~binary:false path
-    ~f:(fun ic ->
-      for _ = 1 to n - 1 do
-        ignore (input_line ic)
-      done;
-      input_line ic
-    )
-
-let file_lines path ~start ~stop =
-  Io.with_file_in ~binary:true path
-    ~f:(fun ic ->
-      let rec aux acc lnum =
-        if lnum > stop then
-          List.rev acc
-        else if lnum < start then
-          (ignore (input_line ic);
-           aux acc (lnum + 1))
-        else
-          let line = input_line ic in
-          aux ((string_of_int lnum, line) :: acc) (lnum + 1)
-      in
-      aux [] 1
-    )
-
-let pp_line padding_width pp (lnum, l) =
-  Format.fprintf pp "%*s | %s\n" padding_width lnum l
-
 let print ppf loc =
-  let { Loc.start; stop } = loc in
-  let start_c = start.pos_cnum - start.pos_bol in
-  let stop_c  = stop.pos_cnum  - start.pos_bol in
-  let num_lines = stop.pos_lnum - start.pos_lnum in
-  let pp_file_excerpt pp () =
-    let whole_file = start_c = 0 && stop_c = 0 in
-    if not whole_file then
-      let path = Path.of_string start.pos_fname in
-      if Path.exists path then
-        let line_num = start.pos_lnum in
-        let line_num_str = string_of_int line_num in
-        let padding_width = String.length line_num_str in
-        let line = file_line path line_num in
-        if stop_c <= String.length line then
-          let len = stop_c - start_c in
-          Format.fprintf pp "%a%*s\n"
-            (pp_line padding_width) (line_num_str, line)
-            (stop_c + padding_width + 3)
-            (String.make len '^')
-        else
-          let get_padding lines =
-            let (lnum, _) = Option.value_exn (List.last lines) in
-            String.length lnum
-          in
-          let print_ellipsis padding_width =
-            (* We add 2 to the width of max line to account for
-               the extra space and the `|` character at the end
-               of a line number *)
-            let line = String.make (padding_width + 2) '.' in
-            Format.fprintf pp "%s\n" line
-          in
-          let print_lines lines padding_width =
-            List.iter ~f:(fun (lnum, l) ->
-              pp_line padding_width pp (lnum, l)) lines;
-          in
-          if num_lines <= max_lines_to_print_in_full then
-            let lines = file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in
-            print_lines lines (get_padding lines)
-          else
-            (* We need to send the padding width from the last four lines
-               so the two blocks of lines align if they have different number
-               of digits in their line numbers *)
-            let first_shown_lines = file_lines path ~start:(start.pos_lnum)
-                               ~stop:(start.pos_lnum + context_lines) in
-            let last_shown_lines = file_lines path ~start:(stop.pos_lnum - context_lines)
-                              ~stop:(stop.pos_lnum) in
-            let padding_width = get_padding last_shown_lines in
-            (print_lines first_shown_lines padding_width;
-             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
-    pp_file_excerpt ()
+  Format.fprintf ppf "%a%a" Loc.print loc
+    (Loc.pp_file_excerpt ~context_lines ~max_lines_to_print_in_full) loc
 
 (* This is ugly *)
 let printer = ref (Printf.eprintf "%s%!")

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

src/stdune/io.ml

@@ -28,8 +28,16 @@ module type S = sig
   val open_in  : ?binary:bool (* default true *) -> path -> in_channel
   val open_out : ?binary:bool (* default true *) -> path -> out_channel
 
-  val with_file_in  : ?binary:bool (* default true *) -> path -> f:(in_channel -> 'a) -> 'a
-  val with_file_out : ?binary:bool (* default true *) -> path -> f:(out_channel -> 'a) -> 'a
+  val with_file_in
+    : ?binary:bool (* default true *)
+    -> path
+    -> f:(in_channel -> 'a)
+    -> 'a
+  val with_file_out
+    : ?binary:bool (* default true *)
+    -> path
+    -> f:(out_channel -> 'a)
+    -> 'a
 
   val with_lexbuf_from_file : path -> f:(Lexing.lexbuf -> 'a) -> 'a
   val lines_of_file : path -> string list
@@ -42,6 +50,9 @@ module type S = sig
 
   val write_lines : path -> string list -> unit
   val copy_file : ?chmod:(int -> int) -> src:path -> dst:path -> unit -> unit
+
+  val file_line : path -> int -> string
+  val file_lines : path -> start:int -> stop:int -> (string * string) list
 end
 
 module Make (Path : sig
@@ -152,6 +163,31 @@ module Make (Path : sig
         ~finally:close_out
         ~f:(fun oc ->
           copy_channels ic oc))
+
+
+  let file_line path n =
+    with_file_in ~binary:false path
+      ~f:(fun ic ->
+        for _ = 1 to n - 1 do
+          ignore (input_line ic)
+        done;
+        input_line ic
+      )
+
+  let file_lines path ~start ~stop =
+    with_file_in ~binary:true path
+      ~f:(fun ic ->
+        let rec aux acc lnum =
+          if lnum > stop then
+            List.rev acc
+          else if lnum < start then
+            (ignore (input_line ic);
+             aux acc (lnum + 1))
+          else
+            let line = input_line ic in
+            aux ((string_of_int lnum, line) :: acc) (lnum + 1)
+        in
+        aux [] 1)
 end
 
 include Make(Path)

src/stdune/io.mli

@@ -15,8 +15,16 @@ module type S = sig
   val open_in  : ?binary:bool (* default true *) -> path -> in_channel
   val open_out : ?binary:bool (* default true *) -> path -> out_channel
 
-  val with_file_in  : ?binary:bool (* default true *) -> path -> f:(in_channel -> 'a) -> 'a
-  val with_file_out : ?binary:bool (* default true *) -> path -> f:(out_channel -> 'a) -> 'a
+  val with_file_in
+    : ?binary:bool (* default true *)
+    -> path
+    -> f:(in_channel -> 'a)
+    -> 'a
+  val with_file_out
+    : ?binary:bool (* default true *)
+    -> path
+    -> f:(out_channel -> 'a)
+    -> 'a
 
   val with_lexbuf_from_file : path -> f:(Lexing.lexbuf -> 'a) -> 'a
   val lines_of_file : path -> string list
@@ -29,6 +37,9 @@ module type S = sig
 
   val write_lines : path -> string list -> unit
   val copy_file : ?chmod:(int -> int) -> src:path -> dst:path -> unit -> unit
+
+  val file_line : path -> int -> string
+  val file_lines : path -> start:int -> stop:int -> (string * string) list
 end
 
 include S with type path = Path.t

src/stdune/loc.ml

@@ -83,3 +83,59 @@ let to_file_colon_line t =
 
 let pp_file_colon_line ppf t =
   Format.pp_print_string ppf (to_file_colon_line t)
+
+let pp_line padding_width pp (lnum, l) =
+  Format.fprintf pp "%*s | %s\n" padding_width lnum l
+
+let pp_file_excerpt ~context_lines ~max_lines_to_print_in_full
+      pp { start; stop } =
+  let start_c = start.pos_cnum - start.pos_bol in
+  let stop_c  = stop.pos_cnum  - start.pos_bol in
+  let num_lines = stop.pos_lnum - start.pos_lnum in
+  let whole_file = start_c = 0 && stop_c = 0 in
+  if not whole_file then
+    let path = Path.of_string start.pos_fname in
+    if Path.exists path then
+      let line_num = start.pos_lnum in
+      let line_num_str = string_of_int line_num in
+      let padding_width = String.length line_num_str in
+      let line = Io.file_line path line_num in
+      if stop_c <= String.length line then
+        let len = stop_c - start_c in
+        Format.fprintf pp "%a%*s\n"
+          (pp_line padding_width) (line_num_str, line)
+          (stop_c + padding_width + 3)
+          (String.make len '^')
+      else
+        let get_padding lines =
+          let (lnum, _) = Option.value_exn (List.last lines) in
+          String.length lnum
+        in
+        let print_ellipsis padding_width =
+          (* We add 2 to the width of max line to account for the extra space
+             and the `|` character at the end of a line number *)
+          let line = String.make (padding_width + 2) '.' in
+          Format.fprintf pp "%s\n" line
+        in
+        let print_lines lines padding_width =
+          List.iter ~f:(fun (lnum, l) ->
+            pp_line padding_width pp (lnum, l)) lines;
+        in
+        if num_lines <= max_lines_to_print_in_full then
+          let lines =
+            Io.file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in
+          print_lines lines (get_padding lines)
+        else
+          (* We need to send the padding width from the last four lines so the
+             two blocks of lines align if they have different number of digits
+             in their line numbers *)
+          let first_shown_lines =
+            Io.file_lines path ~start:(start.pos_lnum)
+              ~stop:(start.pos_lnum + context_lines) in
+          let last_shown_lines =
+            Io.file_lines path ~start:(stop.pos_lnum - context_lines)
+              ~stop:(stop.pos_lnum) in
+          let padding_width = get_padding last_shown_lines in
+          (print_lines first_shown_lines padding_width;
+           print_ellipsis padding_width;
+           print_lines last_shown_lines padding_width)

src/stdune/loc.mli

@@ -21,3 +21,12 @@ 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
+
+val pp_file_excerpt
+  : context_lines:int
+  -> max_lines_to_print_in_full:int
+  -> Format.formatter
+  -> t
+  -> unit

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