refactor(console): split Dune_console.Backend (#7000

Move the dumb and progress backends to their own files.

Move flushing/composition to a [Combinators] module

Finally, [Console.Backend.progress] is now flushing. Previously, it
wouldn't flush and was therefore buggy. This didn't affect dune, as we
only used [progress_threaded].

Signed-off-by: Rudi Grinberg <[email protected]>

boot/libs.ml

@@ -51,6 +51,7 @@ let local_libraries =
   ; ("src/fswatch_win", Some "Fswatch_win", false, None)
   ; ("src/dune_file_watcher", Some "Dune_file_watcher", false, None)
   ; ("src/dune_engine", Some "Dune_engine", false, None)
+  ; ("src/dune_threaded_console", Some "Dune_threaded_console", false, None)
   ; ("src/dune_config", Some "Dune_config", false, None)
   ; ("src/dune_rules", Some "Dune_rules", true, None)
   ; ("src/upgrader", Some "Dune_upgrader", false, None)

src/dune_config/display.ml

@@ -34,4 +34,4 @@ let to_dyn { status_line; verbosity } : Dyn.t =
 let console_backend t =
   match t.status_line with
   | false -> Dune_console.Backend.dumb
-  | true -> Dune_console.Backend.progress_threaded ()
+  | true -> Dune_threaded_console.progress ()

src/dune_config/dune

@@ -4,6 +4,7 @@
   stdune
   xdg
   dune_console
+  dune_threaded_console
   dune_lang
   dune_cache
   dune_cache_storage

src/dune_console/combinators.ml

@@ -0,0 +1,52 @@
+let flush (module Backend : Backend_intf.S) : Backend_intf.t =
+  (module struct
+    include Backend
+
+    let print_if_no_status_line msg =
+      print_if_no_status_line msg;
+      flush stderr
+
+    let print_user_message msg =
+      print_user_message msg;
+      flush stderr
+
+    let reset () =
+      reset ();
+      flush stderr
+
+    let reset_flush_history () =
+      reset_flush_history ();
+      flush stderr
+  end : Backend_intf.S)
+
+let compose (module A : Backend_intf.S) (module B : Backend_intf.S) :
+    (module Backend_intf.S) =
+  (module struct
+    let start () =
+      A.start ();
+      B.start ()
+
+    let print_user_message msg =
+      A.print_user_message msg;
+      B.print_user_message msg
+
+    let set_status_line x =
+      A.set_status_line x;
+      B.set_status_line x
+
+    let finish () =
+      A.finish ();
+      B.finish ()
+
+    let print_if_no_status_line msg =
+      A.print_if_no_status_line msg;
+      B.print_if_no_status_line msg
+
+    let reset () =
+      A.reset ();
+      B.reset ()
+
+    let reset_flush_history () =
+      A.reset_flush_history ();
+      B.reset_flush_history ()
+  end : Backend_intf.S)

src/dune_console/combinators.mli

@@ -0,0 +1,5 @@
+(** Add a [flush stderr] after every UI operation *)
+val flush : Backend_intf.t -> Backend_intf.t
+
+(** Creates a backend that writes to both backends in sequence *)
+val compose : Backend_intf.t -> Backend_intf.t -> Backend_intf.t

src/dune_console/dumb.ml

@@ -0,0 +1,28 @@
+open Stdune
+
+module No_flush : Backend_intf.S = struct
+  let start () = ()
+
+  let finish () = ()
+
+  let print_user_message msg =
+    Option.iter msg.User_message.loc ~f:(fun loc ->
+        Loc.render Format.err_formatter (Loc.pp loc));
+    User_message.prerr { msg with loc = None }
+
+  let set_status_line _ = ()
+
+  let print_if_no_status_line msg =
+    (* [Pp.cut] seems to be enough to force the terminating newline to
+        appear. *)
+    Ansi_color.prerr
+      (Pp.seq (Pp.map_tags msg ~f:User_message.Print_config.default) Pp.cut)
+
+  let reset () = prerr_string "\x1b[H\x1b[2J"
+
+  let reset_flush_history () = prerr_string "\x1b[1;1H\x1b[2J\x1b[3J"
+end
+
+let flush = Combinators.flush (module No_flush)
+
+include (val flush)

src/dune_console/dumb.mli

@@ -0,0 +1,5 @@
+(** Output to a terminal without any capbilities and without flushing *)
+module No_flush : Backend_intf.S
+
+(** Output to a terminal without any capbilities with flushing *)
+include Backend_intf.S

src/dune_console/dune

@@ -1,5 +1,5 @@
 (library
  (name dune_console)
- (libraries stdune threads.posix)
+ (libraries stdune)
  (instrumentation
   (backend bisect_ppx)))

src/dune_console/dune_console.ml

@@ -1,94 +1,15 @@
 open Stdune
 
+module type Backend = Backend_intf.S
+
 module Backend = struct
   type t = Backend_intf.t
 
-  module Dumb_no_flush : Backend_intf.S = struct
-    let start () = ()
-
-    let finish () = ()
-
-    let print_user_message msg =
-      Option.iter msg.User_message.loc ~f:(fun loc ->
-          Loc.render Format.err_formatter (Loc.pp loc));
-      User_message.prerr { msg with loc = None }
-
-    let set_status_line _ = ()
-
-    let print_if_no_status_line msg =
-      (* [Pp.cut] seems to be enough to force the terminating newline to
-         appear. *)
-      Ansi_color.prerr
-        (Pp.seq (Pp.map_tags msg ~f:User_message.Print_config.default) Pp.cut)
-
-    let reset () = prerr_string "\x1b[H\x1b[2J"
-
-    let reset_flush_history () = prerr_string "\x1b[1;1H\x1b[2J\x1b[3J"
-  end
-
-  module Dumb : Backend_intf.S = struct
-    include Dumb_no_flush
-
-    let print_if_no_status_line msg =
-      print_if_no_status_line msg;
-      flush stderr
-
-    let print_user_message msg =
-      print_user_message msg;
-      flush stderr
-
-    let reset () =
-      reset ();
-      flush stderr
-
-    let reset_flush_history () =
-      reset_flush_history ();
-      flush stderr
-  end
-
-  module Progress_no_flush : Backend_intf.S = struct
-    let status_line = ref Pp.nop
-
-    let start () = ()
-
-    let status_line_len = ref 0
-
-    let hide_status_line () =
-      if !status_line_len > 0 then Printf.eprintf "\r%*s\r" !status_line_len ""
-
-    let show_status_line () =
-      if !status_line_len > 0 then Ansi_color.prerr !status_line
-
-    let set_status_line = function
-      | None ->
-        hide_status_line ();
-        status_line := Pp.nop;
-        status_line_len := 0
-      | Some line ->
-        let line = Pp.map_tags line ~f:User_message.Print_config.default in
-        let line_len = String.length (Format.asprintf "%a" Pp.to_fmt line) in
-        hide_status_line ();
-        status_line := line;
-        status_line_len := line_len;
-        show_status_line ()
-
-    let print_if_no_status_line _msg = ()
-
-    let print_user_message msg =
-      hide_status_line ();
-      Dumb_no_flush.print_user_message msg;
-      show_status_line ()
-
-    let reset () = Dumb.reset ()
-
-    let finish () = set_status_line None
-
-    let reset_flush_history () = Dumb.reset_flush_history ()
-  end
-
   let dumb = (module Dumb : Backend_intf.S)
 
-  let progress = (module Progress_no_flush : Backend_intf.S)
+  let progress = Progress.no_flush
+
+  let compose = Combinators.compose
 
   let main = ref dumb
 
@@ -98,64 +19,9 @@ module Backend = struct
     main := (module T);
     T.start ()
 
-  let compose (module A : Backend_intf.S) (module B : Backend_intf.S) :
-      (module Backend_intf.S) =
-    (module struct
-      let start () =
-        A.start ();
-        B.start ()
-
-      let print_user_message msg =
-        A.print_user_message msg;
-        B.print_user_message msg
-
-      let set_status_line x =
-        A.set_status_line x;
-        B.set_status_line x
-
-      let finish () =
-        A.finish ();
-        B.finish ()
-
-      let print_if_no_status_line msg =
-        A.print_if_no_status_line msg;
-        B.print_if_no_status_line msg
-
-      let reset () =
-        A.reset ();
-        B.reset ()
-
-      let reset_flush_history () =
-        A.reset_flush_history ();
-        B.reset_flush_history ()
-    end : Backend_intf.S)
-
-  module Progress_no_flush_threaded : Threaded_intf.S = struct
-    include Progress_no_flush
-
-    let render (state : Threaded_intf.state) =
-      while not (Queue.is_empty state.messages) do
-        print_user_message (Queue.pop_exn state.messages)
-      done;
-      set_status_line state.status_line;
-      flush stderr
-
-    (* The current console doesn't react to user events so we just sleep until
-       the next loop iteration. Because it doesn't react to user input, it cannot
-       modify the UI state, and as a consequence doesn't need the mutex. *)
-    let handle_user_events ~now ~time_budget _ =
-      Unix.sleepf time_budget;
-      now +. time_budget
-  end
-
-  let progress_threaded =
-    let t = lazy (Threaded.make (module Progress_no_flush_threaded)) in
-    fun () -> Lazy.force t
-end
+  let flush t = Combinators.flush t
 
-module Threaded = struct
-  include Threaded_intf
-  include Threaded
+  let progress_no_flush = Progress.no_flush
 end
 
 let print_user_message msg =

src/dune_console/dune_console.mli

@@ -7,8 +7,35 @@ open Stdune
     be something else. This module allow to set a global backend for the
     application as well as composing backends. *)
 
+module type Backend = sig
+  (** The interface of a custom console backend. *)
+
+  (** Start the backend. This is guaranteed to be called before all other
+      functions. *)
+  val start : unit -> unit
+
+  (** Output a basic user message to the screen. *)
+  val print_user_message : User_message.t -> unit
+
+  (** Set the status line. *)
+  val set_status_line : User_message.Style.t Pp.t option -> unit
+
+  (** Print a message if the backend doesn't support a persistent status line. *)
+  val print_if_no_status_line : User_message.Style.t Pp.t -> unit
+
+  (** Reset the display. *)
+  val reset : unit -> unit
+
+  (** Reset the display and flush history. *)
+  val reset_flush_history : unit -> unit
+
+  (** Finalize the backend. After this function is called, it is guaranteed that
+      no other functions will be called. *)
+  val finish : unit -> unit
+end
+
 module Backend : sig
-  type t
+  type t = (module Backend)
 
   val set : t -> unit
 
@@ -23,21 +50,12 @@ module Backend : sig
   (** A backend that displays the status line in the terminal. *)
   val progress : t
 
-  (** A backend that displays the status line in the terminal, with the
-      processing logic happening in a separate thread. *)
-  val progress_threaded : unit -> t
-end
-
-module Threaded : sig
-  include module type of Threaded_intf
-
-  (** [spawn_thread f] is called by the main thread to spawn a new thread. The
-      thread should call [f] to start the user interface. This forward
-      declaration allows the function to be set much later in the scheduler when
-      the operation is defined. This is only useful for threaded backends. *)
-  val spawn_thread : ((unit -> unit) -> unit) Fdecl.t
+  (** [flush t] returns a backend that will flush [stderr] after every write *)
+  val flush : t -> t
 
-  val make : (module S) -> Backend.t
+  (** A base progress backend that doesn't flush. Any backend implemented on top
+      if is expected to flush manually *)
+  val progress_no_flush : t
 end
 
 (** Format and print a user message to the console. *)

src/dune_console/progress.ml

@@ -0,0 +1,45 @@
+open Stdune
+
+module No_flush = struct
+  let status_line = ref Pp.nop
+
+  let start () = ()
+
+  let status_line_len = ref 0
+
+  let hide_status_line () =
+    if !status_line_len > 0 then Printf.eprintf "\r%*s\r" !status_line_len ""
+
+  let show_status_line () =
+    if !status_line_len > 0 then Ansi_color.prerr !status_line
+
+  let set_status_line = function
+    | None ->
+      hide_status_line ();
+      status_line := Pp.nop;
+      status_line_len := 0
+    | Some line ->
+      let line = Pp.map_tags line ~f:User_message.Print_config.default in
+      let line_len = String.length (Format.asprintf "%a" Pp.to_fmt line) in
+      hide_status_line ();
+      status_line := line;
+      status_line_len := line_len;
+      show_status_line ()
+
+  let print_if_no_status_line _msg = ()
+
+  let print_user_message msg =
+    hide_status_line ();
+    Dumb.No_flush.print_user_message msg;
+    show_status_line ()
+
+  let reset () = Dumb.reset ()
+
+  let finish () = set_status_line None
+
+  let reset_flush_history () = Dumb.reset_flush_history ()
+end
+
+let no_flush = (module No_flush : Backend_intf.S)
+
+let flush = Combinators.flush no_flush