Add (with-exit-code <pred> <action>)

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

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

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 ]

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 _

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

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

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)

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)

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

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

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

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
 

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

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. *)