diff --git a/bin/exec.ml b/bin/exec.ml index 284fbe78effa..709a018fe698 100644 --- a/bin/exec.ml +++ b/bin/exec.ml @@ -30,13 +30,49 @@ let man = let info = Cmd.info "exec" ~doc ~man +module Cli_item = 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 root sctx item = + let open Memo.O in + match item with + | 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 + Path.to_string + (Path.build + (Path.Build.relative + (Dune_engine.Context_name.build_dir (Context.name context)) + path)) + | Terminal s -> Memo.return s + ;; + + 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 } @@ -53,8 +89,8 @@ module Command_to_exec = struct (* 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 +142,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) ;; @@ -153,7 +190,7 @@ 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 sctx ~no_rebuild ~dir prog = let open Memo.O in match Filename.analyze_program_name prog with | In_path -> @@ -195,63 +232,82 @@ 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 : Cli_item.t + ; args : Cli_item.t list + ; env : Env.t Memo.t + ; sctx : Super_context.t Memo.t + ; get_path_and_build_if_necessary : 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 item = + let* sctx = sctx + and+ dir = dir in + get_path_and_build_if_necessary sctx ~no_rebuild ~dir item 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 = Cli_item.expand root sctx prog in + get_path_and_build_if_necessary prog + in + let+ args = Memo.parallel_map ~f:(Cli_item.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 in + let* sctx = sctx in + let* prog = Cli_item.expand (Common.root common) sctx prog in + let+ args = + args |> Memo.parallel_map ~f:(Cli_item.expand (Common.root common) sctx) + in { Command_to_exec.get_path_and_build_if_necessary = - (fun () -> + (fun item -> (* 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 item)) + ; prog ; args ; env } @@ -263,19 +319,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 Cli_item.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. *) + 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 diff --git a/bin/target.ml b/bin/target.ml index ef095e370227..fefc18e86aff 100644 --- a/bin/target.ml +++ b/bin/target.ml @@ -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 diff --git a/bin/target.mli b/bin/target.mli index c4a57eb36e98..03a1e55115ce 100644 --- a/bin/target.mli +++ b/bin/target.mli @@ -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 diff --git a/doc/changes/6035.md b/doc/changes/6035.md new file mode 100644 index 000000000000..8f412364d334 --- /dev/null +++ b/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) diff --git a/src/dune_lang/string_with_vars.mli b/src/dune_lang/string_with_vars.mli index 65837e04b7d2..ec646ca423f6 100644 --- a/src/dune_lang/string_with_vars.mli +++ b/src/dune_lang/string_with_vars.mli @@ -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]. *) diff --git a/test/blackbox-tests/test-cases/exec-bin.t b/test/blackbox-tests/test-cases/exec-bin.t new file mode 100644 index 000000000000..0688a016c889 --- /dev/null +++ b/test/blackbox-tests/test-cases/exec-bin.t @@ -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