[taskbar] more informative non-interactive mode

Summary:
Print the following for each source file to analyse in non-interactive mode:

```
path/to/source_file.c starting
[...]
path/to/source_file.c DONE in <time>
```

This should help diagnose when infer is stuck. It also logs this information to
the log file regardless of the form of the progress bar.

Also add a `--progress-bar-style` option to allow the user to force a
particular rendering: plain (as above), multiline (The Glorious One), or auto
(selection depends on whether infer is connected to a TTY on stdin *and*
stderr).

Reviewed By: mbouaziz

Differential Revision: D9120509

fbshipit-source-id: 4b43b7464

infer/src/backend/InferAnalyze.ml

@@ -21,11 +21,11 @@ let analyze_source_file : SourceFile.t Tasks.doer =
  fun source_file ->
   DB.Results_dir.init source_file ;
   let exe_env = Exe_env.mk () in
-  L.(debug Analysis Medium) "@\nProcessing '%a'@." SourceFile.pp source_file ;
-  (* clear cache for each source file to avoid it growing unboundedly *)
-  clear_caches () ;
-  Callbacks.analyze_file exe_env source_file ;
-  if Config.write_html then Printer.write_all_html_files source_file
+  L.task_progress SourceFile.pp source_file ~f:(fun () ->
+      (* clear cache for each source file to avoid it growing unboundedly *)
+      clear_caches () ;
+      Callbacks.analyze_file exe_env source_file ;
+      if Config.write_html then Printer.write_all_html_files source_file )
 
 
 let output_json_makefile_stats clusters =

infer/src/backend/Tasks.ml

@@ -11,9 +11,7 @@ module L = Logging
 type 'a doer = 'a -> unit
 
 let run_sequentially ~(f: 'a doer) (tasks: 'a list) : unit =
-  let task_bar =
-    if Config.show_progress_bar then TaskBar.create_multiline ~jobs:1 else TaskBar.create_dummy ()
-  in
+  let task_bar = TaskBar.create ~jobs:1 in
   (ProcessPoolState.update_status :=
      fun t status ->
        TaskBar.update_status task_bar ~slot:0 t status ;
@@ -38,19 +36,13 @@ let fork_protect ~f x =
 
 
 module Runner = struct
-  type 'a t = {pool: 'a ProcessPool.t; task_bar: TaskBar.t}
+  type 'a t = 'a ProcessPool.t
 
   let create ~jobs ~f =
-    let task_bar =
-      if Config.show_progress_bar then TaskBar.create_multiline ~jobs else TaskBar.create_dummy ()
-    in
-    { pool=
-        ProcessPool.create ~jobs
-          ~child_prelude:
-            ((* hack: run post-fork bookkeeping stuff by passing a dummy function to [fork_protect] *)
-             fork_protect ~f:(fun () -> () ))
-          task_bar ~f
-    ; task_bar }
+    ProcessPool.create ~jobs ~f
+      ~child_prelude:
+        ((* hack: run post-fork bookkeeping stuff by passing a dummy function to [fork_protect] *)
+         fork_protect ~f:(fun () -> () ))
 
 
   let run runner ~tasks =
@@ -58,6 +50,5 @@ module Runner = struct
     Pervasives.flush_all () ;
     (* Compact heap before forking *)
     Gc.compact () ;
-    ProcessPool.run runner.pool tasks ;
-    TaskBar.finish runner.task_bar
+    ProcessPool.run runner tasks
 end

infer/src/base/Config.ml

@@ -1747,6 +1747,14 @@ and progress_bar =
     "Show a progress bar"
 
 
+and progress_bar_style =
+  CLOpt.mk_symbol ~long:"progress-bar-style"
+    ~symbols:[("auto", `Auto); ("plain", `Plain); ("multiline", `MultiLine)] ~eq:Pervasives.( = )
+    ~default:`Auto ~in_help:[(Analyze, manual_generic); (Capture, manual_generic)]
+    "Style of the progress bar. $(b,auto) selects $(b,multiline) if connected to a tty, otherwise \
+     $(b,plain)."
+
+
 and project_root =
   CLOpt.mk_path ~deprecated:["project_root"; "-project_root"; "pr"] ~long:"project-root" ~short:'C'
     ~default:CLOpt.init_work_dir
@@ -2747,6 +2755,18 @@ and[@warning "-32"] procedures_per_process = !procedures_per_process
 
 and procedures_source_file = !procedures_source_file
 
+and progress_bar =
+  if !progress_bar then
+    match !progress_bar_style with
+    | `Auto when Unix.(isatty stdin && isatty stderr) ->
+        `MultiLine
+    | `Auto ->
+        `Plain
+    | (`Plain | `MultiLine) as style ->
+        style
+  else `Quiet
+
+
 and procs_csv = !procs_csv
 
 and project_root = !project_root
@@ -2799,8 +2819,6 @@ and select = !select
 
 and show_buckets = !print_buckets
 
-and show_progress_bar = !progress_bar
-
 and siof = !siof
 
 and siof_check_iostreams = !siof_check_iostreams

infer/src/base/Config.mli

@@ -520,6 +520,8 @@ val procs_csv : string option
 
 val project_root : string
 
+val progress_bar : [`MultiLine | `Plain | `Quiet]
+
 val quandary : bool
 
 val quandary_endpoints : Yojson.Basic.json
@@ -562,8 +564,6 @@ val select : int option
 
 val show_buckets : bool
 
-val show_progress_bar : bool
-
 val siof : bool
 
 val siof_check_iostreams : bool

infer/src/base/Logging.ml

@@ -208,6 +208,15 @@ let phase fmt = log ~to_console:false phase_file_fmts fmt
 
 let progress fmt = log ~to_console:(not Config.quiet) progress_file_fmts fmt
 
+let task_progress ~f pp x =
+  let to_console =
+    match Config.progress_bar with `Plain -> true | `Quiet | `MultiLine -> false
+  in
+  log ~to_console progress_file_fmts "%a starting@." pp x ;
+  f () ;
+  log ~to_console progress_file_fmts "%a DONE@." pp x
+
+
 let user_warning fmt = log ~to_console:(not Config.quiet) user_warning_file_fmts fmt
 
 let user_error fmt = log ~to_console:true user_error_file_fmts fmt

infer/src/base/Logging.mli

@@ -23,6 +23,10 @@ val environment_info : ('a, F.formatter, unit) format -> 'a
 val progress : ('a, F.formatter, unit) format -> 'a
 (** print immediately to standard error unless --quiet is specified *)
 
+val task_progress : f:(unit -> unit) -> (F.formatter -> 'a -> unit) -> 'a -> unit
+(** [task_progress ~f pp x] executes [f] and log progress [pp x] in the log file and also on the
+    console unless there is an active task bar *)
+
 val result : ('a, F.formatter, unit) format -> 'a
 (** Emit a result to stdout. Use only if the output format is stable and useful enough that it may
     conceivably get piped to another program, ie, almost never (use [progress] instead otherwise).

infer/src/base/ProcessPool.ml

@@ -229,8 +229,9 @@ let fork_child ~child_prelude ~slot (updates_r, updates_w) ~f =
       {pid; down_pipe= Unix.out_channel_of_descr to_child_w}
 
 
-let create : jobs:int -> child_prelude:(unit -> unit) -> TaskBar.t -> f:('a -> unit) -> 'a t =
- fun ~jobs ~child_prelude task_bar ~f ->
+let create : jobs:int -> child_prelude:(unit -> unit) -> f:('a -> unit) -> 'a t =
+ fun ~jobs ~child_prelude ~f ->
+  let task_bar = TaskBar.create ~jobs in
   (* Pipe to communicate from children to parent. Only one pipe is needed: the messages sent by
       children include the identifier of the child sending the message (its [slot]). This way there
       is only one pipe to wait on for updates. *)
@@ -257,4 +258,5 @@ let run pool tasks =
   while not (List.is_empty pool.tasks && pool.idle_children >= pool.jobs) do
     process_updates pool buffer ; TaskBar.refresh pool.task_bar
   done ;
-  wait_all pool
+  wait_all pool ;
+  TaskBar.finish pool.task_bar

infer/src/base/ProcessPool.mli

@@ -26,7 +26,7 @@ open! IStd
 (** A ['a t] process pool accepts tasks of type ['a]. ['a] will be marshalled over a Unix pipe.*)
 type _ t
 
-val create : jobs:int -> child_prelude:(unit -> unit) -> TaskBar.t -> f:('a -> unit) -> 'a t
+val create : jobs:int -> child_prelude:(unit -> unit) -> f:('a -> unit) -> 'a t
 (** Create a new pool of processes running [jobs] jobs in parallel *)
 
 val run : 'a t -> 'a list -> unit

infer/src/base/TaskBar.ml

@@ -7,7 +7,6 @@
 
 open! IStd
 module F = Format
-module L = Logging
 
 (** {2 arbitrary constants } *)
 
@@ -35,7 +34,7 @@ type multiline_info =
 type t =
   | MultiLine of multiline_info  (** interactive *)
   | NonInteractive  (** display terse progress, to use when output is redirected *)
-  | Dummy  (** ignore everything *)
+  | Quiet  (** ignore everything *)
 
 (** print [c] [n] times *)
 let rec pp_n c fmt n =
@@ -123,25 +122,27 @@ let refresh_multiline task_bar =
   ()
 
 
-let refresh = function MultiLine t -> refresh_multiline t | NonInteractive | Dummy -> ()
+let refresh = function MultiLine t -> refresh_multiline t | NonInteractive | Quiet -> ()
 
-let create_multiline ~jobs =
-  if Unix.(isatty stdin) && Unix.(isatty stderr) then (
-    let t0 = Mtime_clock.now () in
-    let task_bar =
-      { jobs
-      ; jobs_statuses= Array.create ~len:jobs "idle"
-      ; jobs_start_times= Array.create ~len:jobs t0
-      ; start_time= Mtime_clock.counter ()
-      ; tasks_done= 0
-      ; tasks_total= 0 }
-    in
-    ANSITerminal.erase Below ; MultiLine task_bar )
-  else NonInteractive
+let create ~jobs =
+  match Config.progress_bar with
+  | `Quiet ->
+      Quiet
+  | `Plain ->
+      NonInteractive
+  | `MultiLine ->
+      let t0 = Mtime_clock.now () in
+      let task_bar =
+        { jobs
+        ; jobs_statuses= Array.create ~len:jobs "idle"
+        ; jobs_start_times= Array.create ~len:jobs t0
+        ; start_time= Mtime_clock.counter ()
+        ; tasks_done= 0
+        ; tasks_total= 0 }
+      in
+      ANSITerminal.erase Below ; MultiLine task_bar
 
 
-let create_dummy () = Dummy
-
 let update_status_multiline task_bar ~slot:job t0 status =
   (task_bar.jobs_statuses).(job) <- status ;
   (task_bar.jobs_start_times).(job) <- t0 ;
@@ -152,7 +153,7 @@ let update_status task_bar ~slot t0 status =
   match task_bar with
   | MultiLine t ->
       update_status_multiline t ~slot t0 status
-  | NonInteractive | Dummy ->
+  | NonInteractive | Quiet ->
       ()
 
 
@@ -160,7 +161,7 @@ let set_tasks_total task_bar n =
   match task_bar with
   | MultiLine multiline ->
       multiline.tasks_total <- n
-  | NonInteractive | Dummy ->
+  | NonInteractive | Quiet ->
       ()
 
 
@@ -168,9 +169,7 @@ let tasks_done_add task_bar n =
   match task_bar with
   | MultiLine multiline ->
       multiline.tasks_done <- multiline.tasks_done + n
-  | NonInteractive ->
-      L.progress "#%!"
-  | Dummy ->
+  | NonInteractive | Quiet ->
       ()
 
 
@@ -178,7 +177,7 @@ let tasks_done_reset task_bar =
   match task_bar with
   | MultiLine multiline ->
       multiline.tasks_done <- 0
-  | NonInteractive | Dummy ->
+  | NonInteractive | Quiet ->
       ()
 
 
@@ -188,8 +187,8 @@ let finish = function
       Out_channel.output_string stderr "\n" ;
       ANSITerminal.erase Below ;
       Out_channel.flush stderr
-  | NonInteractive | Dummy ->
+  | NonInteractive | Quiet ->
       ()
 
 
-let is_interactive = function MultiLine _ -> true | NonInteractive | Dummy -> false
+let is_interactive = function MultiLine _ -> true | NonInteractive | Quiet -> false

infer/src/base/TaskBar.mli

@@ -12,15 +12,12 @@ type t
 val refresh : t -> unit
 (** draw the taskbar *)
 
-val create_multiline : jobs:int -> t
-(** creates a multiline task bar for running [jobs] jobs in parallel *)
-
-val create_dummy : unit -> t
-(** silent task bar *)
+val create : jobs:int -> t
+(** creates a task bar for running [jobs] jobs in parallel *)
 
 val update_status : t -> slot:int -> Mtime.t -> string -> unit
 (** [update_status task_bar ~slot t status] records an event described by [status] on slot [slot]
-   started at time [t] *)
+    started at time [t] *)
 
 val set_tasks_total : t -> int -> unit
 (** set the total number of tasks to do *)