Fix locating program in exec watch mode

This fixes a bug where running an executable from the current project
with `dune exec --watch` would be unable to find the executable unless
the command was run from the project's root directory.

The problem was introduced when we started setting the cwd of processes
spawned by exec in watch mode to the user's current directory
(ocaml#10262). If the program argument to
exec refers to a file to be built in the current project (such as an
executable implemented in the current project) then the path to the
executable to spawn will be a path inside the _build directory relative
to the project root. Since the cwd of the new process was set to the
user's current directory, this relative path was being resolved within
the current directory, whereas it should have been resolved relative to
the project root.

The fix was to convert relative paths into absolute paths relative to
the project root (this was already being done for exec when not in watch
mode).

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

bin/exec.ml

@@ -77,22 +77,25 @@ module Command_to_exec = struct
 
   (* Helper function to spawn a new process running a command in an
      environment, returning the new process' pid *)
-  let spawn_process path ~args ~env =
+  let spawn_process root prog ~args ~env =
     let pid =
-      let path = Path.to_string path in
+      let prog = Path.to_string prog |> resolve_relative_path_within_root_dir root in
       let env = Env.to_unix env |> Spawn.Env.of_list in
-      let argv = path :: args in
+      let argv = prog :: args in
       let cwd = Spawn.Working_dir.Path Fpath.initial_cwd in
-      Spawn.spawn ~prog:path ~env ~cwd ~argv ()
+      Spawn.spawn ~prog ~env ~cwd ~argv ()
     in
     Pid.of_int pid
   ;;
 
   (* Run the command, first (re)building the program which the command is
      invoking *)
-  let build_and_run_in_child_process { get_path_and_build_if_necessary; prog; args; env } =
+  let build_and_run_in_child_process
+    root
+    { get_path_and_build_if_necessary; prog; args; env }
+    =
     get_path_and_build_if_necessary prog
-    |> Fiber.map ~f:(Result.map ~f:(spawn_process ~args ~env))
+    |> Fiber.map ~f:(Result.map ~f:(spawn_process root ~args ~env))
   ;;
 end
 
@@ -139,18 +142,18 @@ module Watch = struct
 
   (* Kills the currently running process, then runs the given command after
      (re)building the program which it will invoke *)
-  let run state ~command_to_exec =
+  let run root state ~command_to_exec =
     let open Fiber.O in
     let* () = Fiber.return () in
     let* () = kill_currently_running_process state in
     let* command_to_exec = command_to_exec () in
-    Command_to_exec.build_and_run_in_child_process command_to_exec
+    Command_to_exec.build_and_run_in_child_process root command_to_exec
     >>| Result.map ~f:(fun pid -> state.currently_running_pid := Some pid)
   ;;
 
-  let loop ~command_to_exec =
+  let loop root ~command_to_exec =
     let state = init_state () in
-    Scheduler.Run.poll (run state ~command_to_exec)
+    Scheduler.Run.poll (run root state ~command_to_exec)
   ;;
 end
 
@@ -322,7 +325,7 @@ module Exec_context = struct
       ; env
       }
     in
-    Watch.loop ~command_to_exec
+    Watch.loop (Common.root common) ~command_to_exec
   ;;
 end
 

bin/import.ml

@@ -239,14 +239,13 @@ module Scheduler = struct
   ;;
 end
 
-let restore_cwd_and_execve (common : Common.t) prog argv env =
-  let prog =
-    if Filename.is_relative prog
-    then (
-      let root = Common.root common in
-      Filename.concat root.dir prog)
-    else prog
-  in
+let resolve_relative_path_within_root_dir (root : Workspace_root.t) path =
+  if Filename.is_relative path then Filename.concat root.dir path else path
+;;
+
+let restore_cwd_and_execve common prog argv env =
+  let root = Common.root common in
+  let prog = resolve_relative_path_within_root_dir root prog in
   Proc.restore_cwd_and_execve prog argv ~env
 ;;
 

doc/changes/10386.md

@@ -0,0 +1,3 @@
+- Fix bug with exec watch mode where paths to executables in the current project
+  could not be resolved unless the user's current directory is the project root.
+  (#10386, @gridbugs)