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 ocaml#2691 Signed-off-by: Etienne Millon <me@emillon.org>
emillon · Sep 2, 2022 · 3155787 · 3155787
1 parent 38c753f
commit 3155787
Show file tree

Hide file tree

Showing 4 changed files with 184 additions and 41 deletions.
diff --git a/bin/exec.ml b/bin/exec.ml
@@ -32,6 +32,35 @@ let man =
 
 let info = Term.info "exec" ~doc ~man
 
+type program_name =
+  | String of string
+  | Sw of Dune_lang.String_with_vars.t
+
+let parse_program_name s =
+  match Arg.conv_parser Arg.dep s with
+  | Ok (File sw) when String.starts_with ~prefix:"%" s -> Sw sw
+  | _ -> String s
+
+type cli_item =
+  | Program of program_name
+  | Argument of string
+
+(** Each item in the CLI is either interpreted as a program, or passed as a
+    plain argument.
+
+    The item in first position is always interpreted as a program, either in
+    pform syntax or in string syntax. The other items are only interpreted as
+    programs if they are in pform syntax. *)
+let build_cli_items prog args =
+  let prog = Program (parse_program_name prog) in
+  let args =
+    List.map args ~f:(fun s ->
+        match parse_program_name s with
+        | Sw _ as n -> Program n
+        | String s -> Argument s)
+  in
+  prog :: args
+
 let term =
   let+ common = Common.term
   and+ context =
@@ -87,48 +116,75 @@ let term =
           in
           User_error.raise ~hints [ Pp.textf "Program %S not found!" prog ]
         in
-        let* prog =
-          let open Memo.O in
+        let cli_items = build_cli_items prog args in
+        let+ argv =
           Build_system.run_exn (fun () ->
-              match Filename.analyze_program_name prog with
-              | In_path -> (
-                Super_context.resolve_program sctx ~dir ~loc:None prog
-                >>= function
-                | Error (_ : Action.Prog.Not_found.t) -> not_found ()
-                | Ok prog -> build_prog prog)
-              | Relative_to_current_dir -> (
-                let path =
-                  Path.relative_to_source_in_build_or_external ~dir prog
-                in
-                (Build_system.file_exists path >>= function
-                 | true -> Memo.return (Some path)
-                 | false -> (
-                   if not (Filename.check_suffix prog ".exe") then
-                     Memo.return None
-                   else
-                     let path = Path.extend_basename path ~suffix:".exe" in
-                     Build_system.file_exists path >>= function
-                     | true -> Memo.return (Some path)
-                     | false -> Memo.return None))
-                >>= function
-                | Some path -> build_prog path
-                | None -> not_found ())
-              | Absolute -> (
-                match
-                  let prog = Path.of_string prog in
-                  if Path.exists prog then Some prog
-                  else if not Sys.win32 then None
-                  else
-                    let prog = Path.extend_basename prog ~suffix:Bin.exe in
-                    Option.some_if (Path.exists prog) prog
-                with
-                | Some prog -> Memo.return prog
-                | None -> not_found ()))
+              Memo.List.map cli_items ~f:(function
+                | Argument s -> Memo.return s
+                | Program n ->
+                  let open Memo.O in
+                  let* prog =
+                    match n with
+                    | Sw sw ->
+                      let+ path, _ =
+                        Action_builder.run
+                          (Target.expand_path_from_root (Common.root common)
+                             ~setup 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
+                  in
+                  let+ path =
+                    match Filename.analyze_program_name prog with
+                    | In_path -> (
+                      Super_context.resolve_program sctx ~dir ~loc:None prog
+                      >>= function
+                      | Error (_ : Action.Prog.Not_found.t) -> not_found ()
+                      | Ok prog -> build_prog prog)
+                    | Relative_to_current_dir -> (
+                      let path =
+                        Path.relative_to_source_in_build_or_external ~dir prog
+                      in
+                      (Build_system.file_exists path >>= function
+                       | true -> Memo.return (Some path)
+                       | false -> (
+                         if not (Filename.check_suffix prog ".exe") then
+                           Memo.return None
+                         else
+                           let path =
+                             Path.extend_basename path ~suffix:".exe"
+                           in
+                           Build_system.file_exists path >>= function
+                           | true -> Memo.return (Some path)
+                           | false -> Memo.return None))
+                      >>= function
+                      | Some path -> build_prog path
+                      | None -> not_found ())
+                    | Absolute -> (
+                      match
+                        let prog = Path.of_string prog in
+                        if Path.exists prog then Some prog
+                        else if not Sys.win32 then None
+                        else
+                          let prog =
+                            Path.extend_basename prog ~suffix:Bin.exe
+                          in
+                          Option.some_if (Path.exists prog) prog
+                      with
+                      | Some prog -> Memo.return prog
+                      | None -> not_found ())
+                  in
+                  Path.to_string path))
         in
-        let prog = Path.to_string prog in
-        let argv = prog :: args in
+        let prog = List.hd argv in
         let env = Super_context.context_env sctx in
-        Fiber.return (prog, argv, env))
+        (prog, argv, env))
   in
   restore_cwd_and_execve common prog argv env
 

diff --git a/bin/target.ml b/bin/target.ml
@@ -102,7 +102,7 @@ let resolve_path path ~(setup : Dune_rules.Main.build_system) =
     | Some res -> Memo.return (Ok res)
     | None -> can't_build path)
 
-let expand_path (root : Workspace_root.t)
+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)
@@ -118,7 +118,11 @@ let expand_path (root : Workspace_root.t)
     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) =
   match Dune_lang.String_with_vars.text_only sv with

diff --git a/bin/target.mli b/bin/target.mli
@@ -6,3 +6,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
+  -> setup:Dune_rules.Main.build_system
+  -> Dune_rules.Context.t
+  -> Dune_lang.String_with_vars.t
+  -> string Dune_engine.Action_builder.t
diff --git a/test/blackbox-tests/test-cases/exec-bin.t b/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