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