From 08f2454679d2e02c2f1d4abc2efe3969bbbef9b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Bobot?= Date: Mon, 8 Jul 2019 20:52:11 +0200 Subject: [PATCH 1/3] Move status line generator global state from Console to Scheduler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: François Bobot --- src/scheduler.ml | 10 +++++++--- src/stdune/console.ml | 14 +++----------- src/stdune/console.mli | 5 +---- 3 files changed, 11 insertions(+), 18 deletions(-) diff --git a/src/scheduler.ml b/src/scheduler.ml index aa0f84949c3..f3f916643ce 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -523,11 +523,15 @@ let with_chdir t ~dir ~f = let t_var : t Fiber.Var.t = Fiber.Var.create () + +let status_line_generator = ref (fun () -> { Console.message = None; show_jobs = false; }) + let update_status_line () = - Console.update_status_line ~running_jobs:(Event.pending_jobs ()) + Console.update_status_line (!status_line_generator ()) ~running_jobs:(Event.pending_jobs ()) let set_status_line_generator gen = - Console.set_status_line_generator ~running_jobs:(Event.pending_jobs ()) gen + status_line_generator := gen; + update_status_line () let set_concurrency n = let t = Fiber.Var.get_exn t_var in @@ -746,7 +750,7 @@ let poll ?log ?config ~once ~finally () = Exit in let wait msg = - let old_generator = Console.get_status_line_generator () in + let old_generator = !status_line_generator in set_status_line_generator (fun () -> { message = Some (Pp.seq msg diff --git a/src/stdune/console.ml b/src/stdune/console.ml index e13ba995118..9341969612d 100644 --- a/src/stdune/console.ml +++ b/src/stdune/console.ml @@ -24,7 +24,6 @@ module T = struct display : Display.t; mutable status_line : Ansi_color.Style.t list Pp.t; mutable status_line_len : int; - mutable gen_status_line : unit -> status_line_config; } let hide_status_line t = @@ -34,9 +33,9 @@ module T = struct let show_status_line s = Ansi_color.prerr s - let update_status_line t ~running_jobs = + let update_status_line t gen_status_line ~running_jobs = if t.display = Progress then begin - match t.gen_status_line () with + match gen_status_line with | { message = None; _ } -> hide_status_line t; flush stderr @@ -78,9 +77,6 @@ module T = struct hide_status_line t; flush stderr - let set_status_line_generator t f ~running_jobs = - t.gen_status_line <- f; - update_status_line t ~running_jobs end let t_var = ref None @@ -90,7 +86,6 @@ let init display = T.display; status_line = Pp.nop; status_line_len = 0; - gen_status_line = (fun () -> { message = None; show_jobs = false; }); } let t () = @@ -98,10 +93,7 @@ let t () = let display () = (t ()).display -let get_status_line_generator () = (t ()).gen_status_line -let set_status_line_generator f ~running_jobs = - T.set_status_line_generator (t ()) f ~running_jobs -let update_status_line ~running_jobs = T.update_status_line (t ()) ~running_jobs +let update_status_line gen ~running_jobs = T.update_status_line (t ()) gen ~running_jobs let hide_status_line () = T.hide_status_line (t ()) let print msg = match !t_var with diff --git a/src/stdune/console.mli b/src/stdune/console.mli index 047389f8ea8..5c0f01e1151 100644 --- a/src/stdune/console.mli +++ b/src/stdune/console.mli @@ -27,9 +27,6 @@ val init : Display.t -> unit (** / *) (** Everything below this line requires [init] to have been called earlier. *) -val get_status_line_generator : unit -> (unit -> status_line_config) -val set_status_line_generator : (unit -> status_line_config) -> running_jobs:int -> unit - -val update_status_line : running_jobs:int -> unit +val update_status_line : status_line_config -> running_jobs:int -> unit val hide_status_line : unit -> unit val display : unit -> Display.t From fe236fa54112dd23d8637b5ed6f55480797db156 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Bobot?= Date: Tue, 9 Jul 2019 12:21:37 +0200 Subject: [PATCH 2/3] Simplify console by only requesting the line to print MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: François Bobot --- src/main.ml | 2 +- src/scheduler.ml | 20 ++++++++++++++++++-- src/scheduler.mli | 7 ++++++- src/stdune/console.ml | 43 +++++++++++++----------------------------- src/stdune/console.mli | 11 +++++------ 5 files changed, 43 insertions(+), 40 deletions(-) diff --git a/src/main.ml b/src/main.ml index 7f1eadf187e..7e4f25d23b0 100644 --- a/src/main.ml +++ b/src/main.ml @@ -87,7 +87,7 @@ let init_build_system ?only_packages ?external_lib_deps_mode w = let rule_done = ref 0 in let rule_total = ref 0 in let gen_status_line () = - { Console. + { Scheduler. message = Some (Pp.verbatim (sprintf "Done: %u/%u" !rule_done !rule_total)) ; show_jobs = true diff --git a/src/scheduler.ml b/src/scheduler.ml index f3f916643ce..37c820e168a 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -523,11 +523,27 @@ let with_chdir t ~dir ~f = let t_var : t Fiber.Var.t = Fiber.Var.create () +type status_line_config = + { message : User_message.Style.t Pp.t option + ; show_jobs : bool + } -let status_line_generator = ref (fun () -> { Console.message = None; show_jobs = false; }) +let status_line_generator = ref (fun () -> { message = None; show_jobs = false; }) let update_status_line () = - Console.update_status_line (!status_line_generator ()) ~running_jobs:(Event.pending_jobs ()) + let gen_status_line = !status_line_generator () in + match gen_status_line with + | { message = None; _ } -> + Console.hide_status_line (); + | { message = Some status_line; show_jobs } -> + let status_line = + if show_jobs then + Pp.seq status_line + (Pp.verbatim (Printf.sprintf " (jobs: %u)" (Event.pending_jobs ()))) + else + status_line + in + Console.update_status_line status_line let set_status_line_generator gen = status_line_generator := gen; diff --git a/src/scheduler.mli b/src/scheduler.mli index 44f7549b140..1e60d63ae8e 100644 --- a/src/scheduler.mli +++ b/src/scheduler.mli @@ -25,8 +25,13 @@ val poll (** Wait for the following process to terminate *) val wait_for_process : int -> Unix.process_status Fiber.t +type status_line_config = + { message : User_message.Style.t Pp.t option + ; show_jobs : bool + } + (** Set the status line generator for the current scheduler *) -val set_status_line_generator : (unit -> Console.status_line_config) -> unit +val set_status_line_generator : (unit -> status_line_config) -> unit val set_concurrency : int -> unit diff --git a/src/stdune/console.ml b/src/stdune/console.ml index 9341969612d..59a036ec5d6 100644 --- a/src/stdune/console.ml +++ b/src/stdune/console.ml @@ -13,11 +13,6 @@ module Display = struct ] end -type status_line_config = - { message : User_message.Style.t Pp.t option - ; show_jobs : bool - } - module T = struct type t = { @@ -33,31 +28,19 @@ module T = struct let show_status_line s = Ansi_color.prerr s - let update_status_line t gen_status_line ~running_jobs = + let update_status_line t status_line = if t.display = Progress then begin - match gen_status_line with - | { message = None; _ } -> - hide_status_line t; - flush stderr - | { message = Some status_line; show_jobs } -> - let status_line = - if show_jobs then - Pp.seq status_line - (Pp.verbatim (Printf.sprintf " (jobs: %u)" running_jobs)) - else - status_line - in - let status_line = - Pp.map_tags status_line ~f:User_message.Print_config.default - in - let status_line_len = - String.length (Format.asprintf "%a" Pp.render_ignore_tags status_line) - in - hide_status_line t; - show_status_line status_line; - flush stderr; - t.status_line <- status_line; - t.status_line_len <- status_line_len + let status_line = + Pp.map_tags status_line ~f:User_message.Print_config.default + in + let status_line_len = + String.length (Format.asprintf "%a" Pp.render_ignore_tags status_line) + in + hide_status_line t; + show_status_line status_line; + flush stderr; + t.status_line <- status_line; + t.status_line_len <- status_line_len end let print t msg = @@ -93,7 +76,7 @@ let t () = let display () = (t ()).display -let update_status_line gen ~running_jobs = T.update_status_line (t ()) gen ~running_jobs +let update_status_line status_line = T.update_status_line (t ()) status_line let hide_status_line () = T.hide_status_line (t ()) let print msg = match !t_var with diff --git a/src/stdune/console.mli b/src/stdune/console.mli index 5c0f01e1151..45b350b1fcf 100644 --- a/src/stdune/console.mli +++ b/src/stdune/console.mli @@ -17,16 +17,15 @@ val print_user_message -> User_message.t -> unit -type status_line_config = - { message : User_message.Style.t Pp.t option - ; show_jobs : bool - } - val init : Display.t -> unit (** / *) (** Everything below this line requires [init] to have been called earlier. *) -val update_status_line : status_line_config -> running_jobs:int -> unit +val update_status_line : User_message.Style.t Pp.t -> unit +(** Update the status line if the display is in progress mode *) + val hide_status_line : unit -> unit +(** Hide the status line *) + val display : unit -> Display.t From cde9860362559e13e961c72d1a972ab2bc68cfc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Bobot?= Date: Tue, 9 Jul 2019 12:32:26 +0200 Subject: [PATCH 3/3] Hiding the status line means also to forget it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Otherwise hiding then printing user message would show back the old status line Signed-off-by: François Bobot --- src/scheduler.ml | 4 ++-- src/stdune/console.ml | 21 ++++++++++++--------- src/stdune/console.mli | 9 ++++++--- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/src/scheduler.ml b/src/scheduler.ml index 37c820e168a..32686aa1b08 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -534,7 +534,7 @@ let update_status_line () = let gen_status_line = !status_line_generator () in match gen_status_line with | { message = None; _ } -> - Console.hide_status_line (); + Console.clear_status_line (); | { message = Some status_line; show_jobs } -> let status_line = if show_jobs then @@ -667,7 +667,7 @@ end = struct let* () = Fiber.yield () in let count = Event.pending_jobs () in if count = 0 then begin - Console.hide_status_line (); + Console.clear_status_line (); Fiber.return Done end else begin update_status_line (); diff --git a/src/stdune/console.ml b/src/stdune/console.ml index 59a036ec5d6..87a052eba9d 100644 --- a/src/stdune/console.ml +++ b/src/stdune/console.ml @@ -25,8 +25,9 @@ module T = struct if t.status_line_len > 0 then Printf.eprintf "\r%*s\r" t.status_line_len "" - let show_status_line s = - Ansi_color.prerr s + let show_status_line t = + if t.status_line_len > 0 then + Ansi_color.prerr t.status_line let update_status_line t status_line = if t.display = Progress then begin @@ -37,27 +38,29 @@ module T = struct String.length (Format.asprintf "%a" Pp.render_ignore_tags status_line) in hide_status_line t; - show_status_line status_line; - flush stderr; t.status_line <- status_line; - t.status_line_len <- status_line_len + t.status_line_len <- status_line_len; + show_status_line t; + flush stderr; end let print t msg = hide_status_line t; prerr_string msg; - show_status_line t.status_line; + show_status_line t; flush stderr let print_user_message t ?config msg = hide_status_line t; Option.iter msg.User_message.loc ~f:(Loc.print Format.err_formatter); User_message.prerr ?config { msg with loc = None }; - show_status_line t.status_line; + show_status_line t; flush stderr - let hide_status_line t = + let clear_status_line t = hide_status_line t; + t.status_line <- Pp.nop; + t.status_line_len <- 0; flush stderr end @@ -77,7 +80,7 @@ let t () = let display () = (t ()).display let update_status_line status_line = T.update_status_line (t ()) status_line -let hide_status_line () = T.hide_status_line (t ()) +let clear_status_line () = T.clear_status_line (t ()) let print msg = match !t_var with | None -> Printf.eprintf "%s%!" msg diff --git a/src/stdune/console.mli b/src/stdune/console.mli index 45b350b1fcf..a4f3095d7f8 100644 --- a/src/stdune/console.mli +++ b/src/stdune/console.mli @@ -1,3 +1,6 @@ +(** Manage printing user message and keeping progress information in the status line *) + + module Display : sig type t = @@ -23,9 +26,9 @@ val init : Display.t -> unit (** Everything below this line requires [init] to have been called earlier. *) val update_status_line : User_message.Style.t Pp.t -> unit -(** Update the status line if the display is in progress mode *) +(** Update the status line if the display is in progress mode. *) -val hide_status_line : unit -> unit -(** Hide the status line *) +val clear_status_line : unit -> unit +(** Clear the status line *) val display : unit -> Display.t