forked from colinbenner/ocaml-llvm
-
Notifications
You must be signed in to change notification settings - Fork 16
/
display.ml
386 lines (377 loc) · 11.7 KB
/
display.ml
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
(***********************************************************************)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Original author: Berke Durak *)
(* Display *)
open My_std;;
open My_unix;;
let fp = Printf.fprintf;;
(*** ANSI *)
module ANSI =
struct
let up oc n = fp oc "\027[%dA" n;;
let clear_to_eol oc () = fp oc "\027[K";;
let bol oc () = fp oc "\r";;
let get_columns () =
try
int_of_string (String.chomp (My_unix.run_and_read "tput cols"))
with
| Failure _ -> 80
end
;;
(* ***)
(*** tagline_description *)
type tagline_description = (string * char) list;;
(* ***)
(*** sophisticated_display *)
type sophisticated_display = {
ds_channel : out_channel; (** Channel for writing *)
ds_start_time : float; (** When was compilation started *)
mutable ds_last_update : float; (** When was the display last updated *)
mutable ds_last_target : string; (** Last target built *)
mutable ds_last_cached : bool; (** Was the last target cached or really built ? *)
mutable ds_last_tags : Tags.t; (** Tags of the last command *)
mutable ds_changed : bool; (** Does the tag line need recomputing ? *)
ds_update_interval : float; (** Minimum interval between updates *)
ds_columns : int; (** Number of columns in dssplay *)
mutable ds_jobs : int; (** Number of jobs launched or cached *)
mutable ds_jobs_cached : int; (** Number of jobs cached *)
ds_tagline : string; (** Current tagline *)
mutable ds_seen_tags : Tags.t; (** Tags that we have encountered *)
ds_pathname_length : int; (** How much space for displaying pathnames ? *)
ds_tld : tagline_description; (** Description for the tagline *)
};;
(* ***)
(*** display_line, display *)
type display_line =
| Classic
| Sophisticated of sophisticated_display
type display = {
di_log_level : int;
mutable di_log_channel : (Format.formatter * out_channel) option;
di_channel : out_channel;
di_formatter : Format.formatter;
di_display_line : display_line;
mutable di_finished : bool;
}
;;
(* ***)
(*** various defaults *)
let default_update_interval = 0.05;;
let default_tagline_description = [
"ocaml", 'O';
"native", 'N';
"byte", 'B';
"program", 'P';
"pp", 'R';
"debug", 'D';
"interf", 'I';
"link", 'L';
];;
(* NOT including spaces *)
let countdown_chars = 8;;
let jobs_chars = 3;;
let jobs_cached_chars = 5;;
let dots = "...";;
let start_target = "STARTING";;
let finish_target = "FINISHED";;
let ticker_chars = 3;;
let ticker_period = 0.25;;
let ticker_animation = [|
"\\";
"|";
"/";
"-";
|];;
let cached = "*";;
let uncached = " ";;
let cache_chars = 1;;
(* ***)
(*** create_tagline *)
let create_tagline description = String.make (List.length description) '-';;
(* ***)
(*** create *)
let create
?(channel=stdout)
?(mode:[`Classic|`Sophisticated] = `Sophisticated)
?columns:(_columns=75)
?(description = default_tagline_description)
?log_file
?(log_level=1)
()
=
let log_channel =
match log_file with
| None -> None
| Some fn ->
let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o644 fn in
let f = Format.formatter_of_out_channel oc in
Format.fprintf f "### Starting build.\n";
Some (f, oc)
in
let display_line =
match mode with
| `Classic -> Classic
| `Sophisticated ->
(* We assume Unix is not degraded. *)
let n = ANSI.get_columns () in
let tag_chars = List.length description in
Sophisticated
{ ds_channel = stdout;
ds_start_time = gettimeofday ();
ds_last_update = 0.0;
ds_last_target = start_target;
ds_last_tags = Tags.empty;
ds_last_cached = false;
ds_changed = false;
ds_update_interval = default_update_interval;
ds_columns = n;
ds_jobs = 0;
ds_jobs_cached = 0;
ds_tagline = create_tagline description;
ds_seen_tags = Tags.empty;
ds_pathname_length = n -
(countdown_chars + 1 + jobs_chars + 1 + jobs_cached_chars + 1 +
cache_chars + 1 + tag_chars + 1 + ticker_chars + 2);
ds_tld = description }
in
{ di_log_level = log_level;
di_log_channel = log_channel;
di_channel = channel;
di_formatter = Format.formatter_of_out_channel channel;
di_display_line = display_line;
di_finished = false }
;;
(* ***)
(*** print_time *)
let print_time oc t =
let t = int_of_float t in
let s = t mod 60 in
let m = (t / 60) mod 60 in
let h = t / 3600 in
fp oc "%02d:%02d:%02d" h m s
;;
(* ***)
(*** print_shortened_pathname *)
let print_shortened_pathname length oc u =
assert(length >= 3);
let m = String.length u in
if m <= length then
begin
output_string oc u;
fp oc "%*s" (length - m) ""
end
else
begin
let n = String.length dots in
let k = length - n in
output_string oc dots;
output oc u (m - k) k;
end
(* ***)
(*** Layout
00000000001111111111222222222233333333334444444444555555555566666666667777777777
01234567890123456789012345678901234567890123456789012345678901234567890123456789
HH MM SS XXXX PATHNAME
00:12:31 32 ( 26) ...lp4Filters/Camlp4LocationStripper.cmo * OBn-------------
| | | | | \ tags
| | | \ last target built \ cached ?
| | |
| | \ number of jobs cached
| \ number of jobs
\ elapsed time
cmo mllib
***)
(*** redraw_sophisticated *)
let redraw_sophisticated ds =
let t = gettimeofday () in
let oc = ds.ds_channel in
let dt = t -. ds.ds_start_time in
ds.ds_last_update <- t;
fp oc "%a" ANSI.bol ();
let ticker_phase = (abs (int_of_float (ceil (dt /. ticker_period)))) mod (Array.length ticker_animation) in
let ticker = ticker_animation.(ticker_phase) in
fp oc "%a %-4d (%-4d) %a %s %s %s"
print_time dt
ds.ds_jobs
ds.ds_jobs_cached
(print_shortened_pathname ds.ds_pathname_length) ds.ds_last_target
(if ds.ds_last_cached then cached else uncached)
ds.ds_tagline
ticker;
fp oc "%a%!" ANSI.clear_to_eol ()
;;
(* ***)
(*** redraw *)
let redraw = function
| Classic -> ()
| Sophisticated ds -> redraw_sophisticated ds
;;
(* ***)
(*** finish_sophisticated *)
let finish_sophisticated ?(how=`Success) ds =
let t = gettimeofday () in
let oc = ds.ds_channel in
let dt = t -. ds.ds_start_time in
match how with
| `Success|`Error ->
fp oc "%a" ANSI.bol ();
fp oc "%s %d target%s (%d cached) in %a."
(if how = `Error then
"Compilation unsuccessful after building"
else
"Finished,")
ds.ds_jobs
(if ds.ds_jobs = 1 then "" else "s")
ds.ds_jobs_cached
print_time dt;
fp oc "%a\n%!" ANSI.clear_to_eol ()
| `Quiet ->
fp oc "%a%a%!" ANSI.bol () ANSI.clear_to_eol ();
;;
(* ***)
(*** sophisticated_display *)
let sophisticated_display ds f =
fp ds.ds_channel "%a%a%!" ANSI.bol () ANSI.clear_to_eol ();
f ds.ds_channel
;;
(* ***)
(*** call_if *)
let call_if log_channel f =
match log_channel with
| None -> ()
| Some x -> f x
;;
(* ***)
(*** display *)
let display di f =
call_if di.di_log_channel (fun (_, oc) -> f oc);
match di.di_display_line with
| Classic -> f di.di_channel
| Sophisticated ds -> sophisticated_display ds f
;;
(* ***)
(*** finish *)
let finish ?(how=`Success) di =
if not di.di_finished then begin
di.di_finished <- true;
call_if di.di_log_channel
begin fun (fmt, oc) ->
Format.fprintf fmt "# Compilation %ssuccessful.@." (if how = `Error then "un" else "");
close_out oc;
di.di_log_channel <- None
end;
match di.di_display_line with
| Classic -> ()
| Sophisticated ds -> finish_sophisticated ~how ds
end
;;
(* ***)
(*** update_tagline_from_tags *)
let update_tagline_from_tags ds =
let tagline = ds.ds_tagline in
let tags = ds.ds_last_tags in
let rec loop i = function
| [] ->
for j = i to String.length tagline - 1 do
tagline.[j] <- '-'
done
| (tag, c) :: rest ->
if Tags.mem tag tags then
tagline.[i] <- Char.uppercase c
else
if Tags.mem tag ds.ds_seen_tags then
tagline.[i] <- Char.lowercase c
else
tagline.[i] <- '-';
loop (i + 1) rest
in
loop 0 ds.ds_tld;
;;
(* ***)
(*** update_sophisticated *)
let update_sophisticated ds =
let t = gettimeofday () in
let dt = t -. ds.ds_last_update in
if dt > ds.ds_update_interval then
begin
if ds.ds_changed then
begin
update_tagline_from_tags ds;
ds.ds_changed <- false
end;
redraw_sophisticated ds
end
else
()
;;
(* ***)
(*** set_target_sophisticated *)
let set_target_sophisticated ds target tags cached =
ds.ds_changed <- true;
ds.ds_last_target <- target;
ds.ds_last_tags <- tags;
ds.ds_jobs <- 1 + ds.ds_jobs;
if cached then ds.ds_jobs_cached <- 1 + ds.ds_jobs_cached;
ds.ds_last_cached <- cached;
ds.ds_seen_tags <- Tags.union ds.ds_seen_tags ds.ds_last_tags;
update_sophisticated ds
;;
let print_tags f tags =
let first = ref true in
Tags.iter begin fun tag ->
if !first then begin
first := false;
Format.fprintf f "%s" tag
end else Format.fprintf f ", %s" tag
end tags
;;
(* ***)
(*** update *)
let update di =
match di.di_display_line with
| Classic -> ()
| Sophisticated ds -> update_sophisticated ds
;;
(* ***)
(*** event *)
let event di ?(pretend=false) command target tags =
call_if di.di_log_channel
(fun (fmt, _) ->
Format.fprintf fmt "# Target: %s, tags: { %a }\n" target print_tags tags;
Format.fprintf fmt "%s%s@." command (if pretend then " # cached" else ""));
match di.di_display_line with
| Classic ->
if pretend then
(if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command)
else
(if di.di_log_level >= 1 then Format.fprintf di.di_formatter "%s\n%!" command)
| Sophisticated ds ->
set_target_sophisticated ds target tags pretend;
update_sophisticated ds
;;
(* ***)
(*** dprintf *)
let dprintf ?(log_level=1) di fmt =
if log_level > di.di_log_level then Discard_printf.discard_printf fmt else
match di.di_display_line with
| Classic -> Format.fprintf di.di_formatter fmt
| Sophisticated _ ->
if log_level < 0 then
begin
display di ignore;
Format.fprintf di.di_formatter fmt
end
else
match di.di_log_channel with
| Some (f, _) -> Format.fprintf f fmt
| None -> Discard_printf.discard_printf fmt
(* ***)