diff --git a/doc/manual.org b/doc/manual.org
index a0d3e3c5..5a223f8c 100644
--- a/doc/manual.org
+++ b/doc/manual.org
@@ -804,6 +804,13 @@ The following constructions are available:
- =(chdir
)= to change the current directory
- =(setenv )= to set an environment variable
- =(with-stdout-to )= to redirect the output to a file
+- =(progn ...)= to execute several commands in sequence
+- =(echo )= to output a string on stdout
+- =(cat )= to print the contents of a file to stdout
+- =(copy )= to copy a file
+- =(copy-and-add-line-directive )= to copy a file and add a
+ line directive at the beginning
+
* Usage
TODO
diff --git a/src/action.ml b/src/action.ml
index aefaac06..dee7eb3a 100644
--- a/src/action.ml
+++ b/src/action.ml
@@ -7,6 +7,10 @@ module Mini_shexp = struct
| Chdir of 'a * 'a t
| Setenv of 'a * 'a * 'a t
| With_stdout_to of 'a * 'a t
+ | Progn of 'a t list
+ | Echo of 'a
+ | Cat of 'a
+ | Copy_and_add_line_directive of 'a * 'a
let rec t a sexp =
sum
@@ -14,6 +18,13 @@ module Mini_shexp = struct
; cstr "chdir" (a @> t a @> nil) (fun dn t -> Chdir (dn, t))
; cstr "setenv" (a @> a @> t a @> nil) (fun k v t -> Setenv (k, v, t))
; cstr "with-stdout-to" (a @> t a @> nil) (fun fn t -> With_stdout_to (fn, t))
+ ; cstr_rest "progn" nil (t a) (fun l -> Progn l)
+ ; cstr "echo" (a @> nil) (fun x -> Echo x)
+ ; cstr "cat" (a @> nil) (fun x -> Cat x)
+ ; cstr "copy" (a @> a @> nil) (fun src dst ->
+ With_stdout_to (dst, Cat src))
+ ; cstr "copy-and-add-line-directive" (a @> a @> nil) (fun src dst ->
+ Copy_and_add_line_directive (src, dst))
]
sexp
@@ -23,6 +34,10 @@ module Mini_shexp = struct
| 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)
+ | Progn l -> Progn (List.map l ~f:(map ~f))
+ | Echo x -> Echo (f x)
+ | Cat x -> Cat (f x)
+ | Copy_and_add_line_directive (x, y) -> Copy_and_add_line_directive (f x, f y)
let rec fold t ~init:acc ~f =
match t with
@@ -30,37 +45,21 @@ module Mini_shexp = struct
| 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 stdouts = function
- | Chdir (fn, t) ->
- loop vars (Path.relative dir fn) stdouts t
- | Setenv (var, value, 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
+ | Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
+ | Echo x -> f acc x
+ | Cat x -> f acc x
+ | Copy_and_add_line_directive (x, y) -> f (f acc x) y
let rec sexp_of_t f : _ -> Sexp.t = 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]
+ | Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f))
+ | Echo x -> List [Atom "echo"; f x]
+ | Cat x -> List [Atom "cat"; f x]
+ | Copy_and_add_line_directive (x, y) ->
+ List [Atom "copy-and-add-line-directive"; f x; f y]
end
module T = struct
@@ -91,15 +90,3 @@ end
include T
module Unexpanded = String_with_vars.Lift(T)
-
-let to_action ~dir ~env = function
- | Shexp shexp -> Mini_shexp.to_action ~dir ~env shexp
- | Bash cmd ->
- { Action.
- prog = Path.absolute "/bin/bash"
- ; args = ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
- ; env
- ; dir
- ; stdout_to = None
- ; touches = []
- }
diff --git a/src/build.ml b/src/build.ml
index c5e12984..0ab4f033 100644
--- a/src/build.ml
+++ b/src/build.ml
@@ -156,8 +156,12 @@ let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args =
>>>
prim ~targets
(fun (prog, args) ->
- let stdout_to = Option.map stdout_to ~f:Path.to_string in
- Future.run Strict ~dir:(Path.to_string dir) ?stdout_to ?env
+ let stdout_to =
+ match stdout_to with
+ | None -> Future.Terminal
+ | Some path -> File (Path.to_string path)
+ in
+ Future.run Strict ~dir:(Path.to_string dir) ~stdout_to ?env
(Path.reach prog ~from:dir) args)
let run_capture_gen ~f ?(dir=Path.root) ?env prog args =
@@ -174,16 +178,80 @@ let run_capture ?dir ?env prog args =
let run_capture_lines ?dir ?env prog args =
run_capture_gen ~f:Future.run_capture_lines ?dir ?env prog args
-let action ~targets =
- dyn_paths (arr (fun a -> [a.Action.prog]))
- >>>
- prim ~targets
- (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.to_string in
- Future.run Strict ~dir:(Path.to_string dir) ~env ?stdout_to
- (Path.reach ~from:dir prog) args)
+module Shexp = struct
+ open Future
+ open Action.Mini_shexp
+
+ let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail =
+ match t with
+ | Run (prog, args) ->
+ let stdout_to : Future.stdout_to =
+ match stdout_to with
+ | None -> Terminal
+ | Some (fn, oc) -> Opened_file { filename = fn; tail; desc = Channel oc }
+ in
+ let env = Context.extend_env ~vars:env_extra ~env in
+ Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to prog args
+ | Chdir (fn, t) ->
+ exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn)
+ | Setenv (var, value, t) ->
+ exec t ~dir ~env ~stdout_to ~tail
+ ~env_extra:(String_map.add env_extra ~key:var ~data:value)
+ | With_stdout_to (fn, t) ->
+ if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
+ let fn = Path.to_string (Path.relative dir fn) in
+ exec t ~dir ~env ~env_extra ~tail
+ ~stdout_to:(Some (fn, open_out_bin fn))
+ | Progn l ->
+ exec_list l ~dir ~env ~env_extra ~stdout_to ~tail
+ | Echo str ->
+ return
+ (match stdout_to with
+ | None -> print_string str; flush stdout
+ | Some (_, oc) ->
+ output_string oc str;
+ if tail then close_out oc)
+ | Cat fn ->
+ let fn = Path.to_string (Path.relative dir fn) in
+ with_file_in fn ~f:(fun ic ->
+ match stdout_to with
+ | None -> copy_channels ic stdout
+ | Some (_, oc) ->
+ copy_channels ic oc;
+ if tail then close_out oc);
+ return ()
+ | Copy_and_add_line_directive (src, dst) ->
+ let src = Path.to_string (Path.relative dir src) in
+ let dst = Path.to_string (Path.relative dir dst) in
+ with_file_in src ~f:(fun ic ->
+ with_file_out dst ~f:(fun oc ->
+ Printf.fprintf oc "# 1 %S\n" src;
+ copy_channels ic oc));
+ return ()
+
+ and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail =
+ match l with
+ | [] ->
+ if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
+ Future.return ()
+ | [t] ->
+ exec t ~dir ~env ~env_extra ~stdout_to ~tail
+ | t :: rest ->
+ exec t ~dir ~env ~env_extra ~stdout_to ~tail:false >>= fun () ->
+ exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail
+
+ let exec t ~dir ~env =
+ exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true
+end
+
+let action ~dir ~env ~targets =
+ prim ~targets (fun action ->
+ match (action : string Action.t) with
+ | Bash cmd ->
+ Future.run Strict ~dir:(Path.to_string dir) ~env
+ "/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
+ | Shexp shexp ->
+ Shexp.exec ~dir ~env shexp)
let echo fn =
create_file ~target:fn (fun data ->
@@ -196,4 +264,6 @@ let copy ~src ~dst =
let touch target =
create_file ~target (fun _ ->
- close_out (open_out_bin (Path.to_string target)))
+ Unix.close
+ (Unix.openfile (Path.to_string target)
+ [O_CREAT; O_TRUNC; O_WRONLY] 0o666))
diff --git a/src/future.ml b/src/future.ml
index e18fc8b4..be7d25de 100644
--- a/src/future.ml
+++ b/src/future.ml
@@ -152,11 +152,26 @@ let map_result
| 0 -> Ok (f ())
| n -> Error n
+type stdout_to =
+ | Terminal
+ | File of string
+ | Opened_file of opened_file
+
+and opened_file =
+ { filename : string
+ ; desc : opened_file_desc
+ ; tail : bool
+ }
+
+and opened_file_desc =
+ | Fd of Unix.file_descr
+ | Channel of out_channel
+
type job =
{ prog : string
; args : string list
; dir : string option
- ; stdout_to : string option
+ ; stdout_to : stdout_to
; env : string array option
; ivar : int Ivar.t
; ok_codes : int list
@@ -164,7 +179,7 @@ type job =
let to_run : job Queue.t = Queue.create ()
-let run_internal ?dir ?stdout_to ?env fail_mode prog args =
+let run_internal ?dir ?(stdout_to=Terminal) ?env fail_mode prog args =
let dir =
match dir with
| Some "." -> None
@@ -205,7 +220,7 @@ end
let run_capture_gen ?dir ?env fail_mode prog args ~f =
let fn = Temp.create "jbuild" ".output" in
- map_result fail_mode (run_internal ?dir ~stdout_to:fn ?env fail_mode prog args)
+ map_result fail_mode (run_internal ?dir ~stdout_to:(File fn) ?env fail_mode prog args)
~f:(fun () ->
let x = f fn in
Temp.destroy fn;
@@ -279,8 +294,8 @@ module Scheduler = struct
| Some dir -> sprintf "(cd %s && %s)" dir s
in
match stdout_to with
- | None -> s
- | Some fn -> sprintf "%s > %s" s fn
+ | Terminal -> s
+ | File fn | Opened_file { filename = fn; _ } -> sprintf "%s > %s" s fn
type running_job =
{ id : int
@@ -429,10 +444,17 @@ module Scheduler = struct
let output_fd = Unix.openfile output_filename [O_WRONLY] 0 in
let stdout, close_stdout =
match job.stdout_to with
- | None -> (output_fd, false)
- | Some fn ->
+ | Terminal -> (output_fd, None)
+ | File fn ->
let fd = Unix.openfile fn [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in
- (fd, true)
+ (fd, Some (Fd fd))
+ | Opened_file { desc; tail; _ } ->
+ let fd =
+ match desc with
+ | Fd fd -> fd
+ | Channel oc -> flush oc; Unix.descr_of_out_channel oc
+ in
+ (fd, Option.some_if tail desc)
in
Option.iter job.dir ~f:(fun dir -> Sys.chdir dir);
let pid =
@@ -446,7 +468,9 @@ module Scheduler = struct
in
Option.iter job.dir ~f:(fun _ -> Sys.chdir cwd);
Unix.close output_fd;
- if close_stdout then Unix.close stdout;
+ Option.iter close_stdout ~f:(function
+ | Fd fd -> Unix.close fd
+ | Channel oc -> close_out oc);
Hashtbl.add running ~key:pid
~data:{ id
; job
diff --git a/src/future.mli b/src/future.mli
index 9d00e9f7..035868c8 100644
--- a/src/future.mli
+++ b/src/future.mli
@@ -23,10 +23,27 @@ type ('a, 'b) failure_mode =
(** Accept the following non-zero exit codes, and return [Error code] if the process
exists with one of these codes. *)
+(** Where to redirect standard output *)
+type stdout_to =
+ | Terminal
+ | File of string
+ | Opened_file of opened_file
+
+and opened_file =
+ { filename : string
+ ; desc : opened_file_desc
+ ; tail : bool
+ (** If [true], the descriptor is closed after starting the command *)
+ }
+
+and opened_file_desc =
+ | Fd of Unix.file_descr
+ | Channel of out_channel
+
(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *)
val run
: ?dir:string
- -> ?stdout_to:string
+ -> ?stdout_to:stdout_to
-> ?env:string array
-> (unit, 'a) failure_mode
-> string
diff --git a/src/gen_rules.ml b/src/gen_rules.ml
index e36be05c..a8e705e1 100644
--- a/src/gen_rules.ml
+++ b/src/gen_rules.ml
@@ -1232,21 +1232,21 @@ module Gen(P : Params) = struct
| User actions |
+-----------------------------------------------------------------+ *)
- module User_action_interpret : sig
+ module Action_interpret : sig
val expand
- : User_action.Unexpanded.t
+ : Action.Unexpanded.t
-> dir:Path.t
-> dep_kind:Build.lib_dep_kind
-> targets:string list
-> deps:Dep_conf.t list
- -> (unit, string User_action.t) Build.t
+ -> (unit, string Action.t) Build.t
val run
: dir:Path.t
-> targets:Path.t list
- -> (string User_action.t, unit) Build.t
+ -> (string Action.t, unit) Build.t
end = struct
- module U = User_action.Unexpanded
+ module U = Action.Unexpanded
type artefact =
| Direct of Path.t
@@ -1314,9 +1314,7 @@ module Gen(P : Params) = struct
end
let run ~dir ~targets =
- Build.arr (User_action.to_action ~dir ~env:ctx.env)
- >>>
- Build.action ~targets
+ Build.action ~dir ~env:ctx.env ~targets
end
(* +-----------------------------------------------------------------+
@@ -1328,14 +1326,14 @@ module Gen(P : Params) = struct
add_rule
(Dep_conf_interpret.dep_of_list ~dir rule.deps
>>>
- User_action_interpret.expand
+ Action_interpret.expand
rule.action
~dir
~dep_kind:Required
~targets:rule.targets
~deps:rule.deps
>>>
- User_action_interpret.run
+ Action_interpret.run
~dir
~targets)
@@ -1346,7 +1344,7 @@ module Gen(P : Params) = struct
let action =
match alias_conf.action with
| None -> Sexp.Atom "none"
- | Some a -> List [Atom "some" ; User_action.Unexpanded.sexp_of_t a] in
+ | Some a -> List [Atom "some" ; Action.Unexpanded.sexp_of_t a] in
Sexp.List [deps ; action]
|> Sexp.to_string
|> Digest.string
@@ -1361,13 +1359,13 @@ module Gen(P : Params) = struct
| None -> deps
| Some action ->
deps
- >>> User_action_interpret.expand
+ >>> Action_interpret.expand
action
~dir
~dep_kind:Required
~targets:[]
~deps:alias_conf.deps
- >>> User_action_interpret.run ~dir ~targets:[] in
+ >>> Action_interpret.run ~dir ~targets:[] in
add_rule (deps >>> dummy)
(* +-----------------------------------------------------------------+
diff --git a/src/import.ml b/src/import.ml
index 8902b9d4..dcd524de 100644
--- a/src/import.ml
+++ b/src/import.ml
@@ -284,6 +284,9 @@ module Option = struct
let value_exn = function
| Some x -> x
| None -> assert false
+
+ let some_if cond x =
+ if cond then Some x else None
end
type ('a, 'b) eq = Eq : ('a, 'a) eq