Merge pull request #2385 from ocaml/bobot/simplify_console_handling

Move status line generator global state from Console to Scheduler

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

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

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
 

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,19 +72,15 @@ let init display =
     T.display;
     status_line = Pp.nop;
     status_line_len = 0;
-    gen_status_line = (fun () -> { message = None; show_jobs = false; });
   }
 
 let t () =
   Option.value_exn !t_var
 
 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

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