diff --git a/src/main.ml b/src/main.ml index 025e35ac4e0..b9e861a0c95 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 aa0f84949c3..32686aa1b08 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -523,11 +523,31 @@ 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 () -> { message = None; show_jobs = false; }) + let update_status_line () = - Console.update_status_line ~running_jobs:(Event.pending_jobs ()) + let gen_status_line = !status_line_generator () in + match gen_status_line with + | { message = None; _ } -> + Console.clear_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 = - 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 @@ -647,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 (); @@ -746,7 +766,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/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 e13ba995118..87a052eba9d 100644 --- a/src/stdune/console.ml +++ b/src/stdune/console.ml @@ -13,74 +13,56 @@ module Display = struct ] end -type status_line_config = - { message : User_message.Style.t Pp.t option - ; show_jobs : bool - } - module T = struct type t = { 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 = 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 ~running_jobs = + let update_status_line t status_line = if t.display = Progress then begin - match t.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; + t.status_line <- status_line; + 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 - 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 +72,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,11 +79,8 @@ 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 hide_status_line () = T.hide_status_line (t ()) +let update_status_line status_line = T.update_status_line (t ()) status_line +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 047389f8ea8..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 = @@ -17,19 +20,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 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 : User_message.Style.t Pp.t -> unit +(** Update the status line if the display is in progress mode. *) + +val clear_status_line : unit -> unit +(** Clear the status line *) -val update_status_line : running_jobs:int -> unit -val hide_status_line : unit -> unit val display : unit -> Display.t