Allow running tests concurrently with watch server, again! (#12473)

* Allow running tests concurrently with watch server
* Fix 'forwarding' warning appearing too early

---------

Signed-off-by: Ambre Austen Suhamy <ambre@tarides.com>

Author: ElectreAAS

bin/build.ml

@@ -92,11 +92,16 @@ let poll_handling_rpc_build_requests ~(common : Common.t) ~config =
   in
   Dune_engine.Scheduler.Run.poll_passive
     ~get_build_request:
-      (let+ (Build (targets, ivar)) = Dune_rpc_impl.Server.pending_build_action rpc in
+      (let+ { kind; outcome } = Dune_rpc_impl.Server.pending_action rpc in
        let request setup =
-         Target.interpret_targets (Common.root common) config setup targets
+         let root = Common.root common in
+         match kind with
+         | Build targets ->
+           Target.interpret_targets (Common.root common) config setup targets
+         | Runtest dir_or_cram_test_paths ->
+           Runtest_common.make_request ~dir_or_cram_test_paths ~to_cwd:root.to_cwd setup
        in
-       run_build_system ~common ~request, ivar)
+       run_build_system ~common ~request, outcome)
 ;;
 
 let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit =
@@ -138,10 +143,10 @@ let run_build_command ~(common : Common.t) ~config ~request =
     ~request
 ;;
 
-let build_via_rpc_server ~print_on_success ~targets =
+let build_via_rpc_server ~print_on_success ~targets builder lock_held_by =
   Rpc.Rpc_common.wrap_build_outcome_exn
     ~print_on_success
-    (Rpc.Group.Build.build ~wait:true)
+    (Rpc.Group.Build.build ~wait:true builder lock_held_by)
     targets
     ()
 ;;
@@ -199,11 +204,9 @@ let build =
          perform the RPC call.
       *)
       Rpc.Rpc_common.run_via_rpc
-        ~builder
         ~common
         ~config
-        lock_held_by
-        (Rpc.Group.Build.build ~wait:true)
+        (Rpc.Group.Build.build ~wait:true builder lock_held_by)
         targets
     | Ok () ->
       let request setup =

bin/build.mli

@@ -8,6 +8,8 @@ open Import
 val build_via_rpc_server
   :  print_on_success:bool
   -> targets:Dune_lang.Dep_conf.t list
+  -> Common.Builder.t
+  -> Dune_util.Global_lock.Lock_held_by.t
   -> unit Fiber.t
 
 val run_build_system

bin/exec.ml

@@ -187,7 +187,7 @@ let step ~prog ~args ~common ~no_rebuild ~context ~on_exit () =
    directory lock.
 
    Returns the absolute path to the executable. *)
-let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog =
+let build_prog_via_rpc_if_necessary ~dir ~no_rebuild builder lock_held_by prog =
   match Filename.analyze_program_name prog with
   | In_path ->
     (* This case is reached if [dune exec] is passed the name of an
@@ -225,7 +225,11 @@ let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog =
           Dune_lang.Dep_conf.File
             (Dune_lang.String_with_vars.make_text Loc.none (Path.to_string path))
         in
-        Build.build_via_rpc_server ~print_on_success:false ~targets:[ target ])
+        Build.build_via_rpc_server
+          ~print_on_success:false
+          ~targets:[ target ]
+          builder
+          lock_held_by)
     in
     Path.to_absolute_filename path
   | Absolute ->
@@ -234,7 +238,7 @@ let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog =
     else not_found ~hints:[] ~prog
 ;;
 
-let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild =
+let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild builder lock_held_by =
   let open Fiber.O in
   let ensure_terminal v =
     match (v : Cmd_arg.t) with
@@ -252,7 +256,9 @@ let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild =
   let dir = Context_name.build_dir context in
   let prog = ensure_terminal prog in
   let args = List.map args ~f:ensure_terminal in
-  let+ prog = build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog in
+  let+ prog =
+    build_prog_via_rpc_if_necessary ~dir ~no_rebuild builder lock_held_by prog
+  in
   restore_cwd_and_execve (Common.root common) prog args Env.initial
 ;;
 
@@ -311,18 +317,9 @@ let term : unit Term.t =
               | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
          ]
      | No ->
-       if not (Common.Builder.equal builder Common.Builder.default)
-       then
-         User_warning.emit
-           [ Pp.textf
-               "Your build request is being forwarded to a running Dune instance%s. Note \
-                that certain command line arguments may be ignored."
-               (match lock_held_by with
-                | Unknown -> ""
-                | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
-           ];
        Scheduler.go_without_rpc_server ~common ~config
-       @@ fun () -> exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild)
+       @@ fun () ->
+       exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild builder lock_held_by)
   | Ok () -> exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild
 ;;
 

bin/fmt.ml

@@ -26,7 +26,7 @@ let lock_ocamlformat () =
   else Fiber.return ()
 ;;
 
-let run_fmt_command ~common ~config ~preview =
+let run_fmt_command ~common ~config ~preview builder =
   let open Fiber.O in
   let once () =
     let* () = lock_ocamlformat () in
@@ -50,6 +50,9 @@ let run_fmt_command ~common ~config ~preview =
         Rpc.Rpc_common.fire_request
           ~name:"format"
           ~wait:true
+          ~warn_forwarding:false
+          ~lock_held_by
+          builder
           Dune_rpc.Procedures.Public.format
           ())
     in
@@ -81,7 +84,7 @@ let command =
       Common.Builder.set_promote builder (if preview then Never else Automatically)
     in
     let common, config = Common.init builder in
-    run_fmt_command ~common ~config ~preview
+    run_fmt_command ~common ~config ~preview builder
   in
   Cmd.v (Cmd.info "fmt" ~doc ~man ~envs:Common.envs) term
 ;;

bin/promotion.ml

@@ -63,13 +63,13 @@ module Apply = struct
         Diff_promotion.promote_files_registered_in_last_run files_to_promote)
     | Error lock_held_by ->
       Rpc.Rpc_common.run_via_rpc
-        ~builder
         ~common
         ~config
-        lock_held_by
         (Rpc.Rpc_common.fire_request
            ~name:"promote_many"
            ~wait:true
+           ~lock_held_by
+           builder
            Dune_rpc_private.Procedures.Public.promote_many)
         files_to_promote
   ;;

bin/rpc/rpc_build.ml

@@ -1,12 +1,18 @@
 open Import
 
-let build ~wait targets =
+let build ~wait builder lock_held_by targets =
   let targets =
     List.map targets ~f:(fun target ->
       let sexp = Dune_lang.Dep_conf.encode target in
       Dune_lang.to_string sexp)
   in
-  Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets
+  Rpc_common.fire_request
+    ~name:"build"
+    ~wait
+    ~lock_held_by
+    builder
+    Dune_rpc_impl.Decl.build
+    targets
 ;;
 
 let term =
@@ -18,7 +24,7 @@ let term =
   @@ fun () ->
   let open Fiber.O in
   let+ response =
-    Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets
+    Rpc_common.fire_request ~name:"build" ~wait builder Dune_rpc_impl.Decl.build targets
   in
   match response with
   | Error (error : Dune_rpc.Response.Error.t) ->

bin/rpc/rpc_build.mli

@@ -6,6 +6,8 @@ open! Import
     running then raise a [User_error].  *)
 val build
   :  wait:bool
+  -> Common.Builder.t
+  -> Dune_util.Global_lock.Lock_held_by.t
   -> Dune_lang.Dep_conf.t list
   -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t
 

bin/rpc/rpc_common.ml

@@ -75,9 +75,30 @@ let establish_client_session ~wait =
   if wait then establish_connection_with_retry () else establish_connection_exn ()
 ;;
 
-let fire_request ~name ~wait request arg =
+let warn_ignore_arguments lock_held_by =
+  User_warning.emit
+    [ Pp.paragraphf
+        "Your build request is being forwarded to a running Dune instance%s. Note that \
+         certain command line arguments may be ignored."
+        (match lock_held_by with
+         | Dune_util.Global_lock.Lock_held_by.Unknown -> ""
+         | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
+    ]
+;;
+
+let fire_request
+      ~name
+      ~wait
+      ?(warn_forwarding = true)
+      ?(lock_held_by = Dune_util.Global_lock.Lock_held_by.Unknown)
+      builder
+      request
+      arg
+  =
   let open Fiber.O in
   let* connection = establish_client_session ~wait in
+  if warn_forwarding && not (Common.Builder.equal builder Common.Builder.default)
+  then warn_ignore_arguments lock_held_by;
   Dune_rpc_impl.Client.client
     connection
     (Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom name)))
@@ -107,20 +128,7 @@ let wrap_build_outcome_exn ~print_on_success f args () =
     Console.print [ error_msg |> Pp.tag User_message.Style.Error ]
 ;;
 
-let warn_ignore_arguments lock_held_by =
-  User_warning.emit
-    [ Pp.paragraphf
-        "Your build request is being forwarded to a running Dune instance%s. Note that \
-         certain command line arguments may be ignored."
-        (match lock_held_by with
-         | Dune_util.Global_lock.Lock_held_by.Unknown -> ""
-         | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
-    ]
-;;
-
-let run_via_rpc ~builder ~common ~config lock_held_by f args =
-  if not (Common.Builder.equal builder Common.Builder.default)
-  then warn_ignore_arguments lock_held_by;
+let run_via_rpc ~common ~config f args =
   Scheduler.go_without_rpc_server
     ~common
     ~config

bin/rpc/rpc_common.mli

@@ -22,10 +22,16 @@ val client_term : Common.Builder.t -> (unit -> 'a Fiber.t) -> 'a
 val wait_term : bool Cmdliner.Term.t
 
 (** Send a request to the RPC server. If [wait], it will poll forever until a server is listening.
-    Should be scheduled by a scheduler that does not come with a RPC server on its own. *)
+    Should be scheduled by a scheduler that does not come with a RPC server on its own.
+
+    [warn_forwarding] defaults to true, warns the user that since a RPC server is running, some arguments are ignored.
+    [lock_held_by] defaults to [Unknown], is only used to allow error messages to print the PID. *)
 val fire_request
   :  name:string
   -> wait:bool
+  -> ?warn_forwarding:bool
+  -> ?lock_held_by:Dune_util.Global_lock.Lock_held_by.t
+  -> Common.Builder.t
   -> ('a, 'b) Dune_rpc.Decl.request
   -> 'a
   -> ('b, Dune_rpc.Response.Error.t) result Fiber.t
@@ -44,10 +50,8 @@ val warn_ignore_arguments : Dune_util.Global_lock.Lock_held_by.t -> unit
 
 (**  Schedule a fiber to run via RPC, wrapping any errors. *)
 val run_via_rpc
-  :  builder:Common.Builder.t
-  -> common:Common.t
+  :  common:Common.t
   -> config:Dune_config_file.Dune_config.t
-  -> Dune_util.Global_lock.Lock_held_by.t
   -> ('a
       -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result
            Fiber.t)

bin/rpc/rpc_ping.ml

@@ -18,6 +18,7 @@ let term =
   Rpc_common.fire_request
     ~name:"ping_cmd"
     ~wait
+    builder
     Dune_rpc_private.Procedures.Public.ping
     ()
   >>| function