@ -6,17 +6,29 @@
* )
* )
open ! IStd
open ! IStd
module F = Format
module L = Logging
module L = Logging
(* * arbitrary *)
(* * {2 arbitrary constants } *)
let progress_bar_total_size_default = 60
(* * max size for the top bar of the multiline task bar *)
let top_bar_size_default = 100
(* * do not attempt to draw the top bar of the multiline task bar unless it can be at least this big *)
let min_acceptable_progress_bar = 10
(* * infer rulez *)
let job_prefix = " ⊢ "
(* * {2 Task bar} *)
(* * state of a multi-line task bar *)
(* * state of a multi-line task bar *)
type multiline_info =
type multiline_info =
{ jobs : int (* * number of jobs running in parallel *)
{ jobs : int (* * number of jobs running in parallel *)
; statuses : string Array . t
; jobs_ statuses: string Array . t
(* * array of size [jobs] with a description of what the process is doing *)
(* * array of size [jobs] with a description of what the process is doing *)
; start_times : Mtime . t Array . t (* * array of size [jobs] of start times for each process *)
; jobs_start_times : Mtime . t Array . t (* * array of size [jobs] of start times for each process *)
; start_time : Mtime_clock . counter (* * time since the creation of the task bar *)
; mutable tasks_done : int
; mutable tasks_done : int
; mutable tasks_total : int }
; mutable tasks_total : int }
@ -32,31 +44,53 @@ let rec pp_n c oc n =
pp_n c oc ( n - 1 ) )
pp_n c oc ( n - 1 ) )
let progress_bar_total_size =
let draw_top_bar ~ term_width ~ total ~ finished ~ elapsed =
lazy
( if Unix . ( isatty stdin ) then
let term_width , _ = ANSITerminal . size () in
min progress_bar_total_size_default term_width
else progress_bar_total_size_default )
let draw_progress_bar ~ total ~ don =
let lazy progress_bar_total_size = progress_bar_total_size in
let bar_done_size = don * progress_bar_total_size / total in
let tasks_total_string = Int . to_string total in
let tasks_total_string = Int . to_string total in
let bar_tasks_num_size = String . length tasks_total_string in
let bar_tasks_num_size = String . length tasks_total_string in
Printf . eprintf " %*d/%s [%a%a] %d%% \n " bar_tasks_num_size don tasks_total_string ( pp_n '#' )
let elapsed_string = F . asprintf " %a " Mtime . Span . pp elapsed in
bar_done_size ( pp_n '.' )
(* format string for the full top bar, assuming there is enough room, and number of characters
( progress_bar_total_size - bar_done_size )
taken by the portion of the top bar that is not the progress bar itself * )
( don * 100 / total )
let top_bar_fmt , size_around_progress_bar =
(* add pairs of a partial format string and its expected size *)
let ( + + ) ( f1 , l1 ) ( f2 , l2 ) = ( f1 ^^ f2 , l1 + l2 ) in
let draw_job_status ~ draw_time t ~ status ~ t0 =
let ( + + + ) ( f1 , l1 ) f2 = ( f1 ^^ f2 , l1 + ( string_of_format f2 | > String . length ) ) in
ANSITerminal . ( prerr_string [ Bold ; magenta ] ) " ⊢ " ;
( " %*d " , bar_tasks_num_size (* finished *) ) + + + " / " + + ( " %s " , bar_tasks_num_size (* total *) )
( if draw_time then
+ + + " [ " + + ( " %a%a " , 0 (* progress bar *) ) + + + " ] "
let time_running = Mtime . span t0 t | > Mtime . Span . to_s in
+ + ( " %d%% " , 3 (* "xx%", even though sometimes it's just "x%" *) ) + + + " "
Printf . eprintf " [%4.1fs] " time_running ) ;
+ + ( " %s "
Out_channel . output_string stderr status ;
, max ( String . length elapsed_string ) 9
(* leave some room for elapsed_string to avoid flicker. 9 characters is "XXhXXmXXs" so it
gives some reasonable margin . * )
)
in
let top_bar_size = min term_width top_bar_size_default in
let progress_bar_size = top_bar_size - size_around_progress_bar in
( if progress_bar_size < min_acceptable_progress_bar then
let s = Printf . sprintf " %d/%s %s " finished tasks_total_string elapsed_string in
Out_channel . output_string stderr ( String . prefix s term_width )
else
let bar_done_size = finished * progress_bar_size / total in
Printf . eprintf top_bar_fmt bar_tasks_num_size finished tasks_total_string ( pp_n '#' )
bar_done_size ( pp_n '.' )
( progress_bar_size - bar_done_size )
( finished * 100 / total )
elapsed_string ) ;
ANSITerminal . erase Eol ;
Out_channel . output_string stderr " \n "
let draw_job_status ~ term_width ~ draw_time t ~ status ~ t0 =
let length = ref 0 in
let job_prefix_size = String . length job_prefix in
if term_width > job_prefix_size then (
ANSITerminal . ( prerr_string [ Bold ; magenta ] ) job_prefix ;
length := ! length + job_prefix_size ) ;
let time_width = 4 + (* actually drawing the time *) 3 (* "[] " *) in
if draw_time && term_width > time_width + job_prefix_size then (
let time_running = Mtime . span t0 t | > Mtime . Span . to_s in
Printf . eprintf " [%4.1fs] " time_running ;
length := ! length + time_width ) ;
String . prefix status ( term_width - ! length ) | > Out_channel . output_string stderr ;
ANSITerminal . erase Eol ;
ANSITerminal . erase Eol ;
Out_channel . output_string stderr " \n "
Out_channel . output_string stderr " \n "
@ -64,17 +98,19 @@ let draw_job_status ~draw_time t ~status ~t0 =
let refresh_multiline task_bar =
let refresh_multiline task_bar =
ANSITerminal . move_bol () ;
ANSITerminal . move_bol () ;
let should_draw_progress_bar = task_bar . tasks_total > 0 && task_bar . tasks_done > = 0 in
let should_draw_progress_bar = task_bar . tasks_total > 0 && task_bar . tasks_done > = 0 in
let term_width , _ = ANSITerminal . size () in
if should_draw_progress_bar then
if should_draw_progress_bar then
draw_ progress _bar ~ t otal: task_bar . tasks_total ~ don : task_bar . tasks_done ;
draw_ to p_bar ~ t erm_width ~ t otal: task_bar . tasks_total ~ finishe d: task_bar . tasks_done
let t = Mtime_clock . now () in
~ elapsed : ( Mtime_clock . count task_bar . start_time ) ;
let draw_time =
let draw_time =
(* When there is only 1 job we are careful not to spawn processes needlessly, thus there is no
(* When there is only 1 job we are careful not to spawn processes needlessly, thus there is no
one to refresh the task bar while the analysis is running and the time displayed will always
one to refresh the task bar while the analysis is running and the time displayed will always
be 0 . Avoid confusion by not displaying the time in that case . * )
be 0 . Avoid confusion by not displaying the time in that case . * )
task_bar . jobs > 1
task_bar . jobs > 1
in
in
Array . iter2_exn task_bar . statuses task_bar . start_times ~ f : ( fun status t0 ->
let now = Mtime_clock . now () in
draw_job_status ~ draw_time t ~ status ~ t0 ) ;
Array . iter2_exn task_bar . jobs_statuses task_bar . jobs_start_times ~ f : ( fun status t0 ->
draw_job_status ~ term_width ~ draw_time now ~ status ~ t0 ) ;
let lines_printed =
let lines_printed =
let progress_bar = if should_draw_progress_bar then 1 else 0 in
let progress_bar = if should_draw_progress_bar then 1 else 0 in
task_bar . jobs + progress_bar
task_bar . jobs + progress_bar
@ -90,8 +126,9 @@ let create_multiline ~jobs =
let t0 = Mtime_clock . now () in
let t0 = Mtime_clock . now () in
let task_bar =
let task_bar =
{ jobs
{ jobs
; statuses = Array . create ~ len : jobs " idle "
; jobs_statuses = Array . create ~ len : jobs " idle "
; start_times = Array . create ~ len : jobs t0
; jobs_start_times = Array . create ~ len : jobs t0
; start_time = Mtime_clock . counter ()
; tasks_done = 0
; tasks_done = 0
; tasks_total = 0 }
; tasks_total = 0 }
in
in
@ -102,8 +139,8 @@ let create_multiline ~jobs =
let create_dummy () = Dummy
let create_dummy () = Dummy
let update_status_multiline task_bar ~ slot : job t0 status =
let update_status_multiline task_bar ~ slot : job t0 status =
( task_bar . statuses) . ( job ) <- status ;
( task_bar . jobs_ statuses) . ( job ) <- status ;
( task_bar . start_times) . ( job ) <- t0 ;
( task_bar . jobs_ start_times) . ( job ) <- t0 ;
()
()