1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
let show_backend_exceptions = ref true
type with_bt = exn * Printexc.raw_backtrace
type err = ..
type context = {
steps : string list;
}
exception Io of err * context
exception Multiple of (exn * Printexc.raw_backtrace) list
type err += Multiple_io of (err * context * Printexc.raw_backtrace) list
exception Cancelled of exn
let create err = Io (err, { steps = [] })
let empty_backtrace = Printexc.get_callstack 0
let add_context ex fmt =
fmt |> Fmt.kstr @@ fun msg ->
match ex with
| Io (code, t) -> Io (code, {steps = msg :: t.steps})
| ex -> ex
let reraise_with_context ex bt fmt =
fmt |> Fmt.kstr @@ fun msg ->
match ex with
| Io (code, t) ->
let context = { steps = msg :: t.steps } in
Printexc.raise_with_backtrace (Io (code, context)) bt
| _ ->
Printexc.raise_with_backtrace ex bt
let err_printers : (Format.formatter -> err -> bool) list ref = ref []
let register_pp fn =
err_printers := fn :: !err_printers
let break f _ = Format.pp_print_custom_break f
~fits:(",", 1, "")
~breaks:(",", 2, "")
let pp_err f x =
let rec aux = function
| [] -> Fmt.string f "?"
| pp :: pps -> if not (pp f x) then aux pps
in
aux !err_printers
let pp_with_context f (code, context) =
Fmt.pf f "%a%a" pp_err code
Fmt.(list ~sep:nop (break ++ string)) (List.rev context.steps)
let pp_with_bt f (code, context, bt) =
match String.trim (Printexc.raw_backtrace_to_string bt) with
| "" ->
Fmt.pf f "- @[<hov>%a@]"
pp_with_context (code, context)
| bt ->
Fmt.pf f "- @[<v>%a@,%a@]"
pp_with_context (code, context)
Fmt.lines bt
let pp f = function
| Io (code, t) ->
Fmt.pf f "Eio.Io %a%a"
pp_err code
Fmt.(list ~sep:nop (break ++ string)) (List.rev t.steps)
| ex ->
Fmt.string f (Printexc.to_string ex)
let pp_multiple f exns =
let pp_with_bt f (ex, bt) =
match String.trim (Printexc.raw_backtrace_to_string bt) with
| "" ->
Fmt.pf f "- @[<v>%a@]" pp ex
| bt ->
Fmt.pf f "- @[<v>%a@,%a@]"
pp ex
Fmt.lines bt
in
Fmt.pf f "@[<v>Multiple exceptions:@,%a@]"
(Fmt.(list ~sep:cut) pp_with_bt) (List.rev exns)
let () =
Printexc.register_printer @@ function
| Io _ as ex -> Some (Fmt.str "@[<v>%a@]" pp ex)
| Multiple exns -> Some (Fmt.str "%a" pp_multiple exns)
| Cancelled ex -> Some ("Cancelled: " ^ Printexc.to_string ex)
| _ -> None
let combine e1 e2 =
if fst e1 == fst e2 then e1
else match e1, e2 with
| (Cancelled _, _), e
| e, (Cancelled _, _) -> e
| (Io (c1, t1), bt1), (Io (c2, t2), bt2) -> create (Multiple_io [(c1, t1, bt1); (c2, t2, bt2)]), empty_backtrace
| (Multiple exs, bt1), e2 -> Multiple (e2 :: exs), bt1
| e1, e2 -> Multiple [e2; e1], empty_backtrace
module Backend = struct
type t = ..
let show = ref true
let printers : (Format.formatter -> t -> bool) list ref = ref []
let register_pp fn =
printers := fn :: !printers
let pp f x =
if !show then (
let rec aux = function
| [] -> Fmt.string f "?"
| pp :: pps -> if not (pp f x) then aux pps
in
aux !printers
) else Fmt.string f "_"
end
type err += X of Backend.t
let () =
register_pp (fun f -> function
| Multiple_io errs -> Fmt.pf f "Multiple_io@\n%a" (Fmt.(list ~sep:cut) pp_with_bt) errs; true
| X ex -> Backend.pp f ex; true
| _ -> false
)