Refactor Report_error module

- make `printer` type abstract
- make a builtin printer

Signed-off-by: Etienne Millon <me@emillon.org>

src/lib.ml

@@ -1234,11 +1234,6 @@ let () =
           (Some t.pd_loc, None)
         | _ -> (None, None)
       in
-      Some
+      let pp ppf = report_lib_error ppf e in
-        { Report_error.
+      Some (Report_error.make_printer ?loc ?hint pp)
-          loc
-        ; hint
-        ; pp = (fun ppf -> report_lib_error ppf e)
-        ; backtrace = false
-        }
     | _ -> None)

src/report_error.ml

@@ -10,15 +10,75 @@ type printer =
   ; backtrace : bool
   }
 
-let p =
+let make_printer ?(backtrace=false) ?hint ?loc pp =
-  { loc       = None
+  { loc
-  ; pp        = ignore
+  ; pp
-  ; hint      = None
+  ; hint
-  ; backtrace = false
+  ; backtrace
   }
 
-let reporters = ref []
+let builtin_printer = function
-let register f = reporters := f :: !reporters
+  | Dsexp.Of_sexp.Of_sexp (loc, msg, hint') ->
+    let loc =
+      { loc with
+        start = { loc.start with pos_fname = !map_fname loc.start.pos_fname }
+      }
+    in
+    let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s%s\n" msg
+                   (match hint' with
+                    | None -> ""
+                    | Some { Dsexp.Of_sexp. on; candidates } ->
+                      hint on candidates)
+    in
+    Some (make_printer ~loc pp)
+  | Exn.Loc_error (loc, msg) ->
+    let loc =
+      { loc with
+        start = { loc.start with pos_fname = !map_fname loc.start.pos_fname }
+      }
+    in
+    let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s\n" msg in
+    Some (make_printer ~loc pp)
+  | Dsexp.Parse_error e ->
+    let loc = Dsexp.Parse_error.loc     e in
+    let msg = Dsexp.Parse_error.message e in
+    let map_pos (pos : Lexing.position) =
+      { pos with pos_fname = !map_fname pos.pos_fname }
+    in
+    let loc : Loc.t =
+      { start = map_pos loc.start
+      ; stop  = map_pos loc.stop
+      }
+    in
+    let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s\n" msg in
+    Some (make_printer ~loc pp)
+  | Exn.Fatal_error msg ->
+    let pp ppf =
+      if msg.[String.length msg - 1] = '\n' then
+        Format.fprintf ppf "%s" msg
+      else
+        Format.fprintf ppf "%s\n" (String.capitalize msg)
+    in
+    Some (make_printer pp)
+  | Stdune.Exn.Code_error sexp ->
+    let pp = fun ppf ->
+          Format.fprintf ppf "@{<error>Internal error, please report upstream \
+                              including the contents of _build/log.@}\n\
+                              Description:%a\n"
+            Sexp.pp sexp
+    in
+    Some (make_printer ~backtrace:true pp)
+  | Unix.Unix_error (err, func, fname) ->
+    let pp ppf =
+      Format.fprintf ppf "@{<error>Error@}: %s: %s: %s\n"
+        func fname (Unix.error_message err)
+    in
+    Some (make_printer pp)
+  | _ -> None
+
+let printers = ref [builtin_printer]
+
+let register f = printers := f :: !printers
 
 let i_must_not_segfault =
   let x = lazy (at_exit (fun () ->
@@ -31,79 +91,24 @@ cases are handled there will be nothing.  Only I will remain."))
   in
   fun () -> Lazy.force x
 
+let find_printer exn =
+  List.find_map !printers ~f:(fun f -> f exn)
+
+let exn_printer exn =
+  let pp ppf =
+    let s = Printexc.to_string exn in
+    if String.is_prefix s ~prefix:"File \"" then
+      Format.fprintf ppf "%s\n" s
+    else
+      Format.fprintf ppf "@{<error>Error@}: exception %s\n" s
+  in
+  make_printer ~backtrace:true pp
+
 (* Firt return value is [true] if the backtrace was printed *)
 let report_with_backtrace exn =
-  match List.find_map !reporters ~f:(fun f -> f exn) with
+  match find_printer exn with
   | Some p -> p
-  | None ->
+  | None -> exn_printer exn
-    match exn with
-    | Exn.Loc_error (loc, msg) ->
-      let loc =
-        { loc with
-          start = { loc.start with pos_fname = !map_fname loc.start.pos_fname }
-        }
-      in
-      let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s\n" msg in
-      { p with loc = Some loc; pp }
-    | Dsexp.Of_sexp.Of_sexp (loc, msg, hint') ->
-      let loc =
-        { loc with
-          start = { loc.start with pos_fname = !map_fname loc.start.pos_fname }
-        }
-      in
-      let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s%s\n" msg
-                     (match hint' with
-                      | None -> ""
-                      | Some { Dsexp.Of_sexp. on; candidates } ->
-                        hint on candidates)
-      in
-      { p with loc = Some loc; pp }
-    | Dsexp.Parse_error e ->
-      let loc = Dsexp.Parse_error.loc     e in
-      let msg = Dsexp.Parse_error.message e in
-      let map_pos (pos : Lexing.position) =
-        { pos with pos_fname = !map_fname pos.pos_fname }
-      in
-      let loc : Loc.t =
-        { start = map_pos loc.start
-        ; stop  = map_pos loc.stop
-        }
-      in
-      { p with
-        loc = Some loc
-      ; pp  = fun ppf -> Format.fprintf ppf "@{<error>Error@}: %s\n" msg
-      }
-    | Exn.Fatal_error msg ->
-      { p with pp = fun ppf ->
-          if msg.[String.length msg - 1] = '\n' then
-            Format.fprintf ppf "%s" msg
-          else
-            Format.fprintf ppf "%s\n" (String.capitalize msg)
-      }
-    | Stdune.Exn.Code_error sexp ->
-      { p with
-        backtrace = true
-      ; pp = fun ppf ->
-          Format.fprintf ppf "@{<error>Internal error, please report upstream \
-                              including the contents of _build/log.@}\n\
-                              Description:%a\n"
-            Sexp.pp sexp
-      }
-    | Unix.Unix_error (err, func, fname) ->
-      { p with pp = fun ppf ->
-          Format.fprintf ppf "@{<error>Error@}: %s: %s: %s\n"
-            func fname (Unix.error_message err)
-      }
-    | _ ->
-      { p with
-        backtrace = true
-      ; pp = fun ppf ->
-          let s = Printexc.to_string exn in
-          if String.is_prefix s ~prefix:"File \"" then
-            Format.fprintf ppf "%s\n" s
-          else
-            Format.fprintf ppf "@{<error>Error@}: exception %s\n" s
-      }
 
 let reported = ref String.Set.empty
 

src/report_error.mli

@@ -11,12 +11,14 @@ open! Stdune
     We cache what is actually printed to the screen.  *)
 val report : exn -> unit
 
-type printer =
+type printer
-  { loc       : Loc.t option
+
-  ; pp        : Format.formatter -> unit
+val make_printer :
-  ; hint      : string option
+  ?backtrace:bool ->
-  ; backtrace : bool
+  ?hint:string ->
-  }
+  ?loc:Loc.t ->
+  (Format.formatter -> unit) ->
+  printer
 
 (** Register an error reporter. *)
 val register : (exn -> printer option) -> unit

src/stanza.ml

@@ -33,15 +33,12 @@ module Of_sexp = struct
     Report_error.register
       (function
         | Parens_no_longer_necessary loc ->
-          Some
+          let pp ppf =
-            { loc = Some loc
+            Format.fprintf ppf
-            ; hint = None
+              "These parentheses are no longer necessary with dune, \
-            ; backtrace = false
+               please remove them.@\n"
-            ; pp = fun ppf ->
+          in
-                Format.fprintf ppf
+          Some (Report_error.make_printer ~loc pp)
-                  "These parentheses are no longer necessary with dune, \
-                   please remove them.@\n"
-            }
         | _ -> None)
 
   let switch_file_kind ~jbuild ~dune =