Refactor Report_error module
- make `printer` type abstract - make a builtin printer Signed-off-by: Etienne Millon <me@emillon.org>
This commit is contained in:
Etienne Millon
parent
7cd183877e
commit
7c0a9a84ba
|
|
@ -1234,11 +1234,6 @@ let () =
|
|||
(Some t.pd_loc, None)
|
||||
| _ -> (None, None)
|
||||
in
|
||||
Some
|
||||
{ Report_error.
|
||||
loc
|
||||
; hint
|
||||
; pp = (fun ppf -> report_lib_error ppf e)
|
||||
; backtrace = false
|
||||
}
|
||||
let pp ppf = report_lib_error ppf e in
|
||||
Some (Report_error.make_printer ?loc ?hint pp)
|
||||
| _ -> None)
|
||||
|
|
|
|||
|
|
@ -10,15 +10,75 @@ type printer =
|
|||
; backtrace : bool
|
||||
}
|
||||
|
||||
let p =
|
||||
{ loc = None
|
||||
; pp = ignore
|
||||
; hint = None
|
||||
; backtrace = false
|
||||
let make_printer ?(backtrace=false) ?hint ?loc pp =
|
||||
{ loc
|
||||
; pp
|
||||
; hint
|
||||
; backtrace
|
||||
}
|
||||
|
||||
let reporters = ref []
|
||||
let register f = reporters := f :: !reporters
|
||||
let builtin_printer = function
|
||||
| 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 ->
|
||||
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
|
||||
}
|
||||
| None -> exn_printer exn
|
||||
|
||||
let reported = ref String.Set.empty
|
||||
|
||||
|
|
|
|||
|
|
@ -11,12 +11,14 @@ open! Stdune
|
|||
We cache what is actually printed to the screen. *)
|
||||
val report : exn -> unit
|
||||
|
||||
type printer =
|
||||
{ loc : Loc.t option
|
||||
; pp : Format.formatter -> unit
|
||||
; hint : string option
|
||||
; backtrace : bool
|
||||
}
|
||||
type printer
|
||||
|
||||
val make_printer :
|
||||
?backtrace:bool ->
|
||||
?hint:string ->
|
||||
?loc:Loc.t ->
|
||||
(Format.formatter -> unit) ->
|
||||
printer
|
||||
|
||||
(** Register an error reporter. *)
|
||||
val register : (exn -> printer option) -> unit
|
||||
|
|
|
|||
|
|
@ -33,15 +33,12 @@ module Of_sexp = struct
|
|||
Report_error.register
|
||||
(function
|
||||
| Parens_no_longer_necessary loc ->
|
||||
Some
|
||||
{ loc = Some loc
|
||||
; hint = None
|
||||
; backtrace = false
|
||||
; pp = fun ppf ->
|
||||
Format.fprintf ppf
|
||||
"These parentheses are no longer necessary with dune, \
|
||||
please remove them.@\n"
|
||||
}
|
||||
let pp ppf =
|
||||
Format.fprintf ppf
|
||||
"These parentheses are no longer necessary with dune, \
|
||||
please remove them.@\n"
|
||||
in
|
||||
Some (Report_error.make_printer ~loc pp)
|
||||
| _ -> None)
|
||||
|
||||
let switch_file_kind ~jbuild ~dune =
|
||||
|
|
|
|||
Loading…
Reference in New Issue