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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
open Std
let time = ref 0.0
let delta_time () = Sys.time () -. !time
let destination = ref None
let selected_sections = ref None
let is_section_enabled section =
match !selected_sections with
| None -> true
| Some sections -> Hashtbl.mem sections section
let output_section oc section title =
Printf.fprintf oc "# %2.2f %s - %s\n" (delta_time ()) section title
let log_flush () =
match !destination with
| None -> ()
| Some oc -> flush oc
let log ~section ~title fmt =
match !destination with
| Some oc when is_section_enabled section ->
Printf.ksprintf
(fun str ->
output_section oc section title;
if str <> "" then (
output_string oc str;
if str.[String.length str - 1] <> '\n' then output_char oc '\n'))
fmt
| None | Some _ -> Printf.ifprintf () fmt
let fmt_buffer = Buffer.create 128
let fmt_handle = Format.formatter_of_buffer fmt_buffer
let fmt () f =
Buffer.reset fmt_buffer;
begin
match f fmt_handle with
| () -> ()
| exception exn ->
Format.fprintf fmt_handle "@\nException: %s" (Printexc.to_string exn)
end;
Format.pp_print_flush fmt_handle ();
let msg = Buffer.contents fmt_buffer in
Buffer.reset fmt_buffer;
msg
let json () f =
match f () with
| json -> !Json.pretty_to_string json
| exception exn -> Printf.sprintf "Exception: %s" (Printexc.to_string exn)
let exn () exn = Printexc.to_string exn
type notification = { section : string; msg : string }
let notifications : notification list ref option ref = ref None
let notify ~section =
let tell msg =
log ~section ~title:"notify" "%s" msg;
match !notifications with
| None -> ()
| Some r -> r := { section; msg } :: !r
in
Printf.ksprintf tell
let with_notifications r f = let_ref notifications (Some r) f
let with_sections sections f =
let sections =
match sections with
| [] -> None
| sections ->
let table = Hashtbl.create (List.length sections) in
List.iter sections ~f:(fun section -> Hashtbl.replace table section ());
Some table
in
let sections0 = !selected_sections in
selected_sections := sections;
match f () with
| result ->
selected_sections := sections0;
result
| exception exn ->
selected_sections := sections0;
reraise exn
let with_log_file file ?(sections = []) f =
match file with
| None -> with_sections sections f
| Some file -> (
log_flush ();
let destination', release =
match file with
| "" -> (None, ignore)
| "-" -> (Some stderr, ignore)
| filename -> (
match open_out filename with
| exception exn ->
Printf.eprintf "cannot open %S for logging: %s" filename
(Printexc.to_string exn);
(None, ignore)
| oc -> (Some oc, fun () -> close_out_noerr oc))
in
let destination0 = !destination in
destination := destination';
let release () =
log_flush ();
destination := destination0;
release ()
in
match with_sections sections f with
| v ->
release ();
v
| exception exn ->
release ();
reraise exn)
type 'a printf = title:string -> ('a, unit, string, unit) format4 -> 'a
type logger = { log : 'a. 'a printf }
let for_section section = { log = (fun ~title fmt -> log ~section ~title fmt) }