Passive watch mode for tests

bin/build_cmd.ml

@@ -18,47 +18,63 @@ let run_build_system ~common ~(request : unit Action_builder.t) () =
              ]));
       Fiber.return ())
 
-let run_build_command_poll ~(common : Common.t) ~config ~request ~setup =
+let setup () = Import.Main.setup ()
+
+let run_build_system ~common ~request =
   let open Fiber.O in
-  let every =
-    Fiber.of_thunk (fun () ->
-        Cached_digest.invalidate_cached_timestamps ();
-        let* setup = setup () in
-        let* request =
-          match
-            let open Option.O in
-            let* rpc = Common.rpc common in
-            Dune_rpc_impl.Server.pending_build_action rpc
-          with
-          | None -> Fiber.return (request setup)
-          | Some (Build (targets, ivar)) ->
-            let+ () = Fiber.Ivar.fill ivar Accepted in
-            Target.interpret_targets (Common.root common) config setup targets
-        in
-        run_build_system ~common ~request ())
-  in
-  Scheduler.poll ~common ~config ~every ~finally:Hooks.End_of_build.run
+  Fiber.finalize
+    (fun () ->
+      Cached_digest.invalidate_cached_timestamps ();
+      let* setup = setup () in
+      let request = request setup in
+      run_build_system ~common ~request ())
+    ~finally:(fun () ->
+      Hooks.End_of_build.run ();
+      Fiber.return ())
+
+let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit =
+  Import.Scheduler.go_with_rpc_server_and_console_status_reporting ~common
+    ~config (fun () -> Scheduler.Run.poll (run_build_system ~common ~request))
+
+let run_build_command_poll_passive ~(common : Common.t) ~config ~request:_ :
+    unit =
+  (* CR-someday aalekseyev: It would've been better to complain if [request] is
+     non-empty, but we can't check that here because [request] is a function.*)
+  let open Fiber.O in
+  match Common.rpc common with
+  | None ->
+    Code_error.raise
+      "Attempted to start a passive polling mode without an RPC server" []
+  | Some rpc ->
+    Import.Scheduler.go_with_rpc_server_and_console_status_reporting ~common
+      ~config (fun () ->
+        Scheduler.Run.poll_passive
+          ~get_build_request:
+            (let+ (Build (targets, ivar)) =
+               Dune_rpc_impl.Server.pending_build_action rpc
+             in
+             let request setup =
+               Target.interpret_targets (Common.root common) config setup
+                 targets
+             in
+             (run_build_system ~common ~request, ivar)))
 
-let run_build_command_once ~(common : Common.t) ~config ~request ~setup =
+let run_build_command_once ~(common : Common.t) ~config ~request =
   let open Fiber.O in
   let once () =
-    let* setup = setup () in
-    let+ res = run_build_system ~common ~request:(request setup) () in
+    let+ res = run_build_system ~common ~request in
     match res with
-    | Error `Already_reported ->
-      (* to ensure non-zero exit code *)
-      raise Dune_util.Report_error.Already_reported
+    | Error `Already_reported -> raise Dune_util.Report_error.Already_reported
     | Ok () -> ()
   in
   Scheduler.go ~common ~config once
 
 let run_build_command ~(common : Common.t) ~config ~request =
-  let setup () = Import.Main.setup () in
-  (if Common.watch common then
-    run_build_command_poll
-  else
-    run_build_command_once)
-    ~setup ~common ~config ~request
+  (match Common.watch common with
+  | Yes Eager -> run_build_command_poll_eager
+  | Yes Passive -> run_build_command_poll_passive
+  | No -> run_build_command_once)
+    ~common ~config ~request
 
 let runtest =
   let doc = "Run tests." in

bin/common.ml

@@ -37,7 +37,7 @@ type t =
     orig_args : string list
   ; rpc : Dune_rpc_impl.Server.t option
   ; default_target : Arg.Dep.t (* For build & runtest only *)
-  ; watch : bool
+  ; watch : Dune_engine.Watch_mode_config.t
   ; print_metrics : bool
   ; stats_trace_file : string option
   ; always_show_command_line : bool
@@ -525,6 +525,11 @@ let display_term =
             {|Control the display mode of Dune.
          See $(b,dune-config\(5\)) for more details.|})
 
+let simple_arg_conv ~to_string ~of_string =
+  Arg.conv
+    ( (fun s -> Result.map_error (of_string s) ~f:(fun s -> `Msg s))
+    , fun pp x -> Format.pp_print_string pp (to_string x) )
+
 let shared_with_config_file =
   let docs = copts_sect in
   let+ concurrency =
@@ -542,12 +547,8 @@ let shared_with_config_file =
           ~doc:{|Run no more than $(i,JOBS) commands simultaneously.|})
   and+ sandboxing_preference =
     let arg =
-      Arg.conv
-        ( (fun s ->
-            Result.map_error (Dune_engine.Sandbox_mode.of_string s) ~f:(fun s ->
-                `Msg s))
-        , fun pp x ->
-            Format.pp_print_string pp (Dune_engine.Sandbox_mode.to_string x) )
+      simple_arg_conv ~of_string:Dune_engine.Sandbox_mode.of_string
+        ~to_string:Dune_engine.Sandbox_mode.to_string
     in
     Arg.(
       value
@@ -799,9 +800,14 @@ let term =
             "Force actions associated to aliases to be re-executed even\n\
             \                   if their dependencies haven't changed.")
   and+ watch =
+    let watch_arg_name = "watch" in
     Arg.(
-      value & flag
-      & info [ "watch"; "w" ]
+      value
+      & opt ~vopt:(Dune_engine.Watch_mode_config.Yes Eager)
+          (simple_arg_conv ~to_string:Dune_engine.Watch_mode_config.to_string
+             ~of_string:Dune_engine.Watch_mode_config.of_string)
+          Dune_engine.Watch_mode_config.No
+      & info [ watch_arg_name; "w" ]
           ~doc:
             "Instead of terminating build after completion, wait continuously \
              for file changes.")
@@ -928,10 +934,9 @@ let term =
   let build_dir = Option.value ~default:default_build_dir build_dir in
   let root = Workspace_root.create ~specified_by_user:root in
   let rpc =
-    if watch then
-      Some (Dune_rpc_impl.Server.create ())
-    else
-      None
+    match watch with
+    | Yes _ -> Some (Dune_rpc_impl.Server.create ())
+    | No -> None
   in
   let stats =
     Option.map stats_trace_file ~f:(fun f ->

bin/common.mli

@@ -10,7 +10,7 @@ val stats : t -> Dune_stats.t option
 
 val print_metrics : t -> bool
 
-val watch : t -> bool
+val watch : t -> Dune_engine.Watch_mode_config.t
 
 val file_watcher : t -> Dune_engine.Scheduler.Run.file_watcher
 

bin/import.ml

@@ -32,7 +32,13 @@ include Common.Let_syntax
 
 let in_group (t, info) = (Term.Group.Term t, info)
 
-module Main = struct
+module Main : sig
+  include module type of struct
+    include Dune_rules.Main
+  end
+
+  val setup : unit -> build_system Fiber.t
+end = struct
   include Dune_rules.Main
 
   let setup () =
@@ -92,18 +98,13 @@ module Scheduler = struct
     let config = Dune_config.for_scheduler dune_config None stats in
     Scheduler.Run.go config ~on_event:(on_event dune_config) f
 
-  let poll ~(common : Common.t) ~config:dune_config ~every ~finally =
+  let go_with_rpc_server_and_console_status_reporting ~(common : Common.t)
+      ~config:dune_config run =
     let stats = Common.stats common in
     let rpc_where = Some (Dune_rpc_private.Where.default ()) in
     let config = Dune_config.for_scheduler dune_config rpc_where stats in
     let file_watcher = Common.file_watcher common in
     let run =
-      let run () =
-        Scheduler.Run.poll
-          (Fiber.finalize
-             (fun () -> every)
-             ~finally:(fun () -> Fiber.return (finally ())))
-      in
       match Common.rpc common with
       | None -> run
       | Some rpc ->