Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
390 lines (379 sloc) 11.8 KB
(***********************************************************************)
(* *)
(* 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 : 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] 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 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
(* ***)
Something went wrong with that request. Please try again.