dune exec: support pform syntax

This supports things like `dune exec time %{bin:e}`.

The syntax is consistent with what support in `dune build` and
backwards compatible in cases where no arguments start with `%`.

The resolution mechanism is slightly different for the program and the
rest of the arguments:

- the program is always considered a possible dependency, either in
  pform syntax (`%{bin:e}` or in string syntax (`./path/to/e`,
  `_build/default/path/to/e`).
- arguments are only interpreted as dependencies if they are in pform
  syntax.

Closes #2691

Signed-off-by: Etienne Millon <me@emillon.org>
Signed-off-by: Marek Kubica <marek@tarides.com>

bin/exec.ml

@@ -134,6 +134,63 @@ let build_prog ~no_rebuild ~prog p =
     p
 ;;
 
+module Cli_item = struct
+  type program_name =
+    | String of string
+    | Sw of Dune_lang.String_with_vars.t * string
+
+  type t =
+    | Program of program_name
+    | Argument of string
+
+  let parse_program_name s =
+    match Arg.conv_parser Arg.dep s with
+    | Ok (File sw) when Dune_lang.String_with_vars.has_pforms sw -> Sw (sw, s)
+    | _ -> String s
+  ;;
+
+  let parse s =
+    match parse_program_name s with
+    | Sw _ as n -> Program n
+    | String s -> Argument s
+  ;;
+
+  let pp_program_name pps = function
+    | String s -> Format.fprintf pps "%s" s
+    | Sw (_, s) -> Format.fprintf pps "%s" s
+  ;;
+
+  let pp pps = function
+    | Program prog -> pp_program_name pps prog
+    | Argument s -> Format.fprintf pps "%s" s
+  ;;
+
+  let expand_program_name root sctx prog =
+    let open Memo.O in
+    let context = Dune_rules.Super_context.context sctx in
+    match prog with
+    | Sw (sw, _) ->
+      let+ path, _ =
+        Action_builder.run (Target.expand_path_from_root' root sctx context sw) Eager
+      in
+      Path.to_string
+        (Path.build
+           (Path.Build.relative
+              (Dune_engine.Context_name.build_dir (Context.name context))
+              path))
+    | String s -> Memo.return s
+  ;;
+
+  let expand root sctx item =
+    match item with
+    | Program p -> expand_program_name root sctx p
+    | Argument s -> Memo.return s
+  ;;
+
+  let program_name_conv = Arg.conv ((fun s -> Ok (parse_program_name s)), pp_program_name)
+  let conv = Arg.conv ((fun s -> Ok (parse s)), pp)
+end
+
 let not_found ~dir ~prog =
   let open Memo.O in
   let+ hints =
@@ -153,8 +210,9 @@ let not_found ~dir ~prog =
   User_error.raise ~hints [ Pp.textf "Program %S not found!" prog ]
 ;;
 
-let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog =
+let get_path_and_build_if_necessary root sctx ~no_rebuild ~dir ~prog =
   let open Memo.O in
+  let* prog = Cli_item.expand_program_name root sctx prog in
   match Filename.analyze_program_name prog with
   | In_path ->
     Super_context.resolve_program sctx ~dir ~loc:None prog
@@ -197,9 +255,10 @@ module Exec_context = struct
   type t =
     { common : Common.t
     ; config : Dune_config.t
-    ; args : string list
+    ; args : Cli_item.t list
     ; env : Env.t Fiber.t
     ; get_path_and_build_if_necessary : (unit -> Path.t Memo.t) Fiber.t
+    ; expand_cli_item : (Cli_item.t -> string Memo.t) Fiber.t
     }
 
   let init ~common ~context ~no_rebuild ~prog ~args =
@@ -222,29 +281,47 @@ module Exec_context = struct
       let open Fiber.O in
       let* sctx = sctx in
       let+ dir = dir in
-      fun () -> get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog
+      fun () ->
+        get_path_and_build_if_necessary (Common.root common) sctx ~no_rebuild ~dir ~prog
     in
-    { common; config; env; args; get_path_and_build_if_necessary }
+    let expand_cli_item =
+      let open Fiber.O in
+      let+ sctx = sctx in
+      fun arg -> Cli_item.expand (Common.root common) sctx arg
+    in
+    { common; config; env; args; get_path_and_build_if_necessary; expand_cli_item }
   ;;
 
-  let run_once { common; config; env; args; get_path_and_build_if_necessary; _ } =
+  let run_once
+    { common; config; env; args; get_path_and_build_if_necessary; expand_cli_item }
+    =
     Scheduler.go ~common ~config
     @@ fun () ->
     let open Fiber.O in
     let* get_path_and_build_if_necessary = get_path_and_build_if_necessary in
     let* env = env in
-    let+ path = Build_system.run_exn get_path_and_build_if_necessary in
+    let* expand_cli_item = expand_cli_item in
+    let* path, args =
+      Build_system.run_exn (fun () ->
+        let path = get_path_and_build_if_necessary () in
+        let args = Memo.parallel_map ~f:expand_cli_item args in
+        Memo.both path args)
+    in
     let prog = Path.to_string path in
     let argv = prog :: args in
     restore_cwd_and_execve common prog argv env
   ;;
 
-  let run_eager_watch { common; config; env; args; get_path_and_build_if_necessary; _ } =
+  let run_eager_watch
+    { common; config; env; args; get_path_and_build_if_necessary; expand_cli_item }
+    =
     Scheduler.go_with_rpc_server_and_console_status_reporting ~common ~config
     @@ fun () ->
     let open Fiber.O in
     let* get_path_and_build_if_necessary = get_path_and_build_if_necessary in
     let* env = env in
+    let* expand_cli_item = expand_cli_item in
+    let* args = args |> Memo.parallel_map ~f:expand_cli_item |> Memo.run in
     let command_to_exec =
       { Command_to_exec.get_path_and_build_if_necessary =
           (fun () ->
@@ -263,10 +340,12 @@ end
 let term =
   let+ common = Common.term
   and+ context = Common.context_arg ~doc:{|Run the command in this build context.|}
-  and+ prog = Arg.(required & pos 0 (some string) None (Arg.info [] ~docv:"PROG"))
+  and+ prog =
+    Arg.(
+      required & pos 0 (some Cli_item.program_name_conv) None (Arg.info [] ~docv:"PROG"))
   and+ no_rebuild =
     Arg.(value & flag & info [ "no-build" ] ~doc:"don't rebuild target before executing")
-  and+ args = Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS")) in
+  and+ args = Arg.(value & pos_right 0 Cli_item.conv [] (Arg.info [] ~docv:"ARGS")) in
   (* TODO we should make sure to finalize the current backend before exiting dune.
      For watch mode, we should finalize the backend and then restart it in between
      runs. *)

bin/target.ml

@@ -165,7 +165,24 @@ let resolve_path path ~(setup : Dune_rules.Main.build_system)
     | None -> can't_build path)
 ;;
 
-let expand_path (root : Workspace_root.t) ~(setup : Dune_rules.Main.build_system) ctx sv =
+let expand_path_from_root' (root : Workspace_root.t) sctx ctx sv =
+  let dir =
+    Path.Build.relative
+      ctx.Context.build_dir
+      (String.concat ~sep:Filename.dir_sep root.to_cwd)
+  in
+  let* expander = Action_builder.of_memo (Dune_rules.Super_context.expander sctx ~dir) in
+  let expander = Dune_rules.Dir_contents.add_sources_to_expander sctx expander in
+  let+ s = Dune_rules.Expander.expand_str expander sv in
+  root.reach_from_root_prefix ^ s
+;;
+
+let expand_path_from_root
+  (root : Workspace_root.t)
+  ~(setup : Dune_rules.Main.build_system)
+  ctx
+  sv
+  =
   let sctx = Dune_engine.Context_name.Map.find_exn setup.scontexts (Context.name ctx) in
   let dir =
     Path.Build.relative
@@ -175,7 +192,12 @@ let expand_path (root : Workspace_root.t) ~(setup : Dune_rules.Main.build_system
   let* expander = Action_builder.of_memo (Dune_rules.Super_context.expander sctx ~dir) in
   let expander = Dune_rules.Dir_contents.add_sources_to_expander sctx expander in
   let+ s = Dune_rules.Expander.expand_str expander sv in
-  Path.relative Path.root (root.reach_from_root_prefix ^ s)
+  root.reach_from_root_prefix ^ s
+;;
+
+let expand_path root ~setup ctx sv =
+  let+ s = expand_path_from_root root ~setup ctx sv in
+  Path.relative Path.root s
 ;;
 
 let resolve_alias root ~recursive sv ~(setup : Dune_rules.Main.build_system) =

bin/target.mli

@@ -17,3 +17,10 @@ val interpret_targets
   -> Dune_rules.Main.build_system
   -> Arg.Dep.t list
   -> unit Dune_engine.Action_builder.t
+
+val expand_path_from_root'
+  :  Workspace_root.t
+  -> Dune_rules.Super_context.t
+  -> Dune_rules.Context.t
+  -> Dune_lang.String_with_vars.t
+  -> string Dune_engine.Action_builder.t

doc/changes/6035.md

@@ -0,0 +1,3 @@
+- `dune exec`: support syntax like `%{bin:program}`. This can appear anywhere
+  in the command line, so things like `dune exec time %{bin:program}` now work.
+  (#6035, fixes #2691, @emillon)

test/blackbox-tests/test-cases/exec-bin.t

@@ -0,0 +1,76 @@
+  $ cat > dune-project << EOF
+  > (lang dune 1.1)
+  > 
+  > (package
+  >  (name e))
+  > EOF
+  $ cat > dune << EOF
+  > (executable
+  >  (public_name e))
+  > EOF
+
+The executable just displays "Hello" and its arguments.
+
+  $ cat > e.ml << EOF
+  > let () =
+  >   print_endline "Hello";
+  >   Array.iteri (fun i s ->
+  >     Printf.printf "argv[%d] = %s\n" i s
+  >     ) Sys.argv
+  > EOF
+
+By default, e is executed with the program name and arguments in argv.
+
+  $ dune exec ./e.exe a b c
+  Hello
+  argv[0] = _build/default/e.exe
+  argv[1] = a
+  argv[2] = b
+  argv[3] = c
+
+The special form %{bin:public_name} is supported.
+
+  $ dune exec %{bin:e} a b c
+  Hello
+  argv[0] = _build/install/default/bin/e
+  argv[1] = a
+  argv[2] = b
+  argv[3] = c
+
+This wrapper parses its own arguments and executes the rest.
+
+  $ cat > wrap.sh << 'EOF'
+  > #!/bin/bash
+  > while getopts "xy" o; do
+  >   echo "Got option: $o"
+  > done
+  > shift $((OPTIND-1))
+  > echo Before
+  > "$@"
+  > echo After
+  > EOF
+  $ chmod +x wrap.sh
+
+It is possible to put the %{bin:...} pform in arguments rather than first.
+
+  $ dune exec -- ./wrap.sh -x -y %{bin:e} a b c
+  Got option: x
+  Got option: y
+  Before
+  Hello
+  argv[0] = _build/install/default/bin/e
+  argv[1] = a
+  argv[2] = b
+  argv[3] = c
+  After
+
+The first item is still looked up in PATH.
+
+  $ dune exec ls %{bin:e}
+  _build/install/default/bin/e
+
+Pforms can appear several times.
+
+  $ dune exec ls %{bin:e} %{bin:e}
+  _build/install/default/bin/e
+  _build/install/default/bin/e