Add using_terminal stanza

bin/init.ml

@@ -65,7 +65,7 @@ let public_name_conv =
 
 let print_completion kind name =
   let open Pp.O in
-  Console.print_user_message
+  Dune_util.Console.print_user_message
     (User_message.make
        [ Pp.tag User_message.Style.Ok (Pp.verbatim "Success")
          ++ Pp.textf ": initialized %s component named " (Kind.to_string kind)

src/dune_engine/action.ml

@@ -158,7 +158,8 @@ let fold_one_step t ~init:acc ~f =
   | Redirect_in (_, _, t)
   | Ignore (_, t)
   | With_accepted_exit_codes (_, t)
-  | No_infer t ->
+  | No_infer t
+  | Using_terminal t ->
     f acc t
   | Progn l
   | Pipe (_, l) ->
@@ -206,7 +207,8 @@ let rec is_dynamic = function
   | Redirect_in (_, _, t)
   | Ignore (_, t)
   | With_accepted_exit_codes (_, t)
-  | No_infer t ->
+  | No_infer t
+  | Using_terminal t ->
     is_dynamic t
   | Progn l
   | Pipe (_, l) ->
@@ -292,6 +294,7 @@ let is_useful_to distribute memoize =
     | With_accepted_exit_codes (_, t)
     | No_infer t ->
       loop t
+    | Using_terminal t -> loop t
     | Progn l
     | Pipe (_, l) ->
       List.exists l ~f:loop

src/dune_engine/action_ast.ml

@@ -272,6 +272,7 @@ struct
         ; target into
         ]
     | No_infer r -> List [ atom "no-infer"; encode r ]
+    | Using_terminal t -> List [ atom "using-terminal"; encode t ]
     | Pipe (outputs, l) ->
       List
         ( atom (sprintf "pipe-%s" (Outputs.to_string outputs))

src/dune_engine/action_dune_lang.ml

@@ -47,7 +47,8 @@ let ensure_at_most_one_dynamic_run ~loc action =
     | Redirect_in (_, _, t)
     | Ignore (_, t)
     | With_accepted_exit_codes (_, t)
-    | No_infer t ->
+    | No_infer t
+    | Using_terminal t ->
       loop t
     | Run _
     | Echo _

src/dune_engine/action_exec.ml

@@ -355,6 +355,14 @@ let rec exec t ~ectx ~eenv =
     Io.write_lines target (String.Set.to_list lines);
     Fiber.return Done
   | No_infer t -> exec t ~ectx ~eenv
+  | Using_terminal t ->
+    Console.with_terminal_lock (fun () ->
+        exec t ~ectx
+          ~eenv:
+            { eenv with
+              stdout_to = Process.Io.stdout
+            ; stderr_to = Process.Io.stderr
+            })
   | Pipe (outputs, l) -> exec_pipe ~ectx ~eenv outputs l
   | Format_dune_file (src, dst) ->
     Format_dune_lang.format_file ~input:(Some src)

src/dune_engine/action_intf.ml

@@ -47,6 +47,7 @@ module type Ast = sig
     | Diff of (path, target) Diff.t
     | Merge_files_into of path list * string list * target
     | No_infer of t
+    | Using_terminal of t
     | Pipe of Outputs.t * t list
     | Format_dune_file of path * target
     | Cram of path

src/dune_engine/action_mapper.ml

@@ -50,6 +50,7 @@ module Make (Src : Action_intf.Ast) (Dst : Action_intf.Ast) = struct
         , List.map extras ~f:(f_string ~dir)
         , f_target ~dir target )
     | No_infer t -> No_infer (f t ~dir)
+    | Using_terminal t -> Using_terminal (f t ~dir)
     | Pipe (outputs, l) -> Pipe (outputs, List.map l ~f:(fun t -> f t ~dir))
     | Format_dune_file (src, dst) ->
       Format_dune_file (f_path ~dir src, f_target ~dir dst)

src/dune_engine/import.ml

@@ -1,4 +1,5 @@
 include Stdune
+module Console = Dune_util.Console
 module Log = Dune_util.Log
 module Re = Dune_re
 

src/dune_rules/action_to_sh.ml

@@ -90,6 +90,7 @@ let simplify act =
            (String.quote_for_shell target))
       :: acc
     | No_infer act -> loop act acc
+    | Using_terminal act -> loop act acc
     | Pipe (outputs, l) -> Pipe (List.map ~f:block l, outputs) :: acc
     | Format_dune_file (src, dst) ->
       Redirect_out

src/dune_rules/action_unexpanded.ml

@@ -202,6 +202,7 @@ module Partial = struct
         , List.map ~f:(E.string ~expander) extras
         , E.target ~expander target )
     | No_infer t -> No_infer (expand t ~expander)
+    | Using_terminal t -> Using_terminal (expand t ~expander)
     | Pipe (outputs, l) -> Pipe (outputs, List.map l ~f:(expand ~expander))
     | Format_dune_file (src, dst) ->
       Format_dune_file (E.path ~expander src, E.target ~expander dst)
@@ -318,6 +319,7 @@ let rec partial_expand t ~expander : Partial.t =
       , List.map extras ~f:(E.string ~expander)
       , E.target ~expander target )
   | No_infer t -> No_infer (partial_expand t ~expander)
+  | Using_terminal t -> Using_terminal (partial_expand t ~expander)
   | Pipe (outputs, l) -> Pipe (outputs, List.map l ~f:(partial_expand ~expander))
   | Format_dune_file (src, dst) ->
     Format_dune_file (E.path ~expander src, E.target ~expander dst)
@@ -425,7 +427,8 @@ end = struct
         acc +< src +@+ dst
       | Chdir (_, t)
       | Setenv (_, _, t)
-      | Ignore (_, t) ->
+      | Ignore (_, t)
+      | Using_terminal t ->
         infer acc t
       | Progn l
       | Pipe (_, l) ->

src/stdune/console.ml → src/dune_util/console.ml

@@ -1,3 +1,7 @@
+open Stdune
+
+let terminal_lock = Fiber.Mutex.create ()
+
 module Backend = struct
   module type S = sig
     val print_user_message : User_message.t -> unit
@@ -69,10 +73,39 @@ module Backend = struct
     let reset () = Dumb.reset ()
   end
 
+  module Buffered = struct
+    type event =
+      | Message of User_message.t
+      | Reset
+
+    let underlying = ref (module Dumb : S)
+
+    let buffer : event Queue.t = Queue.create ()
+
+    let print_user_message msg = Queue.push buffer (Message msg)
+
+    let set_status_line _ = ()
+
+    (* I'm unsure of what the behavior should be here. My gut tells me that it
+       is less surprising to do nothing (and thus preserving the entire log),
+       but it may also be more correct to render the buffered outbut in its
+       entirety, resets and all. *)
+    let reset () = Queue.push buffer Reset
+
+    let restore () =
+      let (module P : S) = !underlying in
+      Queue.iter buffer ~f:(function
+        | Message msg -> P.print_user_message msg
+        | Reset -> P.reset ());
+      Queue.clear buffer
+  end
+
   let dumb = (module Dumb : S)
 
   let progress = (module Progress : S)
 
+  let buffered = (module Buffered : S)
+
   let main = ref dumb
 
   let set t = main := t
@@ -107,6 +140,26 @@ let reset () =
   let (module M : Backend.S) = !Backend.main in
   M.reset ()
 
+let lock () =
+  Backend.Buffered.underlying := !Backend.main;
+  Backend.main := Backend.buffered
+
+let unlock () =
+  Backend.Buffered.restore ();
+  Backend.main := !Backend.Buffered.underlying
+
+let with_terminal_lock f =
+  let open Fiber.O in
+  Fiber.Mutex.with_lock terminal_lock (fun () ->
+      lock ();
+      try
+        let* result = f () in
+        unlock ();
+        Fiber.return result
+      with e ->
+        unlock ();
+        raise e)
+
 module Status_line = struct
   type t = unit -> User_message.Style.t Pp.t option
 
@@ -118,7 +171,7 @@ module Status_line = struct
     | Some pp ->
       (* Always put the status line inside a horizontal to force the [Format]
          module to prefer a single line. In particular, it seems that
-         [Format.pp_print_text] split sthe line before the last word, unless it
+         [Format.pp_print_text] splits the line before the last word, unless it
          is succeeded by a space. This seems like a bug in [Format] and putting
          the whole thing into a [hbox] works around this bug.
 

src/stdune/console.mli → src/dune_util/console.mli

@@ -5,6 +5,8 @@
     be something else. This module allow to set a global backend for the
     application as well as composing backends. *)
 
+open Stdune
+
 module Backend : sig
   module type S = sig
     (** Format and print a user message to the console *)
@@ -41,6 +43,11 @@ include Backend.S
     {[ print_user_message (User_message.make paragraphs) ]} *)
 val print : User_message.Style.t Pp.t list -> unit
 
+(** [with_terminal_lock f] will run [f ()] under a mutex, during which all
+    writes to the console (from [Backend]) will be buffered to be displayed upon
+    release of the lock. *)
+val with_terminal_lock : (unit -> 'a Fiber.t) -> 'a Fiber.t
+
 module Status_line : sig
   (** This module allows to buffer status updates so that they don't slow down
       the application *)

src/dune_util/dune

@@ -1,4 +1,5 @@
 (library
  (name dune_util)
  (public_name dune-private-libs.dune_util)
- (libraries stdune))
+ (libraries stdune fiber)
+ (synopsis "Internal dune library, do not use!"))

src/fiber/dune

@@ -1,4 +1,5 @@
 (library
  (name fiber)
  (libraries stdune)
+ (public_name dune-private-libs.fiber)
  (synopsis "Monadic concurrency library"))

src/stdune/stdune.ml

@@ -4,7 +4,6 @@ module Array = Array
 module Bytes = Bytes
 module Char = Char
 module Comparator = Comparator
-module Console = Console
 module Csexp = Csexp
 module Daemonize = Daemonize
 module Either = Either

test/expect-tests/common/dune_tests_common.ml

@@ -10,7 +10,7 @@ let init =
       ( Printexc.record_backtrace false;
         Path.set_root (Path.External.cwd ());
         Path.Build.set_build_dir (Path.Build.Kind.of_string "_build");
-        Console.Backend.(set dumb);
+        Dune_util.Console.Backend.(set dumb);
         Dune_util.Log.init () )
   in
   fun () -> Lazy.force init