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

CHANGES.md

@@ -146,6 +146,10 @@
   self-contained bytecode executables whenever this options is available
   (OCaml version >= 4.10) (#2692, @nojb)
 
+- Add action `(with-exit-codes <pred> <action>)` to specify the set of
+  successful exit codes of `<action>`. `<pred>` is specified using the predicate
+  language. (#2699, @nojb)
+
 1.11.4 (09/10/2019)
 -------------------
 

doc/concepts.rst

@@ -87,6 +87,29 @@ an flambda compiler with the help of variable expansion:
 
    (and %{ocamlc-config:flambda} (= %{ocamlc-config:system} macosx))
 
+.. _predicate-lang:
+
+Predicate language
+==================
+
+The predicate language allows the user to define simple predicates
+(boolean-valued functions) that dune can evaluate. Here is a semi formal
+specification of the language:
+
+.. code::
+
+   pred := (and <pred> <pred>)
+         | (or <pred> <pred>)
+         | (not <pred>)
+         | :standard
+         | <element>
+
+The exact meaning of ``:standard`` and the nature of ``<element>`` depends on
+the context. For example, in the case of the :ref:`dune-subdirs`, an
+``<element>`` corresponds to file glob patterns. Another example is the user
+action :ref:`(with-exit-codes ...) <user-actions>`, where an ``<element>``
+corresponds to a literal integer.
+
 .. _variables:
 
 Variables
@@ -620,6 +643,10 @@ The following constructions are available:
 - ``(ignore-<outputs> <DSL)`` to ignore the output, where
   ``<outputs>`` is one of: ``stdout``, ``stderr`` or ``outputs``
 - ``(with-stdin-from <file> <DSL>)`` to redirect the input from a file
+- ``(with-exit-codes <pred> <DSL>)`` specifies the list of expected exit codes
+  for the programs executed in ``<DSL>``. ``<pred>`` is a predicate on integer
+  values, and is specified using the :ref:`predicate-lang`. This action is
+  available since dune 2.0.
 - ``(progn <DSL>...)`` to execute several commands in sequence
 - ``(echo <string>)`` to output a string on stdout
 - ``(write-file <file> <string>)`` writes ``<string>`` to ``<file>``

doc/dune-files.rst

@@ -804,10 +804,10 @@ field. The following modes are available:
     from the source tree.
   - ``(into <dir>)`` means that the files are promoted in ``<dir>`` instead of
     the current directory. This feature is available since Dune 1.8.
-  - ``(only <predicate>)`` means that only a subset of the targets
-    should be promoted. The argument is a predicate in a syntax
-    similar to the argument of :ref:`(dirs ...) <dune-subdirs>`. This
-    feature is available since dune 1.10.
+  - ``(only <predicate>)`` means that only a subset of the targets should be
+    promoted. The argument is similar to the argument of :ref:`(dirs ...)
+    <dune-subdirs>`, specified using the :ref:`predicate-lang`. This feature is
+    available since dune 1.10.
 
 - ``promote-until-clean`` is the same as ``(promote (until-clean))``
 - ``(promote-into <dir>)`` is the same as ``(promote (into <dir>))``
@@ -1275,7 +1275,7 @@ dirs (since 1.6)
 -------------------
 
 The ``dirs`` stanza allows to tell specify the sub-directories dune will
-include in a build. The syntax is based on dune's predicate language and allows
+include in a build. The syntax is based on dune's :ref:`predicate-lang` and allows
 the user the following operations:
 
 - The special value ``:standard`` which refers to the default set of used

editor-integration/emacs/dune.el

@@ -113,6 +113,7 @@
                "run" "chdir" "setenv"
                "with-stdout-to" "with-stderr-to" "with-outputs-to"
                "ignore-stdout" "ignore-stderr" "ignore-outputs"
+               "with-stdin-from" "with-exit-codes"
                "progn" "echo" "write-file" "cat" "copy" "copy#" "system"
                "bash" "diff" "diff?" "cmp"
                ;; FIXME: "flags" is already a field and we do not have enough

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

@@ -35,16 +35,28 @@ module Mapper = Action_mapper.Make (Uast) (Uast)
    Having more than one dynamic_run with different cwds could break that. Also,
    we didn't really want to think about how multiple dynamic actions would
    interact (do we want dependencies requested by one to be visible to the
-   other?) *)
+   other?).
+
+   Moreover, we also check that 'dynamic-run' is not used within
+   'with-exit-codes', since the meaning of this interaction is not clear. *)
 let ensure_at_most_one_dynamic_run ~loc action =
-  let rec loop : t -> bool = function
+  let rec loop : bool -> t -> bool =
+   fun with_exit_codes -> function
+    | Dynamic_run _ when with_exit_codes ->
+      User_error.raise ~loc
+        [ Pp.textf
+            "'dynamic-run' can not be used within the scope of \
+             'with-exit-codes'."
+        ]
     | Dynamic_run _ -> true
     | Chdir (_, t)
     | Setenv (_, _, t)
     | Redirect_out (_, _, t)
     | Redirect_in (_, _, t)
     | Ignore (_, t) ->
-      loop t
+      loop with_exit_codes t
+    | With_exit_codes (_, t) ->
+      loop true t
     | Run _
     | Echo _
     | Cat _
@@ -63,7 +75,7 @@ let ensure_at_most_one_dynamic_run ~loc action =
       false
     | Progn ts ->
       List.fold_left ts ~init:false ~f:(fun acc t ->
-          let have_dyn = loop t in
+          let have_dyn = loop with_exit_codes t in
           if acc && have_dyn then
             User_error.raise ~loc
               [ Pp.text
@@ -73,7 +85,7 @@ let ensure_at_most_one_dynamic_run ~loc action =
           else
             acc || have_dyn)
   in
-  ignore (loop action)
+  ignore (loop false action)
 
 let validate ~loc t = ensure_at_most_one_dynamic_run ~loc t
 

src/dune/action_exec.ml

@@ -82,6 +82,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 Predicate_lang.Ast.t
   }
 
 let validate_context_and_prog context prog =
@@ -107,9 +108,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;
@@ -183,6 +185,9 @@ let rec exec t ~ectx ~eenv =
   | Run (Ok prog, args) ->
     let+ () = exec_run ~ectx ~eenv prog args in
     Done
+  | With_exit_codes (exit_codes, t) ->
+    let eenv = { eenv with exit_codes } 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
@@ -416,6 +421,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 = Predicate_lang.Ast.Element 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 Predicate_lang.Ast.any) 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 Predicate_lang.Ast.any) 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