Allow running tests concurrently with watch server, again!

bin/build.ml

@@ -92,11 +92,15 @@ 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+ pending_action = 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 pending_action.kind with
+         | Build targets -> Target.interpret_targets root 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, pending_action.outcome)
 ;;
 
 let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit =
@@ -199,10 +203,10 @@ let build =
          perform the RPC call.
       *)
       Rpc.Rpc_common.run_via_rpc
-        ~builder
-        ~common
-        ~config
+        builder
         lock_held_by
+        common
+        config
         (Rpc.Group.Build.build ~wait:true)
         targets
     | Ok () ->

bin/fmt.ml

@@ -49,7 +49,7 @@ let run_fmt_command ~common ~config ~preview =
       Scheduler.go_without_rpc_server ~common ~config (fun () ->
         Rpc.Rpc_common.fire_request
           ~name:"format"
-          ~wait:true
+          ~wait:false
           Dune_rpc.Procedures.Public.format
           ())
     in

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
+        builder
         lock_held_by
+        common
+        config
         (Rpc.Rpc_common.fire_request
            ~name:"promote_many"
-           ~wait:true
+           ~wait:false
            Dune_rpc_private.Procedures.Public.promote_many)
         files_to_promote
   ;;

bin/rpc/rpc_common.ml

@@ -84,9 +84,9 @@ let fire_request ~name ~wait request arg =
     ~f:(fun client -> request_exn client request arg)
 ;;
 
-let wrap_build_outcome_exn ~print_on_success f args () =
+let wrap_build_outcome_exn ~print_on_success f arg () =
   let open Fiber.O in
-  let+ response = f args in
+  let+ response = f arg in
   match response with
   | Error (error : Rpc_error.t) -> raise_rpc_error error
   | Ok Dune_rpc.Build_outcome_with_diagnostics.Success ->
@@ -118,11 +118,11 @@ let warn_ignore_arguments lock_held_by =
     ]
 ;;
 
-let run_via_rpc ~builder ~common ~config lock_held_by f args =
+let run_via_rpc builder lock_held_by common config request arg =
   if not (Common.Builder.equal builder Common.Builder.default)
   then warn_ignore_arguments lock_held_by;
   Scheduler.go_without_rpc_server
     ~common
     ~config
-    (wrap_build_outcome_exn ~print_on_success:true f args)
+    (wrap_build_outcome_exn ~print_on_success:true request arg)
 ;;

bin/rpc/rpc_common.mli

@@ -44,10 +44,10 @@ 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
-  -> config:Dune_config_file.Dune_config.t
+  :  Common.Builder.t
   -> Dune_util.Global_lock.Lock_held_by.t
+  -> Common.t
+  -> Dune_config_file.Dune_config.t
   -> ('a
       -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result
            Fiber.t)

bin/runtest.ml

@@ -33,129 +33,31 @@ let runtest_info =
   Cmd.info "runtest" ~doc ~man ~envs:Common.envs
 ;;
 
-let find_cram_test path ~parent_dir =
-  let open Memo.O in
-  Source_tree.find_dir parent_dir
-  >>= function
-  | None -> Memo.return None
-  | Some dir ->
-    Dune_rules.Cram_rules.cram_tests dir
-    >>| List.find_map ~f:(function
-      | Ok cram_test when Path.Source.equal path (Source.Cram_test.path cram_test) ->
-        Some cram_test
-      (* We raise any error we encounter when looking for our test specifically. *)
-      | Error (Dune_rules.Cram_rules.Missing_run_t cram_test)
-        when Path.Source.equal path (Source.Cram_test.path cram_test) ->
-        Dune_rules.Cram_rules.missing_run_t cram_test
-      (* Any errors or successes unrelated to our test are discarded. *)
-      | Error (Dune_rules.Cram_rules.Missing_run_t _) | Ok _ -> None)
-;;
-
-let explain_unsuccessful_search path ~parent_dir =
-  let open Memo.O in
-  (* If the user misspelled the test name, we give them a hint. *)
-  let+ hints =
-    (* We search for all files and directories in the parent directory and
-       suggest them as possible candidates. *)
-    let+ candidates =
-      let+ file_candidates =
-        let+ files = Source_tree.files_of parent_dir in
-        Path.Source.Set.to_list_map files ~f:Path.Source.to_string
-      and+ dir_candidates =
-        let* parent_source_dir = Source_tree.find_dir parent_dir in
-        match parent_source_dir with
-        | None -> Memo.return []
-        | Some parent_source_dir ->
-          let dirs = Source_tree.Dir.sub_dirs parent_source_dir in
-          String.Map.to_list dirs
-          |> Memo.List.map ~f:(fun (_candidate, candidate_path) ->
-            Source_tree.Dir.sub_dir_as_t candidate_path
-            >>| Source_tree.Dir.path
-            >>| Path.Source.to_string)
-      in
-      List.concat [ file_candidates; dir_candidates ]
-    in
-    User_message.did_you_mean (Path.Source.to_string path) ~candidates
-  in
-  User_error.raise
-    ~hints
-    [ Pp.textf "%S does not match any known test." (Path.Source.to_string path) ]
-;;
-
-(* [disambiguate_test_name path] is a function that takes in a
-   directory [path] and classifies it as either a cram test or a directory to
-   run tests in. *)
-let disambiguate_test_name path =
-  match Path.Source.parent path with
-  | None -> Memo.return @@ `Runtest (Path.source Path.Source.root)
-  | Some parent_dir ->
-    let open Memo.O in
-    find_cram_test path ~parent_dir
-    >>= (function
-     | Some test ->
-       (* If we find the cram test, then we request that is run. *)
-       Memo.return (`Cram (parent_dir, test))
-     | None ->
-       (* If we don't find it, then we assume the user intended a directory for
-          @runtest to be used. *)
-       Source_tree.find_dir path
-       >>= (function
-        (* We need to make sure that this directory or file exists. *)
-        | Some _ -> Memo.return (`Runtest (Path.source path))
-        | None -> explain_unsuccessful_search path ~parent_dir))
-;;
-
 let runtest_term =
   let name = Arg.info [] ~docv:"TEST" in
   let+ builder = Common.Builder.term
-  and+ dirs = Arg.(value & pos_all string [ "." ] name) in
+  and+ dir_or_cram_test_paths = Arg.(value & pos_all string [ "." ] name) in
   let common, config = Common.init builder in
-  let request (setup : Import.Main.build_system) =
-    let contexts = setup.contexts in
-    List.map dirs ~f:(fun dir ->
-      let dir = Path.of_string dir |> Path.Expert.try_localize_external in
-      let open Action_builder.O in
-      let* contexts, alias_kind =
-        match (Util.check_path contexts dir : Util.checked) with
-        | In_build_dir (context, dir) ->
-          let+ res = Action_builder.of_memo (disambiguate_test_name dir) in
-          [ context ], res
-        | In_source_dir dir ->
-          (* We need to adjust the path here to make up for the current working directory. *)
-          let { Workspace_root.to_cwd; _ } = Common.root common in
-          let dir =
-            Path.Source.L.relative Path.Source.root (to_cwd @ Path.Source.explode dir)
-          in
-          let+ res = Action_builder.of_memo (disambiguate_test_name dir) in
-          contexts, res
-        | In_private_context _ | In_install_dir _ ->
-          User_error.raise
-            [ Pp.textf
-                "This path is internal to dune: %s"
-                (Path.to_string_maybe_quoted dir)
-            ]
-        | External _ ->
-          User_error.raise
-            [ Pp.textf
-                "This path is outside the workspace: %s"
-                (Path.to_string_maybe_quoted dir)
-            ]
-      in
-      Alias.request
-      @@
-      match alias_kind with
-      | `Cram (dir, cram) ->
-        let alias_name = Source.Cram_test.name cram in
-        Alias.in_dir
-          ~name:(Dune_engine.Alias.Name.of_string alias_name)
-          ~recursive:false
-          ~contexts
-          (Path.source dir)
-      | `Runtest dir ->
-        Alias.in_dir ~name:Dune_rules.Alias.runtest ~recursive:true ~contexts dir)
-    |> Action_builder.all_unit
-  in
-  Build.run_build_command ~common ~config ~request
+  match Dune_util.Global_lock.lock ~timeout:None with
+  | Ok () ->
+    Build.run_build_command
+      ~common
+      ~config
+      ~request:
+        (Runtest_common.make_request
+           ~dir_or_cram_test_paths
+           ~to_cwd:(Common.root common).to_cwd)
+  | Error lock_held_by ->
+    Rpc.Rpc_common.run_via_rpc
+      builder
+      lock_held_by
+      common
+      config
+      (Rpc.Rpc_common.fire_request
+         ~name:"runtest"
+         ~wait:false
+         Dune_rpc.Procedures.Public.runtest)
+      dir_or_cram_test_paths
 ;;
 
 let commands =

bin/runtest_common.ml

@@ -0,0 +1,116 @@
+open! Import
+
+let find_cram_test path ~parent_dir =
+  let open Memo.O in
+  Source_tree.find_dir parent_dir
+  >>= function
+  | None -> Memo.return None
+  | Some dir ->
+    Dune_rules.Cram_rules.cram_tests dir
+    >>| List.find_map ~f:(function
+      | Ok cram_test when Path.Source.equal path (Source.Cram_test.path cram_test) ->
+        Some cram_test
+      (* We raise any error we encounter when looking for our test specifically. *)
+      | Error (Dune_rules.Cram_rules.Missing_run_t cram_test)
+        when Path.Source.equal path (Source.Cram_test.path cram_test) ->
+        Dune_rules.Cram_rules.missing_run_t cram_test
+        (* Any errors or successes unrelated to our test are discarded. *)
+      | Error (Dune_rules.Cram_rules.Missing_run_t _) | Ok _ -> None)
+;;
+
+let explain_unsuccessful_search path ~parent_dir =
+  let open Memo.O in
+  (* If the user misspelled the test name, we give them a hint. *)
+  let+ hints =
+    (* We search for all files and directories in the parent directory and
+       suggest them as possible candidates. *)
+    let+ candidates =
+      let+ file_candidates =
+        let+ files = Source_tree.files_of parent_dir in
+        Path.Source.Set.to_list_map files ~f:Path.Source.to_string
+      and+ dir_candidates =
+        let* parent_source_dir = Source_tree.find_dir parent_dir in
+        match parent_source_dir with
+        | None -> Memo.return []
+        | Some parent_source_dir ->
+          let dirs = Source_tree.Dir.sub_dirs parent_source_dir in
+          String.Map.to_list dirs
+          |> Memo.List.map ~f:(fun (_candidate, candidate_path) ->
+            Source_tree.Dir.sub_dir_as_t candidate_path
+            >>| Source_tree.Dir.path
+            >>| Path.Source.to_string)
+      in
+      List.concat [ file_candidates; dir_candidates ]
+    in
+    User_message.did_you_mean (Path.Source.to_string path) ~candidates
+  in
+  User_error.raise
+    ~hints
+    [ Pp.textf "%S does not match any known test." (Path.Source.to_string path) ]
+;;
+
+(* [disambiguate_test_name path] is a function that takes in a
+   directory [path] and classifies it as either a cram test or a directory to
+   run tests in. *)
+let disambiguate_test_name path =
+  match Path.Source.parent path with
+  | None -> Memo.return @@ `Runtest (Path.source Path.Source.root)
+  | Some parent_dir ->
+    let open Memo.O in
+    find_cram_test path ~parent_dir
+    >>= (function
+     | Some test ->
+       (* If we find the cram test, then we request that is run. *)
+       Memo.return (`Cram (parent_dir, test))
+     | None ->
+       (* If we don't find it, then we assume the user intended a directory for
+          @runtest to be used. *)
+       Source_tree.find_dir path
+       >>= (function
+        (* We need to make sure that this directory or file exists. *)
+        | Some _ -> Memo.return (`Runtest (Path.source path))
+        | None -> explain_unsuccessful_search path ~parent_dir))
+;;
+
+let make_request ~dir_or_cram_test_paths ~to_cwd (setup : Import.Main.build_system) =
+  let contexts = setup.contexts in
+  List.map dir_or_cram_test_paths ~f:(fun dir ->
+    let dir = Path.of_string dir |> Path.Expert.try_localize_external in
+    let open Action_builder.O in
+    let* contexts, alias_kind =
+      match (Util.check_path contexts dir : Util.checked) with
+      | In_build_dir (context, dir) ->
+        let+ res = Action_builder.of_memo (disambiguate_test_name dir) in
+        [ context ], res
+      | In_source_dir dir ->
+        (* We need to adjust the path here to make up for the current working directory. *)
+        let dir =
+          Path.Source.L.relative Path.Source.root (to_cwd @ Path.Source.explode dir)
+        in
+        let+ res = Action_builder.of_memo (disambiguate_test_name dir) in
+        contexts, res
+      | In_private_context _ | In_install_dir _ ->
+        User_error.raise
+          [ Pp.textf "This path is internal to dune: %s" (Path.to_string_maybe_quoted dir)
+          ]
+      | External _ ->
+        User_error.raise
+          [ Pp.textf
+              "This path is outside the workspace: %s"
+              (Path.to_string_maybe_quoted dir)
+          ]
+    in
+    Alias.request
+    @@
+    match alias_kind with
+    | `Cram (dir, cram) ->
+      let alias_name = Source.Cram_test.name cram in
+      Alias.in_dir
+        ~name:(Dune_engine.Alias.Name.of_string alias_name)
+        ~recursive:false
+        ~contexts
+        (Path.source dir)
+    | `Runtest dir ->
+      Alias.in_dir ~name:Dune_rules.Alias.runtest ~recursive:true ~contexts dir)
+  |> Action_builder.all_unit
+;;

bin/runtest_common.mli

@@ -0,0 +1,10 @@
+open! Import
+
+(** [make_request ~dir_or_cram_test_paths ~to_cwd] returns a function suitable
+    for passing to [Build_cmd.run_build_system] which runs the tests referred
+    to by the elements of [dir_or_cram_test_paths]. *)
+val make_request
+  :  dir_or_cram_test_paths:string list
+  -> to_cwd:string list
+  -> Dune_rules.Main.build_system
+  -> unit Action_builder.t

otherlibs/dune-rpc/private/dune_rpc_private.ml

@@ -620,6 +620,7 @@ module Client = struct
       Builder.declare_request t Procedures.Public.promote;
       Builder.declare_request t Procedures.Public.promote_many;
       Builder.declare_request t Procedures.Public.build_dir;
+      Builder.declare_request t Procedures.Public.runtest;
       Builder.implement_notification t Procedures.Server_side.abort (fun () ->
         handler.abort);
       Builder.implement_notification t Procedures.Server_side.log (fun () -> handler.log);