ocamlbuild/display.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13 (* Original author: Berke Durak *)
  14 (* Display *)
  15 open My_std;;
  16
  17 open My_unix;;
  18
  19 let fp = Printf.fprintf;;
  20
  21 (*** ANSI *)
  22 module ANSI =
  23   struct
  24     let up oc n = fp oc "\027[%dA" n;;
  25     let clear_to_eol oc () = fp oc "\027[K";;
  26     let bol oc () = fp oc "\r";;
  27     let get_columns () =
  28       try
  29         int_of_string (String.chomp (My_unix.run_and_read "tput cols"))
  30       with
  31       | Failure _ -> 80
  32   end
  33 ;;
  34 (* ***)
  35 (*** tagline_description *)
  36 type tagline_description = (string * char) list;;
  37 (* ***)
  38 (*** sophisticated_display *)
  39 type sophisticated_display = {
  40           ds_channel         : out_channel;            (** Channel for writing *)
  41           ds_start_time      : float;                  (** When was compilation started *)
  42   mutable ds_last_update     : float;                  (** When was the display last updated *)
  43   mutable ds_last_target     : string;                 (** Last target built *)
  44   mutable ds_last_cached     : bool;                   (** Was the last target cached or really built ? *)
  45   mutable ds_last_tags       : Tags.t;                 (** Tags of the last command *)
  46   mutable ds_changed         : bool;                   (** Does the tag line need recomputing ? *)
  47           ds_update_interval : float;                  (** Minimum interval between updates *)
  48           ds_columns         : int;                    (** Number of columns in dssplay *)
  49   mutable ds_jobs            : int;                    (** Number of jobs launched or cached *)
  50   mutable ds_jobs_cached     : int;                    (** Number of jobs cached *)
  51           ds_tagline         : string;                 (** Current tagline *)
  52   mutable ds_seen_tags       : Tags.t;                 (** Tags that we have encountered *)
  53           ds_pathname_length : int;                    (** How much space for displaying pathnames ? *)
  54           ds_tld             : tagline_description;    (** Description for the tagline *)
  55 };;
  56 (* ***)
  57 (*** display_line, display *)
  58 type display_line =
  59 | Classic
  60 | Sophisticated of sophisticated_display
  61
  62 type display = {
  63           di_log_level    : int;
  64           di_log_channel  : (Format.formatter * out_channel) option;
  65           di_channel      : out_channel;
  66           di_formatter    : Format.formatter;
  67           di_display_line : display_line;
  68   mutable di_finished     : bool;
  69 }
  70 ;;
  71 (* ***)
  72 (*** various defaults *)
  73 let default_update_interval = 0.05;;
  74 let default_tagline_description = [
  75   "ocaml",     'O';
  76   "native",    'N';
  77   "byte",      'B';
  78   "program",   'P';
  79   "pp",        'R';
  80   "debug",     'D';
  81   "interf",    'I';
  82   "link",      'L';
  83 ];;
  84
  85 (* NOT including spaces *)
  86 let countdown_chars = 8;;
  87 let jobs_chars = 3;;
  88 let jobs_cached_chars = 5;;
  89 let dots = "...";;
  90 let start_target = "STARTING";;
  91 let finish_target = "FINISHED";;
  92 let ticker_chars = 3;;
  93 let ticker_period = 0.25;;
  94 let ticker_animation = [|
  95   "\\";
  96   "|";
  97   "/";
  98   "-";
  99 |];;
 100 let cached = "*";;
 101 let uncached = " ";;
 102 let cache_chars = 1;;
 103 (* ***)
 104 (*** create_tagline *)
 105 let create_tagline description = String.make (List.length description) '-';;
 106 (* ***)
 107 (*** create *)
 108 let create
 109   ?(channel=stdout)
 110   ?(mode:[`Classic|`Sophisticated] = `Sophisticated)
 111   ?columns:(_columns=75)
 112   ?(description = default_tagline_description)
 113   ?log_file
 114   ?(log_level=1)
 115   ()
 116   =
 117   let log_channel =
 118     match log_file with
 119     | None -> None
 120     | Some fn ->
 121         let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o644 fn in
 122         let f = Format.formatter_of_out_channel oc in
 123         Format.fprintf f "### Starting build.\n";
 124         Some (f, oc)
 125   in
 126
 127   let display_line =
 128     match mode with
 129     | `Classic -> Classic
 130     | `Sophisticated ->
 131       (* We assume Unix is not degraded. *)
 132       let n = ANSI.get_columns () in
 133       let tag_chars = List.length description in
 134       Sophisticated
 135         { ds_channel         = stdout;
 136           ds_start_time      = gettimeofday ();
 137           ds_last_update     = 0.0;
 138           ds_last_target     = start_target;
 139           ds_last_tags       = Tags.empty;
 140           ds_last_cached     = false;
 141           ds_changed         = false;
 142           ds_update_interval = default_update_interval;
 143           ds_columns         = n;
 144           ds_jobs            = 0;
 145           ds_jobs_cached     = 0;
 146           ds_tagline         = create_tagline description;
 147           ds_seen_tags       = Tags.empty;
 148           ds_pathname_length = n -
 149                                  (countdown_chars + 1 + jobs_chars + 1 + jobs_cached_chars + 1 +
 150                                   cache_chars + 1 + tag_chars + 1 + ticker_chars + 2);
 151           ds_tld             = description }
 152   in
 153   { di_log_level    = log_level;
 154     di_log_channel  = log_channel;
 155     di_channel      = channel;
 156     di_formatter    = Format.formatter_of_out_channel channel;
 157     di_display_line = display_line;
 158     di_finished     = false }
 159 ;;
 160 (* ***)
 161 (*** print_time *)
 162 let print_time oc t =
 163   let t = int_of_float t in
 164   let s = t mod 60 in
 165   let m = (t / 60) mod 60 in
 166   let h = t / 3600 in
 167   fp oc "%02d:%02d:%02d" h m s
 168 ;;
 169 (* ***)
 170 (*** print_shortened_pathname *)
 171 let print_shortened_pathname length oc u =
 172   assert(length >= 3);
 173   let m = String.length u in
 174   if m <= length then
 175     begin
 176       output_string oc u;
 177       fp oc "%*s" (length - m) ""
 178     end
 179   else
 180     begin
 181       let n = String.length dots in
 182       let k = length - n in
 183       output_string oc dots;
 184       output oc u (m - k) k;
 185     end
 186 (* ***)
 187 (*** Layout
 188
 189 00000000001111111111222222222233333333334444444444555555555566666666667777777777
 190 01234567890123456789012345678901234567890123456789012345678901234567890123456789
 191 HH MM SS XXXX        PATHNAME
 192 00:12:31   32 (  26) ...lp4Filters/Camlp4LocationStripper.cmo * OBn-------------
 193 |          |  |      |                                        | \ tags
 194 |          |  |      \ last target built                      \ cached ?
 195 |          |  |
 196 |          |  \ number of jobs cached
 197 |          \ number of jobs
 198 \ elapsed time
 199 cmo mllib
 200 ***)
 201 (*** redraw_sophisticated *)
 202 let redraw_sophisticated ds =
 203   let t = gettimeofday () in
 204   let oc = ds.ds_channel in
 205   let dt = t -. ds.ds_start_time in
 206   ds.ds_last_update <- t;
 207   fp oc "%a" ANSI.bol ();
 208   let ticker_phase = (abs (int_of_float (ceil (dt /. ticker_period)))) mod (Array.length ticker_animation) in
 209   let ticker = ticker_animation.(ticker_phase) in
 210   fp oc "%a %-4d (%-4d) %a %s %s %s"
 211     print_time dt
 212     ds.ds_jobs
 213     ds.ds_jobs_cached
 214     (print_shortened_pathname ds.ds_pathname_length) ds.ds_last_target
 215     (if ds.ds_last_cached then cached else uncached)
 216     ds.ds_tagline
 217     ticker;
 218   fp oc "%a%!" ANSI.clear_to_eol ()
 219 ;;
 220 (* ***)
 221 (*** redraw *)
 222 let redraw = function
 223   | Classic -> ()
 224   | Sophisticated ds -> redraw_sophisticated ds
 225 ;;
 226 (* ***)
 227 (*** finish_sophisticated *)
 228 let finish_sophisticated ?(how=`Success) ds =
 229   let t = gettimeofday () in
 230   let oc = ds.ds_channel in
 231   let dt = t -. ds.ds_start_time in
 232   match how with
 233   | `Success|`Error ->
 234     fp oc "%a" ANSI.bol ();
 235     fp oc "%s %d target%s (%d cached) in %a."
 236       (if how = `Error then
 237         "Compilation unsuccessful after building"
 238        else
 239          "Finished,")
 240       ds.ds_jobs
 241       (if ds.ds_jobs = 1 then "" else "s")
 242       ds.ds_jobs_cached
 243       print_time dt;
 244     fp oc "%a\n%!" ANSI.clear_to_eol ()
 245   | `Quiet ->
 246     fp oc "%a%a%!" ANSI.bol () ANSI.clear_to_eol ();
 247 ;;
 248 (* ***)
 249 (*** sophisticated_display *)
 250 let sophisticated_display ds f =
 251   fp ds.ds_channel "%a%a%!" ANSI.bol () ANSI.clear_to_eol ();
 252   f ds.ds_channel
 253 ;;
 254 (* ***)
 255 (*** call_if *)
 256 let call_if log_channel f =
 257   match log_channel with
 258   | None -> ()
 259   | Some x -> f x
 260 ;;
 261 (* ***)
 262 (*** display *)
 263 let display di f =
 264   call_if di.di_log_channel (fun (_, oc) -> f oc);
 265   match di.di_display_line with
 266   | Classic -> f di.di_channel
 267   | Sophisticated ds -> sophisticated_display ds f
 268 ;;
 269 (* ***)
 270 (*** finish *)
 271 let finish ?(how=`Success) di =
 272   if not di.di_finished then begin
 273     di.di_finished <- true;
 274     call_if di.di_log_channel
 275       begin fun (fmt, oc) ->
 276         Format.fprintf fmt "# Compilation %ssuccessful.@." (if how = `Error then "un" else "");
 277         close_out oc
 278       end;
 279     match di.di_display_line with
 280     | Classic -> ()
 281     | Sophisticated ds -> finish_sophisticated ~how ds
 282   end
 283 ;;
 284 (* ***)
 285 (*** update_tagline_from_tags *)
 286 let update_tagline_from_tags ds =
 287   let tagline = ds.ds_tagline in
 288   let tags = ds.ds_last_tags in
 289   let rec loop i = function
 290     | [] ->
 291         for j = i to String.length tagline - 1 do
 292           tagline.[j] <- '-'
 293         done
 294     | (tag, c) :: rest ->
 295         if Tags.mem tag tags then
 296           tagline.[i] <- Char.uppercase c
 297         else
 298           if Tags.mem tag ds.ds_seen_tags then
 299             tagline.[i] <- Char.lowercase c
 300           else
 301             tagline.[i] <- '-';
 302         loop (i + 1) rest
 303   in
 304   loop 0 ds.ds_tld;
 305 ;;
 306 (* ***)
 307 (*** update_sophisticated *)
 308 let update_sophisticated ds =
 309   let t = gettimeofday () in
 310   let dt = t -. ds.ds_last_update in
 311   if dt > ds.ds_update_interval then
 312     begin
 313       if ds.ds_changed then
 314         begin
 315           update_tagline_from_tags ds;
 316           ds.ds_changed <- false
 317         end;
 318       redraw_sophisticated ds
 319     end
 320   else
 321     ()
 322 ;;
 323 (* ***)
 324 (*** set_target_sophisticated *)
 325 let set_target_sophisticated ds target tags cached =
 326   ds.ds_changed <- true;
 327   ds.ds_last_target <- target;
 328   ds.ds_last_tags <- tags;
 329   ds.ds_jobs <- 1 + ds.ds_jobs;
 330   if cached then ds.ds_jobs_cached <- 1 + ds.ds_jobs_cached;
 331   ds.ds_last_cached <- cached;
 332   ds.ds_seen_tags <- Tags.union ds.ds_seen_tags ds.ds_last_tags;
 333   update_sophisticated ds
 334 ;;
 335
 336 let print_tags f tags =
 337   let first = ref true in
 338   Tags.iter begin fun tag ->
 339     if !first then begin
 340       first := false;
 341       Format.fprintf f "%s" tag
 342     end else Format.fprintf f ", %s" tag
 343   end tags
 344 ;;
 345 (* ***)
 346 (*** update *)
 347 let update di =
 348   match di.di_display_line with
 349   | Classic -> ()
 350   | Sophisticated ds -> update_sophisticated ds
 351 ;;
 352 (* ***)
 353 (*** event *)
 354 let event di ?(pretend=false) command target tags =
 355   call_if di.di_log_channel
 356     (fun (fmt, _) ->
 357       Format.fprintf fmt "# Target: %s, tags: { %a }\n" target print_tags tags;
 358       Format.fprintf fmt "%s%s@." command (if pretend then " # cached" else ""));
 359   match di.di_display_line with
 360   | Classic ->
 361       if pretend then
 362         (if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command)
 363       else
 364         (if di.di_log_level >= 1 then Format.fprintf di.di_formatter "%s\n%!" command)
 365   | Sophisticated ds ->
 366       set_target_sophisticated ds target tags pretend;
 367       update_sophisticated ds
 368 ;;
 369 (* ***)
 370 (*** dprintf *)
 371 let dprintf ?(log_level=1) di fmt =
 372   if log_level > di.di_log_level then Discard_printf.discard_printf fmt else
 373   match di.di_display_line with
 374   | Classic -> Format.fprintf di.di_formatter fmt
 375   | Sophisticated _ ->
 376       if log_level < 0 then
 377         begin
 378           display di ignore;
 379           Format.fprintf di.di_formatter fmt
 380         end
 381       else
 382         match di.di_log_channel with
 383         | Some (f, _) -> Format.fprintf f fmt
 384         | None -> Discard_printf.discard_printf fmt
 385 (* ***)