Merge pull request ocaml#11905 from gridbugs/dune-exec-which

gridbugs · web-flow · commit 99ffae6afe1b · 2025-07-11T12:19:55.000+10:00
Looking up paths to executables with `dune describe location`
diff --git a/bin/describe/describe.ml b/bin/describe/describe.ml
@@ -21,6 +21,7 @@ let subcommands =
   ; Describe_pkg.command
   ; Describe_contexts.command
   ; Describe_depexts.command
+  ; Describe_location.command
   ]
 ;;
 
diff --git a/bin/describe/describe_location.ml b/bin/describe/describe_location.ml
@@ -0,0 +1,43 @@
+open! Import
+
+let doc =
+  "Print the path to the executable using the same resolution logic as [dune exec]."
+;;
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P
+      {|$(b,dune describe location NAME) prints the path to the executable NAME using the same logic as:
+          |}
+  ; `Pre "$ dune exec NAME"
+  ; `P
+      "Dune will first try to resolve the executable within the public executables in \
+       the current project, then inside the \"bin\" directory of each package among the \
+       project's  dependencies (when using dune package management), and finally within \
+       the  directories listed in the $PATH environment variable."
+  ]
+;;
+
+let info = Cmd.info "location" ~doc ~man
+
+let term : unit Term.t =
+  let+ builder = Common.Builder.term
+  and+ context = Common.context_arg ~doc:{|Run the command in this build context.|}
+  and+ prog =
+    Arg.(required & pos 0 (some Exec.Cmd_arg.conv) None (Arg.info [] ~docv:"PROG"))
+  in
+  let common, config = Common.init builder in
+  Scheduler.go_with_rpc_server ~common ~config
+  @@ fun () ->
+  let open Fiber.O in
+  let* setup = Import.Main.setup () in
+  build_exn
+  @@ fun () ->
+  let open Memo.O in
+  let* sctx = setup >>| Import.Main.find_scontext_exn ~name:context in
+  let* prog = Exec.Cmd_arg.expand ~root:(Common.root common) ~sctx prog in
+  let+ path = Exec.get_path common sctx ~prog >>| Path.to_string in
+  Dune_console.printf "%s" path
+;;
+
+let command = Cmd.v info term
diff --git a/bin/describe/describe_location.mli b/bin/describe/describe_location.mli
@@ -0,0 +1,3 @@
+open! Import
+
+val command : unit Cmd.t
diff --git a/bin/exec.ml b/bin/exec.ml
@@ -115,19 +115,25 @@ let build_prog ~no_rebuild ~prog p =
     p
 ;;
 
-let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog =
+let dir_of_context common sctx =
+  let context = Dune_rules.Super_context.context sctx in
+  Path.Build.relative (Context.build_dir context) (Common.prefix_target common "")
+;;
+
+let get_path common sctx ~prog =
   let open Memo.O in
+  let dir = dir_of_context common sctx in
   match Filename.analyze_program_name prog with
   | In_path ->
     Super_context.resolve_program_memo sctx ~dir ~loc:None prog
     >>= (function
      | Error (_ : Action.Prog.Not_found.t) -> not_found_with_suggestions ~dir ~prog
-     | Ok p -> build_prog ~no_rebuild ~prog p)
+     | Ok p -> Memo.return p)
   | Relative_to_current_dir ->
     let path = Path.relative_to_source_in_build_or_external ~dir prog in
     Build_system.file_exists path
     >>= (function
-     | true -> build_prog ~no_rebuild ~prog path
+     | true -> Memo.return path
      | false -> not_found_with_suggestions ~dir ~prog)
   | Absolute ->
     (match
@@ -144,19 +150,24 @@ let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog =
      | None -> not_found_with_suggestions ~dir ~prog)
 ;;
 
-let step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit () =
+let get_path_and_build_if_necessary common sctx ~no_rebuild ~prog =
   let open Memo.O in
-  let* sctx = setup >>| Import.Main.find_scontext_exn ~name:context in
-  let* env = Super_context.context_env sctx in
-  let expand = Cmd_arg.expand ~root:(Common.root common) ~sctx in
+  let* path = get_path common sctx ~prog in
+  match Filename.analyze_program_name prog with
+  | In_path | Relative_to_current_dir -> build_prog ~no_rebuild ~prog path
+  | Absolute -> Memo.return path
+;;
+
+let step ~prog ~args ~common ~no_rebuild ~context ~on_exit () =
+  let open Memo.O in
+  let* sctx = Super_context.find_exn context in
   let* path =
-    let dir =
-      let context = Dune_rules.Super_context.context sctx in
-      Path.Build.relative (Context.build_dir context) (Common.prefix_target common "")
-    in
-    let* prog = expand prog in
-    get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog
-  and* args = Memo.parallel_map args ~f:expand in
+    let* prog = Cmd_arg.expand ~root:(Common.root common) ~sctx prog in
+    get_path_and_build_if_necessary common sctx ~no_rebuild ~prog
+  and* args =
+    Memo.parallel_map args ~f:(Cmd_arg.expand ~root:(Common.root common) ~sctx)
+  in
+  let* env = Super_context.context_env sctx in
   Memo.of_non_reproducible_fiber
   @@ Dune_engine.Process.run_inherit_std_in_out
        ~dir:(Path.of_string Fpath.initial_cwd)
@@ -252,12 +263,11 @@ let exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild =
     Scheduler.go_with_rpc_server_and_console_status_reporting ~common ~config
     @@ fun () ->
     let open Fiber.O in
-    let* setup = Import.Main.setup () in
     let on_exit = Console.printf "Program exited with code [%d]" in
     Scheduler.Run.poll
     @@
     let* () = Fiber.return @@ Scheduler.maybe_clear_screen ~details_hum:[] config in
-    build @@ step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit
+    build @@ step ~prog ~args ~common ~no_rebuild ~context ~on_exit
   | No ->
     Scheduler.go_with_rpc_server ~common ~config
     @@ fun () ->
@@ -266,16 +276,13 @@ let exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild =
     build_exn (fun () ->
       let open Memo.O in
       let* sctx = setup >>| Import.Main.find_scontext_exn ~name:context in
-      let* env = Super_context.context_env sctx in
-      let expand = Cmd_arg.expand ~root:(Common.root common) ~sctx in
-      let* prog =
-        let dir =
-          let context = Dune_rules.Super_context.context sctx in
-          Path.Build.relative (Context.build_dir context) (Common.prefix_target common "")
-        in
-        let* prog = expand prog in
-        get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog >>| Path.to_string
-      and* args = Memo.parallel_map ~f:expand args in
+      let* env = Super_context.context_env sctx
+      and* prog =
+        let* prog = Cmd_arg.expand ~root:(Common.root common) ~sctx prog in
+        get_path_and_build_if_necessary common sctx ~no_rebuild ~prog >>| Path.to_string
+      and* args =
+        Memo.parallel_map ~f:(Cmd_arg.expand ~root:(Common.root common) ~sctx) args
+      in
       restore_cwd_and_execve (Common.root common) prog args env)
 ;;
 
diff --git a/bin/exec.mli b/bin/exec.mli
@@ -1,3 +1,24 @@
 open Import
 
+module Cmd_arg : sig
+  type t
+
+  val conv : t Arg.conv
+  val expand : t -> root:Workspace_root.t -> sctx:Super_context.t -> string Memo.t
+end
+
+(** Returns the path to the executable [prog] as it will be resolved by dune:
+  - if [prog] is the name of an executable defined by the project then the path
+    to that executable will be returned, and evaluating the returned memo will
+    build the executable if necessary.
+  - otherwise if [prog] is the name of an executable in the "bin" directory of
+    a package in this project's dependency cone then the path to that executable
+    file will be returned. Note that for this reason all dependencies of the
+    project will be built when the returned memo is evaluated (unless the first
+    case is hit).
+  - otherwise if [prog] is the name of an executable in one of the directories
+    listed in the PATH environment variable, the path to that executable will be
+    returned. *)
+val get_path : Common.t -> Super_context.t -> prog:string -> Path.t Memo.t
+
 val command : unit Cmd.t
diff --git a/doc/changes/11905.md b/doc/changes/11905.md
@@ -0,0 +1,2 @@
+- Add `dune describe location` for printing the path to the executable that
+  would be run (#11905, @gridbugs)
diff --git a/test/blackbox-tests/test-cases/describe_location.t b/test/blackbox-tests/test-cases/describe_location.t
@@ -0,0 +1,65 @@
+Exercise the various ways of resolving executable names with `dune exec`.
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.20)
+  > 
+  > (package
+  >  (name foo))
+  > EOF
+
+  $ cat > dune << EOF
+  > (executable
+  >  (public_name foo))
+  > EOF
+
+  $ cat > foo.ml << EOF
+  > let () = print_endline "hello foo"
+  > EOF
+
+An executable that would be installed by the current package:
+  $ dune describe location foo
+  _build/install/default/bin/foo
+
+An executable from the current project:
+  $ dune describe location ./foo.exe
+  _build/default/foo.exe
+
+Test that executables from dependencies are located correctly:
+  $ mkdir dune.lock
+  $ cat > dune.lock/lock.dune << EOF
+  > (lang package 0.1)
+  > EOF
+  $ cat > dune.lock/bar.pkg << EOF
+  > (version 0.1)
+  > (install
+  >  (progn
+  >   (write-file %{bin}/bar "#!/bin/sh\necho hello bar")
+  >   (run chmod a+x %{bin}/bar)))
+  > EOF
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.20)
+  > 
+  > (package
+  >  (name foo)
+  >  (depends bar))
+  > EOF
+
+  $ dune describe location bar
+  _build/_private/default/.pkg/bar/target/bin/bar
+
+Test that executables from PATH are located correctly:
+  $ mkdir bin
+  $ cat > bin/baz << EOF
+  > #!/bin/sh
+  > echo hello baz
+  > EOF
+
+  $ chmod a+x bin/baz
+  $ export PATH=$PWD/bin:$PATH
+
+  $ dune describe location baz
+  $TESTCASE_ROOT/bin/baz
+
+  $ dune exec echo '%{bin:foo}'
+  _build/install/default/bin/foo

Original file line number	Diff line number	Diff line change
`@@ -21,6 +21,7 @@ let subcommands =`
`21`	`21`	`; Describe_pkg.command`
`22`	`22`	`; Describe_contexts.command`
`23`	`23`	`; Describe_depexts.command`
	`24`	`+ ; Describe_location.command`
`24`	`25`	`]`
`25`	`26`	`;;`
`26`	`27`
Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+open! Import`
	`2`	`+`
	`3`	`+val command : unit Cmd.t`
Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,2 @@`
	`1`	+- Add `dune describe location` for printing the path to the executable that
	`2`	`+ would be run (#11905, @gridbugs)`