Skip to content

Commit

Permalink
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
dune exec: support pform syntax
Browse files Browse the repository at this point in the history
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>
Signed-off-by: Marek Kubica <marek@tarides.com>
emillon authored and Leonidas-from-XIV committed Sep 1, 2023
1 parent 7cc79e2 commit 8bd2622
Showing 6 changed files with 235 additions and 49 deletions.
148 changes: 103 additions & 45 deletions bin/exec.ml
Original file line number Diff line number Diff line change
@@ -30,31 +30,66 @@ let man =

let info = Cmd.info "exec" ~doc ~man

module Cmd_arg = struct
type t =
| Expandable of Dune_lang.String_with_vars.t * string
| Terminal of string

let parse s =
match Arg.conv_parser Arg.dep s with
| Ok (File sw) when Dune_lang.String_with_vars.has_pforms sw -> Expandable (sw, s)
| _ -> Terminal s
;;

let pp pps = function
| Expandable (_, s) -> Format.fprintf pps "%s" s
| Terminal s -> Format.fprintf pps "%s" s
;;

let expand t ~root ~sctx =
let open Memo.O in
match t with
| Terminal s -> Memo.return s
| Expandable (sw, _) ->
let+ path, _ =
Action_builder.run (Target.expand_path_from_root root sctx sw) Eager
in
let context = Dune_rules.Super_context.context sctx in
(* TODO Why are we stringifying this path? *)
Path.to_string (Path.build (Path.Build.relative context.build_dir path))
;;

let conv = Arg.conv ((fun s -> Ok (parse s)), pp)
end

module Command_to_exec = struct
(* A command to execute, which knows how to (re)build the program and then
run it with some arguments in an enivorment *)
run it with some arguments in an environment *)

type t =
{ get_path_and_build_if_necessary :
unit -> (Path.t, [ `Already_reported ]) result Fiber.t
string -> (Path.t, [ `Already_reported ]) result Fiber.t
; prog : string
; args : string list
; env : Env.t
}

(* 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 path = Path.to_string path in
let env = Env.to_unix env |> Spawn.Env.of_list in
let argv = path :: args in
let pid = Spawn.spawn ~prog:path ~env ~argv () in
let pid =
let path = Path.to_string path in
let env = Env.to_unix env |> Spawn.Env.of_list in
let argv = path :: args in
Spawn.spawn ~prog:path ~env ~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; args; env } =
get_path_and_build_if_necessary ()
let build_and_run_in_child_process { 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))
;;
end
@@ -106,6 +141,7 @@ module Watch = struct
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
>>| Result.map ~f:(fun pid -> state.currently_running_pid := Some pid)
;;
@@ -195,63 +231,81 @@ let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog =

module Exec_context = struct
type t =
{ common : Common.t
; config : Dune_config.t
; args : string list
; env : Env.t Fiber.t
; get_path_and_build_if_necessary : (unit -> Path.t Memo.t) Fiber.t
{ prog : Cmd_arg.t
; args : Cmd_arg.t list
; env : Env.t Memo.t
; sctx : Super_context.t Memo.t
; get_path_and_build_if_necessary : prog:string -> Path.t Memo.t
}

let init ~common ~context ~no_rebuild ~prog ~args =
(* The initialization of some fields is deferred until the fiber scheduler
has been started. *)
let config = Common.init common in
let open Fiber.O in
let+ setup = Import.Main.setup () in
let open Memo.O in
let sctx =
let open Fiber.O in
let* setup = Import.Main.setup () in
let+ setup = Memo.run setup in
let+ setup = setup in
Import.Main.find_scontext_exn setup ~name:context
in
let dir =
Fiber.map sctx ~f:(fun sctx ->
let context = Dune_rules.Super_context.context sctx in
Path.Build.relative context.build_dir (Common.prefix_target common ""))
let+ sctx = sctx in
let context = Dune_rules.Super_context.context sctx in
Path.Build.relative context.build_dir (Common.prefix_target common "")
in
let env = Fiber.map sctx ~f:Super_context.context_env in
let get_path_and_build_if_necessary =
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
let env = Memo.map sctx ~f:Super_context.context_env in
let get_path_and_build_if_necessary ~prog =
let* sctx = sctx
and+ dir = dir in
get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog
in
{ common; config; env; args; get_path_and_build_if_necessary }
{ sctx; env; prog; args; get_path_and_build_if_necessary }
;;

let run_once { common; config; env; args; get_path_and_build_if_necessary; _ } =
let run_once t common config =
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* path, args, env =
let* { sctx; env; prog; args; get_path_and_build_if_necessary } = t in
Build_system.run_exn (fun () ->
let open Memo.O in
let* env = env
and* sctx = sctx in
let root = Common.root common in
let* path =
let* prog = Cmd_arg.expand prog ~root ~sctx in
get_path_and_build_if_necessary ~prog
in
let+ args = Memo.parallel_map ~f:(Cmd_arg.expand ~root ~sctx) args in
path, args, env)
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 t common config =
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 command_to_exec =
let command_to_exec () =
let open Fiber.O in
let* { sctx; env; prog; args; get_path_and_build_if_necessary } = t in
Memo.run
@@
let open Memo.O in
let* env = env
and* sctx = sctx in
let expand = Cmd_arg.expand ~root:(Common.root common) ~sctx in
let* prog = expand prog in
let+ args = Memo.parallel_map args ~f:expand in
{ Command_to_exec.get_path_and_build_if_necessary =
(fun () ->
(fun prog ->
(* TODO we should release the dune lock. But we aren't doing it
because we don't unload the database files we've marshalled.
*)
Build_system.run get_path_and_build_if_necessary)
Build_system.run (fun () -> get_path_and_build_if_necessary ~prog))
; prog
; args
; env
}
@@ -263,19 +317,23 @@ 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 Cmd_arg.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 Cmd_arg.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. *)
let config = Common.init common in
let exec_context = Exec_context.init ~common ~context ~no_rebuild ~prog ~args in
match Common.watch common with
| Yes Passive ->
User_error.raise [ Pp.textf "passive watch mode is unsupported by exec" ]
| Yes Eager -> Exec_context.run_eager_watch exec_context
| No -> Exec_context.run_once exec_context
let f =
match Common.watch common with
| Yes Passive ->
User_error.raise [ Pp.textf "passive watch mode is unsupported by exec" ]
| Yes Eager -> Exec_context.run_eager_watch
| No -> Exec_context.run_once
in
f exec_context common config
;;

let command = Cmd.v info term
16 changes: 12 additions & 4 deletions bin/target.ml
Original file line number Diff line number Diff line change
@@ -165,8 +165,8 @@ 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 sctx = Dune_engine.Context_name.Map.find_exn setup.scontexts (Context.name ctx) in
let expand_path_from_root (root : Workspace_root.t) sctx sv =
let ctx = Super_context.context sctx in
let dir =
Path.Build.relative
ctx.Context.build_dir
@@ -175,7 +175,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 sctx sv =
let+ s = expand_path_from_root root sctx sv in
Path.relative Path.root s
;;

let resolve_alias root ~recursive sv ~(setup : Dune_rules.Main.build_system) =
@@ -199,7 +204,10 @@ let resolve_target root ~setup target =
(resolve_alias root ~recursive:true sv ~setup))
| File sv as dep ->
let f ctx =
let* path = expand_path root ~setup ctx sv in
let sctx =
Dune_engine.Context_name.Map.find_exn setup.scontexts (Context.name ctx)
in
let* path = expand_path root sctx sv in
Action_builder.of_memo (resolve_path path ~setup)
>>| Result.map_error ~f:(fun hints -> dep, hints)
in
6 changes: 6 additions & 0 deletions bin/target.mli
Original file line number Diff line number Diff line change
@@ -17,3 +17,9 @@ 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_lang.String_with_vars.t
-> string Dune_engine.Action_builder.t
3 changes: 3 additions & 0 deletions doc/changes/8474.md
Original file line number Diff line number Diff line change
@@ -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, #8474, fixes #2691, @emillon, @Leonidas-from-XIV)
3 changes: 3 additions & 0 deletions src/dune_lang/string_with_vars.mli
Original file line number Diff line number Diff line change
@@ -43,7 +43,10 @@ val make_text : ?quoted:bool -> Loc.t -> string -> t
(** Concatenate a list of parts. *)
val make : ?quoted:bool -> Loc.t -> [ `Text of string | `Pform of Pform.t ] list -> t

(** [is_pform v p] holds when [v] is just the Pform [p] *)
val is_pform : t -> Pform.t -> bool

(** If [t] contains any variables *)
val has_pforms : t -> bool

(** If [t] contains no variable, returns the contents of [t]. *)
108 changes: 108 additions & 0 deletions test/blackbox-tests/test-cases/exec-bin.t
Original file line number Diff line number Diff line change
@@ -0,0 +1,108 @@
$ 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

It should also be possible to call another program that is also supposed to be
built if referenced, for this we create a new binary that calls its first
argument:

$ cat > call_arg.ml << EOF
> let () =
> let first = Sys.argv.(1) in
> Printf.printf "Calling my first arg, %S:\n" first;
> let inch, outch = Unix.open_process_args first [|first|] in
> print_endline (input_line inch);
> let status = Unix.close_process (inch, outch) in
> match status with
> | Unix.WEXITED 0 -> print_endline "All good"
> | _ -> print_endline "Something is Rotten in the State of Dune"
> EOF
$ cat > called.ml << EOF
> let () = print_endline "I was called"
> EOF
$ cat > dune << EOF
> (executables
> (public_names e call_arg called)
> (libraries unix))
> EOF

If we then ask it to execute, both `call_arg` and `called` should be compiled
and run, successfully.

$ dune exec %{bin:call_arg} %{bin:called}
Calling my first arg, "_build/install/default/bin/called":
I was called
All good

0 comments on commit 8bd2622

Please sign in to comment.