394 lines
12 KiB
OCaml
394 lines
12 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
|
|
(* 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 () =
|
|
if Sys.os_type = "Unix" then
|
|
try
|
|
int_of_string (String.chomp (My_unix.run_and_read "tput cols"))
|
|
with
|
|
| Failure _ -> 80
|
|
else 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 : bytes; (** 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 = Bytes.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] 0o666 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_substring 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)
|
|
(Bytes.to_string 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 Bytes.length tagline - 1 do
|
|
Bytes.set tagline j '-'
|
|
done
|
|
| (tag, c) :: rest ->
|
|
if Tags.mem tag tags then
|
|
Bytes.set tagline i (Char.uppercase c)
|
|
else
|
|
if Tags.mem tag ds.ds_seen_tags then
|
|
Bytes.set tagline i (Char.lowercase c)
|
|
else
|
|
Bytes.set 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
|
|
begin
|
|
(* This should work, even on Windows *)
|
|
let command = Filename.basename command in
|
|
if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command
|
|
end
|
|
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
|
|
(* ***)
|