diff --git a/src/dune/action_ast.ml b/src/dune/action_ast.ml index a93cfa6bb055..b603a764e9f2 100644 --- a/src/dune/action_ast.ml +++ b/src/dune/action_ast.ml @@ -56,7 +56,11 @@ struct [ ( "run" , let+ prog = Program.decode and+ args = repeat String.decode in - Run (prog, args) ) + Run (Success, prog, args) ) + ; ( "run-fail" + , let+ prog = Program.decode + and+ args = repeat String.decode in + Run (Fail, prog, args) ) ; ( "dynamic-run" , let+ prog = Program.decode and+ args = repeat String.decode in @@ -132,7 +136,10 @@ struct let path = Path.encode in let target = Target.encode in function - | Run (a, xs) -> List (atom "run" :: program a :: List.map xs ~f:string) + | Run (Success, a, xs) -> + List (atom "run" :: program a :: List.map xs ~f:string) + | Run (Fail, a, xs) -> + List (atom "run-fail" :: program a :: List.map xs ~f:string) | Dynamic_run (a, xs) -> List (atom "run_dynamic" :: program a :: List.map xs ~f:string) | Chdir (a, r) -> List [ atom "chdir"; path a; encode r ] @@ -181,7 +188,7 @@ struct ; target into ] - let run prog args = Run (prog, args) + let run prog args = Run (Success, prog, args) let chdir path t = Chdir (path, t) diff --git a/src/dune/action_exec.ml b/src/dune/action_exec.ml index 159df1e97080..41762e8acc14 100644 --- a/src/dune/action_exec.ml +++ b/src/dune/action_exec.ml @@ -103,11 +103,23 @@ let validate_context_and_prog context prog = invalid_prefix (Path.relative Path.build_dir target.name); invalid_prefix (Path.relative Path.build_dir ("install/" ^ target.name)) -let exec_run ~ectx ~eenv prog args = +let exec_run ~ectx ~eenv ~fail_mode prog args = validate_context_and_prog ectx.context prog; - Process.run Strict ~dir:eenv.working_dir ~env:eenv.env - ~stdout_to:eenv.stdout_to ~stderr_to:eenv.stderr_to - ~stdin_from:eenv.stdin_from ~purpose:ectx.purpose prog args + let dir = eenv.working_dir + and env = eenv.env + and stdout_to = eenv.stdout_to + and stderr_to = eenv.stderr_to + and stdin_from = eenv.stdin_from + and purpose = ectx.purpose in + match fail_mode with + | Action_intf.Fail_mode.Success -> + Process.run Strict ~dir ~env ~stdout_to ~stderr_to ~stdin_from ~purpose + prog args + | Fail -> + Fiber.map ~f:ignore + (Process.run + (Accept (Except [ 0 ])) + ~dir ~env ~stdout_to ~stderr_to ~stdin_from ~purpose prog args) let exec_run_dynamic_client ~ectx ~eenv prog args = validate_context_and_prog ectx.context prog; @@ -177,9 +189,9 @@ let exec_echo stdout_to str = let rec exec t ~ectx ~eenv = match (t : Action.t) with - | Run (Error e, _) -> Action.Prog.Not_found.raise e - | Run (Ok prog, args) -> - let+ () = exec_run ~ectx ~eenv prog args in + | Run (_, Error e, _) -> Action.Prog.Not_found.raise e + | Run (fail_mode, Ok prog, args) -> + let+ () = exec_run ~ectx ~eenv ~fail_mode prog args in Done | Dynamic_run (Error e, _) -> Action.Prog.Not_found.raise e | Dynamic_run (Ok prog, args) -> @@ -244,11 +256,14 @@ let rec exec t ~ectx ~eenv = let path, arg = Utils.system_shell_exn ~needed_to:"interpret (system ...) actions" in - let+ () = exec_run ~ectx ~eenv path [ arg; cmd ] in + let+ () = + exec_run ~ectx ~eenv ~fail_mode:Action_intf.Fail_mode.Success path + [ arg; cmd ] + in Done | Bash cmd -> let+ () = - exec_run ~ectx ~eenv + exec_run ~ectx ~eenv ~fail_mode:Action_intf.Fail_mode.Success (Utils.bash_exn ~needed_to:"interpret (bash ...) actions") [ "-e"; "-u"; "-o"; "pipefail"; "-c"; cmd ] in diff --git a/src/dune/action_intf.ml b/src/dune/action_intf.ml index 21844c48ae2d..54963d13b6d8 100644 --- a/src/dune/action_intf.ml +++ b/src/dune/action_intf.ml @@ -11,6 +11,12 @@ module Inputs = struct type t = Stdin end +module Fail_mode = struct + type t = + | Success + | Fail +end + module type Ast = sig type program @@ -21,7 +27,7 @@ module type Ast = sig type string type t = - | Run of program * string list + | Run of Fail_mode.t * program * string list | Dynamic_run of program * string list | Chdir of path * t | Setenv of string * string * t diff --git a/src/dune/action_mapper.ml b/src/dune/action_mapper.ml index b28afb27102d..89fbe510c93b 100755 --- a/src/dune/action_mapper.ml +++ b/src/dune/action_mapper.ml @@ -14,8 +14,8 @@ module Make (Src : Action_intf.Ast) (Dst : Action_intf.Ast) = struct Dst.t = let f t ~dir = f t ~dir ~f_program ~f_string ~f_path ~f_target in match t with - | Run (prog, args) -> - Run (f_program ~dir prog, List.map args ~f:(f_string ~dir)) + | Run (fail_mode, prog, args) -> + Run (fail_mode, f_program ~dir prog, List.map args ~f:(f_string ~dir)) | Dynamic_run (prog, args) -> Dynamic_run (f_program ~dir prog, List.map args ~f:(f_string ~dir)) | Chdir (fn, t) -> Chdir (f_path ~dir fn, f t ~dir:fn) diff --git a/src/dune/action_to_sh.ml b/src/dune/action_to_sh.ml index dc0b71ec457f..28b2c95f1bc3 100644 --- a/src/dune/action_to_sh.ml +++ b/src/dune/action_to_sh.ml @@ -9,6 +9,7 @@ module Simplified = struct type t = | Run of string * string list + | Or of t * t | Chdir of string | Setenv of string * string | Redirect_out of t list * Action.Outputs.t * destination @@ -37,7 +38,8 @@ let mkdir p = Run ("mkdir", [ "-p"; p ]) let simplify act = let rec loop (act : Action.For_shell.t) acc = match act with - | Run (prog, args) -> Run (prog, args) :: acc + | Run (Success, prog, args) -> Run (prog, args) :: acc + | Run (Fail, prog, args) -> Or (Run (prog, args), Run ("true", [])) :: acc | Dynamic_run (prog, args) -> Run (prog, args) :: acc | Chdir (p, act) -> loop act (Chdir p :: mkdir p :: acc) | Setenv (k, v, act) -> loop act (Setenv (k, v) :: acc) @@ -118,6 +120,7 @@ and pp = function (Pp.concat ( quote prog :: List.concat_map args ~f:(fun arg -> [ Pp.space; quote arg ]) )) + | Or (a, b) -> Pp.concat [ pp a; Pp.space; Pp.verbatim "||"; Pp.space; pp b ] | Chdir dir -> Pp.hovbox ~indent:2 (Pp.concat [ Pp.verbatim "cd"; Pp.space; quote dir ]) | Setenv (k, v) -> Pp.concat [ Pp.verbatim k; Pp.verbatim "="; quote v ] diff --git a/src/dune/action_unexpanded.ml b/src/dune/action_unexpanded.ml index 2e3a86cfbbe9..af69358fdb3b 100644 --- a/src/dune/action_unexpanded.ml +++ b/src/dune/action_unexpanded.ml @@ -108,9 +108,9 @@ module Partial = struct (prog, more_args @ args) in match t with - | Run (prog, args) -> + | Run (fail_mode, prog, args) -> let prog, args = expand_run prog args in - Run (prog, args) + Run (fail_mode, prog, args) | Dynamic_run (prog, args) -> let prog, args = expand_run prog args in Dynamic_run (prog, args) @@ -217,9 +217,9 @@ let rec partial_expand t ~map_exe ~expander : Partial.t = | Right _ as prog -> (prog, args) in match t with - | Run (prog, args) -> + | Run (fail_mode, prog, args) -> let prog, args = partial_expand_exe prog args in - Run (prog, args) + Run (fail_mode, prog, args) | Dynamic_run (prog, args) -> let prog, args = partial_expand_exe prog args in Dynamic_run (prog, args) @@ -366,7 +366,7 @@ module Infer = struct let rec infer acc t = match t with - | Run (prog, _) -> acc + acc + acc + infer (acc +@+ fn) t | Redirect_in (_, fn, t) -> infer (acc +< fn) t diff --git a/src/dune/command.ml b/src/dune/command.ml index ef2a9bc4767a..dec4e92a9fac 100644 --- a/src/dune/command.ml +++ b/src/dune/command.ml @@ -99,7 +99,7 @@ let run ~dir ?stdout_to prog args = let targets = add_targets args (Option.to_list stdout_to) in Build.declare_targets (Path.Build.Set.of_list targets) >>> Build.map (prog_and_args ~dir prog args) ~f:(fun (prog, args) -> - let action : Action.t = Run (prog, args) in + let action : Action.t = Run (Success, prog, args) in let action = match stdout_to with | None -> action diff --git a/src/dune/context.ml b/src/dune/context.ml index 4a55aa3305f3..c427dd52376c 100644 --- a/src/dune/context.ml +++ b/src/dune/context.ml @@ -139,7 +139,7 @@ let opam_config_var ~env ~cache var = match Lazy.force opam with | None -> Fiber.return None | Some fn -> ( - Process.run_capture (Accept All) fn ~env [ "config"; "var"; var ] + Process.run_capture (Accept (Except [])) fn ~env [ "config"; "var"; var ] >>| function | Ok s -> let s = String.trim s in diff --git a/src/dune/dune_file.ml b/src/dune/dune_file.ml index 2ffab50022c1..f4c9527613a2 100644 --- a/src/dune/dune_file.ml +++ b/src/dune/dune_file.ml @@ -355,7 +355,8 @@ module Preprocess = struct Action ( loc , Run - ( String_with_vars.make_var loc "bin" + ( Success + , String_with_vars.make_var loc "bin" ~payload:"ocaml-syntax-shims" , ( match for_ with | Compiler -> [ String_with_vars.make_text loc "-dump-ast" ] @@ -1874,7 +1875,8 @@ module Rule = struct , Chdir ( S.virt_var __POS__ "workspace_root" , Run - ( S.virt_text __POS__ "ocamllex" + ( Success + , S.virt_text __POS__ "ocamllex" , [ S.virt_text __POS__ "-q" ; S.virt_text __POS__ "-o" ; S.virt_var __POS__ "targets" @@ -1902,7 +1904,8 @@ module Rule = struct , Chdir ( S.virt_var __POS__ "workspace_root" , Run - ( S.virt_text __POS__ "ocamlyacc" + ( Success + , S.virt_text __POS__ "ocamlyacc" , [ S.virt_var __POS__ "deps" ] ) ) ) ; mode ; locks = [] diff --git a/src/dune/main.ml b/src/dune/main.ml index ae82bcaca43b..4c2ecb5a6237 100644 --- a/src/dune/main.ml +++ b/src/dune/main.ml @@ -118,7 +118,8 @@ let auto_concurrency = | None -> loop rest | Some prog -> ( let* result = - Process.run_capture (Accept All) prog args ~env:Env.initial + Process.run_capture (Accept (Except [])) prog args + ~env:Env.initial ~stderr_to:(Process.Io.file Config.dev_null Process.Io.Out) in match result with diff --git a/src/dune/merlin.ml b/src/dune/merlin.ml index 9439f54e80d9..37985b98273e 100644 --- a/src/dune/merlin.ml +++ b/src/dune/merlin.ml @@ -133,7 +133,7 @@ let add_source_dir t dir = let pp_flag_of_action sctx ~expander ~loc ~action : string option Build.t = match (action : Action_dune_lang.t) with - | Run (exe, args) -> ( + | Run (Success, exe, args) -> ( let args = let open Option.O in let* args, input_file = List.destruct_last args in @@ -148,7 +148,7 @@ let pp_flag_of_action sctx ~expander ~loc ~action : string option Build.t = let action = let targets_dir = Expander.dir expander in let targets = Expander.Targets.Forbidden "preprocessing actions" in - let action = Preprocessing.chdir (Run (exe, args)) in + let action = Preprocessing.chdir (Run (Success, exe, args)) in Super_context.Action.run sctx ~loc ~expander ~dep_kind:Optional ~targets ~targets_dir action (Build.return Bindings.empty) @@ -163,9 +163,10 @@ let pp_flag_of_action sctx ~expander ~loc ~action : string option Build.t = |> Option.some in Build.map action ~f:(function - | Run (exe, args) -> pp_of_action exe args - | Chdir (_, Run (exe, args)) -> pp_of_action exe args - | Chdir (_, Chdir (_, Run (exe, args))) -> pp_of_action exe args + | Run (Success, exe, args) -> pp_of_action exe args + | Chdir (_, Run (Success, exe, args)) -> pp_of_action exe args + | Chdir (_, Chdir (_, Run (Success, exe, args))) -> + pp_of_action exe args | _ -> None) ) | _ -> Build.return None diff --git a/src/dune/process.ml b/src/dune/process.ml index 01f56e1b5169..52bbab896c62 100644 --- a/src/dune/process.ml +++ b/src/dune/process.ml @@ -4,12 +4,12 @@ open Fiber.O type accepted_codes = | These of int list - | All + | Except of int list let code_is_ok accepted_codes n = match accepted_codes with | These set -> List.mem n ~set - | All -> true + | Except set -> not (List.mem n ~set) type ('a, 'b) failure_mode = | Strict : ('a, 'a) failure_mode @@ -18,7 +18,7 @@ type ('a, 'b) failure_mode = let accepted_codes : type a b. (a, b) failure_mode -> accepted_codes = function | Strict -> These [ 0 ] | Accept (These codes) -> These (0 :: codes) - | Accept All -> All + | Accept (Except _ as codes) -> codes let map_result : type a b. (a, b) failure_mode -> int Fiber.t -> f:(unit -> a) -> b Fiber.t diff --git a/src/dune/process.mli b/src/dune/process.mli index 1697cb0bc236..9e36064a0573 100644 --- a/src/dune/process.mli +++ b/src/dune/process.mli @@ -4,7 +4,7 @@ open Import type accepted_codes = | These of int list - | All + | Except of int list (** How to handle sub-process failures *) type ('a, 'b) failure_mode = diff --git a/src/dune/test_rules.ml b/src/dune/test_rules.ml index 7ce574df1def..242e7d08dc2b 100644 --- a/src/dune/test_rules.ml +++ b/src/dune/test_rules.ml @@ -22,7 +22,7 @@ let rules (t : Dune_file.Tests.t) ~sctx ~dir ~scope ~expander ~dir_contents = | Some a -> a | None -> Action_unexpanded.Run - (String_with_vars.make_var loc test_var_name, []) + (Success, String_with_vars.make_var loc test_var_name, []) in let extra_bindings = let test_exe = s ^ ".exe" in