From 42944d6ffa0f21aa90fa2b5feb88eb3b49ee6b1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Sun, 6 Oct 2019 15:48:42 +0200 Subject: [PATCH] Add (with-exit-code ) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Nicolás Ojeda Bär --- src/dune/action.ml | 9 ++++++--- src/dune/action_ast.ml | 12 ++++++++++++ src/dune/action_dune_lang.ml | 3 ++- src/dune/action_exec.ml | 15 ++++++++++++++- src/dune/action_intf.ml | 1 + src/dune/action_mapper.ml | 1 + src/dune/action_to_sh.ml | 1 + src/dune/action_unexpanded.ml | 5 +++++ src/dune/context.ml | 2 +- src/dune/main.ml | 3 ++- src/dune/merlin.ml | 3 ++- src/dune/process.ml | 27 +++++---------------------- src/dune/process.mli | 6 +----- 13 files changed, 53 insertions(+), 35 deletions(-) diff --git a/src/dune/action.ml b/src/dune/action.ml index 9ed70010b2d7..3ca56bc4b3d5 100644 --- a/src/dune/action.ml +++ b/src/dune/action.ml @@ -147,7 +147,8 @@ let fold_one_step t ~init:acc ~f = | Setenv (_, _, t) | Redirect_out (_, _, t) | Redirect_in (_, _, t) - | Ignore (_, t) -> + | Ignore (_, t) + | With_exit_codes (_, t) -> f acc t | Progn l -> List.fold_left l ~init:acc ~f | Run _ @@ -187,7 +188,8 @@ let rec is_dynamic = function | Setenv (_, _, t) | Redirect_out (_, _, t) | Redirect_in (_, _, t) - | Ignore (_, t) -> + | Ignore (_, t) + | With_exit_codes (_, t) -> is_dynamic t | Progn l -> List.exists l ~f:is_dynamic | Run _ @@ -265,7 +267,8 @@ let is_useful_to_sandbox = | Setenv (_, _, t) -> loop t | Redirect_out (_, _, t) -> loop t | Redirect_in (_, _, t) -> loop t - | Ignore (_, t) -> loop t + | Ignore (_, t) + | With_exit_codes (_, t) -> loop t | Progn l -> List.exists l ~f:loop | Echo _ -> false | Cat _ -> false diff --git a/src/dune/action_ast.ml b/src/dune/action_ast.ml index a93cfa6bb055..bd283ea3f82c 100644 --- a/src/dune/action_ast.ml +++ b/src/dune/action_ast.ml @@ -57,6 +57,12 @@ struct , let+ prog = Program.decode and+ args = repeat String.decode in Run (prog, args) ) + ; ( "with-exit-codes" + , Dune_lang.Syntax.since Stanza.syntax (2, 0) + >>> let+ codes = + Predicate_lang.Ast.decode_one Dune_lang.Decoder.int + and+ t = t in + With_exit_codes (codes, t) ) ; ( "dynamic-run" , let+ prog = Program.decode and+ args = repeat String.decode in @@ -133,6 +139,12 @@ struct let target = Target.encode in function | Run (a, xs) -> List (atom "run" :: program a :: List.map xs ~f:string) + | With_exit_codes (pred, t) -> + List + [ atom "with-exit-codes" + ; Predicate_lang.Ast.encode Dune_lang.Encoder.int pred + ; encode t + ] | 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 ] diff --git a/src/dune/action_dune_lang.ml b/src/dune/action_dune_lang.ml index 93b5cfbc42b1..ac58a633e563 100644 --- a/src/dune/action_dune_lang.ml +++ b/src/dune/action_dune_lang.ml @@ -43,7 +43,8 @@ let ensure_at_most_one_dynamic_run ~loc action = | Setenv (_, _, t) | Redirect_out (_, _, t) | Redirect_in (_, _, t) - | Ignore (_, t) -> + | Ignore (_, t) + | With_exit_codes (_, t) -> loop t | Run _ | Echo _ diff --git a/src/dune/action_exec.ml b/src/dune/action_exec.ml index 159df1e97080..858e6891fae2 100644 --- a/src/dune/action_exec.ml +++ b/src/dune/action_exec.ml @@ -80,6 +80,7 @@ type exec_environment = ; stderr_to : Process.Io.output Process.Io.t ; stdin_from : Process.Io.input Process.Io.t ; prepared_dependencies : DAP.Dependency.Set.t + ; exit_codes : int -> bool } let validate_context_and_prog context prog = @@ -105,9 +106,10 @@ let validate_context_and_prog context prog = let exec_run ~ectx ~eenv prog args = validate_context_and_prog ectx.context prog; - Process.run Strict ~dir:eenv.working_dir ~env:eenv.env + Process.run (Accept eenv.exit_codes) ~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 + |> Fiber.map ~f:ignore let exec_run_dynamic_client ~ectx ~eenv prog args = validate_context_and_prog ectx.context prog; @@ -181,6 +183,16 @@ let rec exec t ~ectx ~eenv = | Run (Ok prog, args) -> let+ () = exec_run ~ectx ~eenv prog args in Done + | With_exit_codes (pred, t) -> + let eenv = + { eenv with + exit_codes = + (fun i -> + Predicate_lang.Ast.exec pred + ~standard:(Predicate_lang.Ast.Element 0) (Int.equal i)) + } + in + exec t ~ectx ~eenv | Dynamic_run (Error e, _) -> Action.Prog.Not_found.raise e | Dynamic_run (Ok prog, args) -> exec_run_dynamic_client ~ectx ~eenv prog args @@ -414,6 +426,7 @@ let exec ~targets ~context ~env ~rule_loc ~build_deps t = ; stderr_to = Process.Io.stderr ; stdin_from = Process.Io.stdin ; prepared_dependencies = DAP.Dependency.Set.empty + ; exit_codes = Int.equal 0 } in exec_until_all_deps_ready t ~ectx ~eenv diff --git a/src/dune/action_intf.ml b/src/dune/action_intf.ml index 21844c48ae2d..f5d51c18b933 100644 --- a/src/dune/action_intf.ml +++ b/src/dune/action_intf.ml @@ -22,6 +22,7 @@ module type Ast = sig type t = | Run of program * string list + | With_exit_codes of int Predicate_lang.Ast.t * t | 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..f567e8a894c6 100755 --- a/src/dune/action_mapper.ml +++ b/src/dune/action_mapper.ml @@ -16,6 +16,7 @@ module Make (Src : Action_intf.Ast) (Dst : Action_intf.Ast) = struct match t with | Run (prog, args) -> Run (f_program ~dir prog, List.map args ~f:(f_string ~dir)) + | With_exit_codes (pred, t) -> With_exit_codes (pred, f t ~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..ad93be0a6d28 100644 --- a/src/dune/action_to_sh.ml +++ b/src/dune/action_to_sh.ml @@ -38,6 +38,7 @@ let simplify act = let rec loop (act : Action.For_shell.t) acc = match act with | Run (prog, args) -> Run (prog, args) :: acc + | With_exit_codes (_, t) -> loop t acc (* FIXME *) | 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) diff --git a/src/dune/action_unexpanded.ml b/src/dune/action_unexpanded.ml index 2e3a86cfbbe9..f7c3b9677d19 100644 --- a/src/dune/action_unexpanded.ml +++ b/src/dune/action_unexpanded.ml @@ -111,6 +111,8 @@ module Partial = struct | Run (prog, args) -> let prog, args = expand_run prog args in Run (prog, args) + | With_exit_codes (pred, t) -> + With_exit_codes (pred, expand ~expander ~map_exe t) | Dynamic_run (prog, args) -> let prog, args = expand_run prog args in Dynamic_run (prog, args) @@ -220,6 +222,8 @@ let rec partial_expand t ~map_exe ~expander : Partial.t = | Run (prog, args) -> let prog, args = partial_expand_exe prog args in Run (prog, args) + | With_exit_codes (pred, t) -> + With_exit_codes (pred, partial_expand t ~expander ~map_exe) | Dynamic_run (prog, args) -> let prog, args = partial_expand_exe prog args in Dynamic_run (prog, args) @@ -367,6 +371,7 @@ module Infer = struct let rec infer acc t = match t with | Run (prog, _) -> acc + infer acc t | Dynamic_run (prog, _) -> acc + infer (acc +@+ fn) t | Redirect_in (_, fn, t) -> infer (acc +< fn) t diff --git a/src/dune/context.ml b/src/dune/context.ml index 4a55aa3305f3..9c0138a420be 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 (fun _ -> true)) fn ~env [ "config"; "var"; var ] >>| function | Ok s -> let s = String.trim s in diff --git a/src/dune/main.ml b/src/dune/main.ml index ae82bcaca43b..47606010f677 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 (fun _ -> true)) 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..080e4a474957 100644 --- a/src/dune/merlin.ml +++ b/src/dune/merlin.ml @@ -165,7 +165,8 @@ let pp_flag_of_action sctx ~expander ~loc ~action : string option Build.t = 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 + | Chdir (_, Chdir (_, Run (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..5d8441199f58 100644 --- a/src/dune/process.ml +++ b/src/dune/process.ml @@ -2,23 +2,13 @@ open! Stdune open Import open Fiber.O -type accepted_codes = - | These of int list - | All - -let code_is_ok accepted_codes n = - match accepted_codes with - | These set -> List.mem n ~set - | All -> true - type ('a, 'b) failure_mode = | Strict : ('a, 'a) failure_mode - | Accept : accepted_codes -> ('a, ('a, int) result) failure_mode + | Accept : (int -> bool) -> ('a, ('a, int) result) 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 +let accepted_codes : type a b. (a, b) failure_mode -> int -> bool = function + | Strict -> Int.equal 0 + | Accept f -> f let map_result : type a b. (a, b) failure_mode -> int Fiber.t -> f:(unit -> a) -> b Fiber.t @@ -372,13 +362,6 @@ module Exit_status = struct ++ pp_id id ++ Pp.char ':' ; output ])); - if n <> 0 then - User_warning.emit - [ Pp.tag ~tag:User_message.Style.Kwd (Pp.verbatim "Command") - ++ Pp.space ++ pp_id id - ++ Pp.textf - " exited with code %d, but I'm ignoring it, hope that's OK." n - ]; n | Error err -> let msg = @@ -555,7 +538,7 @@ let run_internal ?dir ?(stdout_to = Io.stdout) ?(stderr_to = Io.stderr) Log.command ~command_line ~output ~exit_status; let exit_status : Exit_status.t = match exit_status with - | WEXITED n when code_is_ok ok_codes n -> Ok n + | WEXITED n when ok_codes n -> Ok n | WEXITED n -> Error (Failed n) | WSIGNALED n -> Error (Signaled (Signal.name n)) | WSTOPPED _ -> assert false diff --git a/src/dune/process.mli b/src/dune/process.mli index 1697cb0bc236..19ab310e5113 100644 --- a/src/dune/process.mli +++ b/src/dune/process.mli @@ -2,15 +2,11 @@ open Import -type accepted_codes = - | These of int list - | All - (** How to handle sub-process failures *) type ('a, 'b) failure_mode = | Strict : ('a, 'a) failure_mode (** Fail if the process exits with anything else than [0] *) - | Accept : accepted_codes -> ('a, ('a, int) result) failure_mode + | Accept : (int -> bool) -> ('a, ('a, int) result) failure_mode (** Accept the following non-zero exit codes, and return [Error code] if the process exists with one of these codes. *)