Add (run-fail prog args) action

Signed-off-by: Nicolás Ojeda Bär <n.oje.bar@gmail.com>

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)
 

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

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

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)

src/dune/action_to_sh.ml

@@ -37,7 +37,7 @@ 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 (_, prog, args) -> Run (prog, args) :: 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)

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 +<! prog
+      | Run (_, prog, _) -> acc +<! prog
       | Dynamic_run (prog, _) -> acc +<! prog
       | Redirect_out (_, fn, t) -> infer (acc +@+ fn) t
       | Redirect_in (_, fn, t) -> infer (acc +< fn) t

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

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

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 = []

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

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
 

src/dune/process.ml

@@ -3,22 +3,18 @@ open Import
 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
+  not (List.mem n ~set:accepted_codes)
 
 type ('a, 'b) failure_mode =
   | Strict : ('a, 'a) failure_mode
   | Accept : accepted_codes -> ('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 list = function
+  | Strict -> [ 0 ]
+  | Accept (Except codes) -> codes
 
 let map_result :
     type a b. (a, b) failure_mode -> int Fiber.t -> f:(unit -> a) -> b Fiber.t

src/dune/process.mli

@@ -3,8 +3,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 =

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