From ecc3462912d93111d1e089a02608a8c0f6edd856 Mon Sep 17 00:00:00 2001
From: Jeremie Dimino <jdimino@janestreet.com>
Date: Fri, 24 Feb 2017 16:47:23 +0000
Subject: [PATCH] Add (with-stdout-to ...)

---
 doc/manual.org      |  1 +
 src/action.ml       | 10 ++++++----
 src/build.ml        |  8 ++++++--
 src/jbuild_types.ml | 25 +++++++++++++++++++++----
 4 files changed, 34 insertions(+), 10 deletions(-)

diff --git a/doc/manual.org b/doc/manual.org
index e7ea0e53..fb1c6348 100644
--- a/doc/manual.org
+++ b/doc/manual.org
@@ -798,6 +798,7 @@ The following constructions are available:
 - =(run <prog> <args>)= to execute a program
 - =(chdir <dir> <DSL>)= to change the current directory
 - =(setenv <var> <value> <DSL>)= to set an environment variable
+- =(with-stdout-to <file> <DSL>)= to redirect the output to a file
 * Usage
 
 TODO
diff --git a/src/action.ml b/src/action.ml
index 2d5ba671..c622c675 100644
--- a/src/action.ml
+++ b/src/action.ml
@@ -1,6 +1,8 @@
 type t =
-  { prog : Path.t
-  ; args : string list
-  ; dir  : Path.t
-  ; env  : string array
+  { prog      : Path.t
+  ; args      : string list
+  ; dir       : Path.t
+  ; env       : string array
+  ; stdout_to : Path.t option
+  ; touches   : Path.t list
   }
diff --git a/src/build.ml b/src/build.ml
index cc3e7e73..502a4751 100644
--- a/src/build.ml
+++ b/src/build.ml
@@ -173,8 +173,12 @@ let action ~targets =
   dyn_paths (arr (fun a -> [a.Action.prog]))
   >>>
   prim ~targets
-    (fun { Action. prog; args; env; dir } ->
-       Future.run ~dir:(Path.to_string dir) ~env (Path.reach ~from:dir prog) args)
+    (fun { Action. prog; args; env; dir; stdout_to; touches } ->
+       List.iter touches ~f:(fun fn ->
+         close_out (open_out_bin (Path.to_string fn)));
+       let stdout_to = Option.map stdout_to ~f:(Path.reach ~from:dir) in
+       Future.run ~dir:(Path.to_string dir) ~env ?stdout_to (Path.reach ~from:dir prog)
+         args)
 
 let echo fn =
   create_file ~target:fn (fun data ->
diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml
index 15806db5..d498b753 100644
--- a/src/jbuild_types.ml
+++ b/src/jbuild_types.ml
@@ -127,12 +127,14 @@ module User_action = struct
       | Run    of 'a * 'a list
       | Chdir  of 'a * 'a t
       | Setenv of 'a * 'a * 'a t
+      | With_stdout_to of 'a * 'a t
 
     let rec t a sexp =
       match sexp with
       | List (Atom "run" :: prog :: args) -> Run (a prog, List.map args ~f:a)
       | List [ Atom "chdir"; dir; arg ] -> Chdir (a dir, t a arg)
       | List [ Atom "setenv"; var; value; arg ] -> Setenv (a var, a value, t a arg)
+      | List [ Atom "with-stdout-to"; file; arg ] -> With_stdout_to (a file, t a arg)
       | _ ->
         of_sexp_error sexp "\
 invalid action, expected one of:
@@ -140,6 +142,7 @@ invalid action, expected one of:
   (run <prog> <args>)
   (chdir <dir> <action>)
   (setenv <var> <value> <action>)
+  (with-stdout-to <file> <action>)
 "
 
     let rec map t ~f =
@@ -147,33 +150,45 @@ invalid action, expected one of:
       | Run (prog, args) -> Run (f prog, List.map args ~f)
       | Chdir (fn, t) -> Chdir (f fn, map t ~f)
       | Setenv (var, value, t) -> Setenv (f var, f value, map t ~f)
+      | With_stdout_to (fn, t) -> With_stdout_to (f fn, map t ~f)
 
     let rec fold t ~init:acc ~f =
       match t with
       | Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f
       | Chdir (fn, t) -> fold t ~init:(f acc fn) ~f
       | Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f
+      | With_stdout_to (fn, t) -> fold t ~init:(f acc fn) ~f
 
     let to_action ~dir ~env (t : string t) =
-      let rec loop vars dir = function
+      let rec loop vars dir stdouts = function
         | Chdir (fn, t) ->
-          loop vars (Path.relative dir fn) t
+          loop vars (Path.relative dir fn) stdouts t
         | Setenv (var, value, t) ->
-          loop (String_map.add vars ~key:var ~data:value) dir t
+          loop (String_map.add vars ~key:var ~data:value) dir stdouts t
+        | With_stdout_to (fn, t) ->
+          loop vars dir (Path.relative dir fn :: stdouts) t
         | Run (prog, args) ->
+          let stdout_to, touches =
+            match stdouts with
+            | [] -> None, []
+            | p :: rest -> (Some p, rest)
+          in
           { Action.
             prog = Path.relative dir prog
           ; args = args
           ; dir
           ; env = Context.extend_env ~vars ~env
+          ; stdout_to
+          ; touches
           }
       in
-      loop String_map.empty dir t
+      loop String_map.empty dir [] t
 
     let rec sexp_of_t f = function
       | Run (a, xs) -> List (Atom "run" :: f a :: List.map xs ~f)
       | Chdir (a, r) -> List [Atom "chdir" ; f a ; sexp_of_t f r]
       | Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f r]
+      | With_stdout_to (fn, r) -> List [Atom "with-stdout-to"; f fn; sexp_of_t f r]
   end
 
   module T = struct
@@ -213,6 +228,8 @@ invalid action, expected one of:
       ; args = ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
       ; env
       ; dir
+      ; stdout_to = None
+      ; touches = []
       }
 end