diff options
Diffstat (limited to 'ocamlbuild/display.ml')
| -rw-r--r-- | ocamlbuild/display.ml | 385 |
1 files changed, 385 insertions, 0 deletions
diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml new file mode 100644 index 000000000..b1f13ee39 --- /dev/null +++ b/ocamlbuild/display.ml @@ -0,0 +1,385 @@ +(***********************************************************************) +(* 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; + 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 + 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 +(* ***) |