2017-02-27 13:34:16 +00:00
|
|
|
open Import
|
|
|
|
open Sexp.Of_sexp
|
|
|
|
|
2017-04-24 11:27:13 +00:00
|
|
|
module Env_var_map = Context.Env_var_map
|
|
|
|
|
2017-05-30 16:35:49 +00:00
|
|
|
module Program = struct
|
|
|
|
type t =
|
|
|
|
| This of Path.t
|
|
|
|
| Not_found of string
|
|
|
|
|
|
|
|
let sexp_of_t = function
|
2017-05-31 07:31:52 +00:00
|
|
|
| This p -> Path.sexp_of_t p
|
2017-05-30 16:35:49 +00:00
|
|
|
| Not_found s -> List [Atom "not_found"; Atom s]
|
|
|
|
|
|
|
|
let t sexp =
|
|
|
|
match sexp with
|
|
|
|
| Atom _ -> This (Path.t sexp)
|
|
|
|
| List (_, [Atom (_, "not_found"); Atom (_, s)]) -> Not_found s
|
|
|
|
| _ ->
|
|
|
|
Loc.fail (Sexp.Ast.loc sexp)
|
|
|
|
"S-expression of the form <atom> or (not_found <atom>) expected"
|
2017-05-31 07:31:52 +00:00
|
|
|
|
|
|
|
let resolve ctx ~dir s =
|
|
|
|
if s = "" then
|
|
|
|
Not_found ""
|
|
|
|
else if String.contains s '/' then
|
|
|
|
This (Path.relative dir s)
|
|
|
|
else
|
|
|
|
match Context.which ctx s with
|
|
|
|
| Some p -> This p
|
|
|
|
| None -> Not_found s
|
2017-05-30 16:35:49 +00:00
|
|
|
end
|
|
|
|
|
2017-05-30 14:40:06 +00:00
|
|
|
module Var_expansion = struct
|
|
|
|
module Concat_or_split = struct
|
|
|
|
type t =
|
|
|
|
| Concat (* default *)
|
|
|
|
| Split (* ${!...} *)
|
|
|
|
end
|
2017-05-29 18:12:37 +00:00
|
|
|
|
2017-05-30 14:40:06 +00:00
|
|
|
open Concat_or_split
|
2017-03-03 11:49:40 +00:00
|
|
|
|
2017-05-30 14:40:06 +00:00
|
|
|
type t =
|
|
|
|
| Paths of Path.t list * Concat_or_split.t
|
|
|
|
| Strings of string list * Concat_or_split.t
|
2017-03-03 11:49:40 +00:00
|
|
|
|
2017-05-30 14:40:06 +00:00
|
|
|
let concat = function
|
|
|
|
| [s] -> s
|
|
|
|
| l -> String.concat ~sep:" " l
|
2017-05-29 18:12:37 +00:00
|
|
|
|
2017-05-30 14:40:06 +00:00
|
|
|
let string_of_path ~dir p = Path.reach ~from:dir p
|
|
|
|
let path_of_string ~dir s = Path.relative dir s
|
2017-03-03 11:49:40 +00:00
|
|
|
|
2017-05-30 14:40:06 +00:00
|
|
|
let to_strings ~dir = function
|
|
|
|
| Strings (l, Split ) -> l
|
|
|
|
| Strings (l, Concat) -> [concat l]
|
|
|
|
| Paths (l, Split ) -> List.map l ~f:(string_of_path ~dir)
|
|
|
|
| Paths (l, Concat) -> [concat (List.map l ~f:(string_of_path ~dir))]
|
|
|
|
|
|
|
|
let to_string ~dir = function
|
|
|
|
| Strings (_, Split) | Paths (_, Split) -> assert false
|
|
|
|
| Strings (l, Concat) -> concat l
|
|
|
|
| Paths (l, Concat) -> concat (List.map l ~f:(string_of_path ~dir))
|
|
|
|
|
|
|
|
let to_path ~dir = function
|
|
|
|
| Strings (_, Split) | Paths (_, Split) -> assert false
|
|
|
|
| Strings (l, Concat) -> path_of_string ~dir (concat l)
|
|
|
|
| Paths ([p], Concat) -> p
|
|
|
|
| Paths (l, Concat) ->
|
|
|
|
path_of_string ~dir (concat (List.map l ~f:(string_of_path ~dir)))
|
|
|
|
|
2017-05-31 07:31:52 +00:00
|
|
|
let to_prog_and_args ctx ~dir exp : Program.t * string list =
|
|
|
|
let resolve = Program.resolve in
|
|
|
|
match exp with
|
|
|
|
| Paths ([p], _) -> (This p, [])
|
|
|
|
| Strings ([s], _) -> (resolve ctx ~dir s, [])
|
|
|
|
| Paths ([], _) | Strings ([], _) -> (Not_found "", [])
|
|
|
|
| Paths (l, Concat) ->
|
|
|
|
(This
|
|
|
|
(path_of_string ~dir
|
|
|
|
(concat (List.map l ~f:(string_of_path ~dir)))),
|
|
|
|
[])
|
|
|
|
| Strings (l, Concat) ->
|
|
|
|
(resolve ~dir ctx (concat l), l)
|
|
|
|
| Paths (p :: l, Split) ->
|
|
|
|
(This p, List.map l ~f:(string_of_path ~dir))
|
|
|
|
| Strings (s :: l, Split) ->
|
|
|
|
(resolve ~dir ctx s, l)
|
2017-05-30 14:40:06 +00:00
|
|
|
end
|
2017-03-06 12:22:44 +00:00
|
|
|
|
2017-05-31 07:31:52 +00:00
|
|
|
module VE = Var_expansion
|
|
|
|
module SW = String_with_vars
|
|
|
|
|
2017-05-28 00:29:12 +00:00
|
|
|
module Outputs = struct
|
|
|
|
include Action_intf.Outputs
|
2017-05-27 23:48:48 +00:00
|
|
|
|
2017-05-28 00:29:12 +00:00
|
|
|
let to_string = function
|
2017-05-27 23:48:48 +00:00
|
|
|
| Stdout -> "stdout"
|
|
|
|
| Stderr -> "stderr"
|
|
|
|
| Outputs -> "outputs"
|
2017-05-28 00:29:12 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
module type Sexpable = sig
|
|
|
|
type t
|
|
|
|
val t : t Sexp.Of_sexp.t
|
|
|
|
val sexp_of_t : t Sexp.To_sexp.t
|
|
|
|
end
|
2017-05-27 23:48:48 +00:00
|
|
|
|
2017-05-28 00:29:12 +00:00
|
|
|
module Make_ast
|
2017-05-30 16:35:49 +00:00
|
|
|
(Program : Sexpable)
|
|
|
|
(Path : Sexpable)
|
|
|
|
(String : Sexpable)
|
2017-05-28 00:29:12 +00:00
|
|
|
(Ast : Action_intf.Ast
|
2017-05-30 16:35:49 +00:00
|
|
|
with type program := Program.t
|
|
|
|
with type path := Path.t
|
|
|
|
with type string := String.t) =
|
2017-05-28 00:29:12 +00:00
|
|
|
struct
|
|
|
|
include Ast
|
|
|
|
|
|
|
|
let rec t sexp =
|
|
|
|
let path = Path.t and string = String.t in
|
2017-05-27 23:48:48 +00:00
|
|
|
sum
|
2017-05-30 16:35:49 +00:00
|
|
|
[ cstr_rest "run" (Program.t @> nil) string (fun prog args -> Run (prog, args))
|
2017-05-28 00:29:12 +00:00
|
|
|
; cstr "chdir" (path @> t @> nil) (fun dn t -> Chdir (dn, t))
|
|
|
|
; cstr "setenv" (string @> string @> t @> nil) (fun k v t -> Setenv (k, v, t))
|
|
|
|
; cstr "with-stdout-to" (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t))
|
|
|
|
; cstr "with-stderr-to" (path @> t @> nil) (fun fn t -> Redirect (Stderr, fn, t))
|
|
|
|
; cstr "with-outputs-to" (path @> t @> nil) (fun fn t -> Redirect (Outputs, fn, t))
|
|
|
|
; cstr "ignore-stdout" (t @> nil) (fun t -> Ignore (Stdout, t))
|
|
|
|
; cstr "ignore-stderr" (t @> nil) (fun t -> Ignore (Stderr, t))
|
|
|
|
; cstr "ignore-outputs" (t @> nil) (fun t -> Ignore (Outputs, t))
|
|
|
|
; cstr_rest "progn" nil t (fun l -> Progn l)
|
|
|
|
; cstr "echo" (string @> nil) (fun x -> Echo x)
|
|
|
|
; cstr "cat" (path @> nil) (fun x -> Cat x)
|
|
|
|
; cstr "create-file" (path @> nil) (fun x -> Create_file x)
|
|
|
|
; cstr "copy" (path @> path @> nil) (fun src dst -> Copy (src, dst))
|
2017-03-03 09:18:03 +00:00
|
|
|
(*
|
2017-05-27 23:48:48 +00:00
|
|
|
(* We don't expose symlink to the user yet since this might complicate things *)
|
|
|
|
; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
|
|
|
|
*)
|
2017-06-05 11:10:39 +00:00
|
|
|
; cstr "copy#" (path @> path @> nil) (fun src dst ->
|
|
|
|
Copy_and_add_line_directive (src, dst))
|
|
|
|
; cstr_loc "copy-and-add-line-directive" (path @> path @> nil) (fun loc src dst ->
|
|
|
|
Loc.warn loc "copy-and-add-line-directive is deprecated, use copy# instead";
|
2017-05-27 23:48:48 +00:00
|
|
|
Copy_and_add_line_directive (src, dst))
|
2017-05-28 00:29:12 +00:00
|
|
|
; cstr "system" (string @> nil) (fun cmd -> System cmd)
|
|
|
|
; cstr "bash" (string @> nil) (fun cmd -> Bash cmd)
|
2017-05-27 23:48:48 +00:00
|
|
|
]
|
|
|
|
sexp
|
|
|
|
|
2017-05-28 00:29:12 +00:00
|
|
|
let rec sexp_of_t : _ -> Sexp.t =
|
|
|
|
let path = Path.sexp_of_t and string = String.sexp_of_t in
|
|
|
|
function
|
2017-05-30 16:35:49 +00:00
|
|
|
| Run (a, xs) -> List (Atom "run" :: Program.sexp_of_t a :: List.map xs ~f:string)
|
2017-05-28 00:29:12 +00:00
|
|
|
| Chdir (a, r) -> List [Atom "chdir" ; path a ; sexp_of_t r]
|
|
|
|
| Setenv (k, v, r) -> List [Atom "setenv" ; string k ; string v ; sexp_of_t r]
|
2017-05-27 23:48:48 +00:00
|
|
|
| Redirect (outputs, fn, r) ->
|
2017-05-28 00:29:12 +00:00
|
|
|
List [ Atom (sprintf "with-%s-to" (Outputs.to_string outputs))
|
|
|
|
; path fn
|
|
|
|
; sexp_of_t r
|
2017-05-27 23:48:48 +00:00
|
|
|
]
|
|
|
|
| Ignore (outputs, r) ->
|
2017-05-28 00:29:12 +00:00
|
|
|
List [ Atom (sprintf "ignore-%s" (Outputs.to_string outputs))
|
|
|
|
; sexp_of_t r
|
2017-05-27 23:48:48 +00:00
|
|
|
]
|
2017-05-28 00:29:12 +00:00
|
|
|
| Progn l -> List (Atom "progn" :: List.map l ~f:sexp_of_t)
|
|
|
|
| Echo x -> List [Atom "echo"; string x]
|
|
|
|
| Cat x -> List [Atom "cat"; path x]
|
|
|
|
| Create_file x -> List [Atom "create-file"; path x]
|
2017-05-27 23:48:48 +00:00
|
|
|
| Copy (x, y) ->
|
2017-05-28 00:29:12 +00:00
|
|
|
List [Atom "copy"; path x; path y]
|
2017-05-27 23:48:48 +00:00
|
|
|
| Symlink (x, y) ->
|
2017-05-28 00:29:12 +00:00
|
|
|
List [Atom "symlink"; path x; path y]
|
2017-05-27 23:48:48 +00:00
|
|
|
| Copy_and_add_line_directive (x, y) ->
|
2017-06-05 11:10:39 +00:00
|
|
|
List [Atom "copy#"; path x; path y]
|
2017-05-28 00:29:12 +00:00
|
|
|
| System x -> List [Atom "system"; string x]
|
|
|
|
| Bash x -> List [Atom "bash"; string x]
|
|
|
|
| Update_file (x, y) -> List [Atom "update-file"; path x; string y]
|
|
|
|
| Rename (x, y) -> List [Atom "rename"; path x; path y]
|
|
|
|
| Remove_tree x -> List [Atom "remove-tree"; path x]
|
2017-05-29 13:51:46 +00:00
|
|
|
| Mkdir x -> List [Atom "mkdir"; path x]
|
2017-05-28 00:29:12 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
module type Ast = Action_intf.Ast
|
2017-05-31 07:31:52 +00:00
|
|
|
with type program = Program.t
|
|
|
|
with type path = Path.t
|
|
|
|
with type string = String.t
|
2017-05-28 00:29:12 +00:00
|
|
|
module rec Ast : Ast = Ast
|
|
|
|
|
|
|
|
include Make_ast
|
2017-05-30 16:35:49 +00:00
|
|
|
(Program)
|
2017-05-28 00:29:12 +00:00
|
|
|
(Path)
|
|
|
|
(struct
|
|
|
|
type t = string
|
|
|
|
let t = Sexp.Of_sexp.string
|
|
|
|
let sexp_of_t = Sexp.To_sexp.string
|
|
|
|
end)
|
|
|
|
(Ast)
|
|
|
|
|
|
|
|
module Unexpanded = struct
|
2017-05-31 07:31:52 +00:00
|
|
|
module type Uast = Action_intf.Ast
|
|
|
|
with type program = String_with_vars.t
|
|
|
|
with type path = String_with_vars.t
|
|
|
|
with type string = String_with_vars.t
|
|
|
|
module rec Uast : Uast = Uast
|
2017-05-28 00:29:12 +00:00
|
|
|
|
2017-05-31 07:31:52 +00:00
|
|
|
include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Uast)
|
2017-05-28 00:29:12 +00:00
|
|
|
|
|
|
|
let t sexp =
|
|
|
|
match sexp with
|
|
|
|
| Atom _ ->
|
|
|
|
of_sexp_errorf sexp
|
|
|
|
"if you meant for this to be executed with bash, write (bash \"...\") instead"
|
|
|
|
| List _ -> t sexp
|
2017-05-27 23:48:48 +00:00
|
|
|
|
2017-05-31 15:49:54 +00:00
|
|
|
let check_mkdir loc path =
|
|
|
|
if not (Path.is_local path) then
|
|
|
|
Loc.fail loc
|
|
|
|
"(mkdir ...) is not supported for paths outside of the workspace:\n\
|
|
|
|
\ %a\n"
|
|
|
|
Sexp.pp (List [Atom "mkdir"; Path.sexp_of_t path])
|
|
|
|
|
2017-05-31 07:31:52 +00:00
|
|
|
module Partial = struct
|
|
|
|
module type Past = Action_intf.Ast
|
|
|
|
with type program = (Program.t, String_with_vars.t) either
|
|
|
|
with type path = (Path.t , String_with_vars.t) either
|
|
|
|
with type string = (string , String_with_vars.t) either
|
|
|
|
module rec Past : Past = Past
|
|
|
|
|
|
|
|
include Past
|
|
|
|
|
|
|
|
module E = struct
|
|
|
|
let string ~dir ~f = function
|
|
|
|
| Inl x -> x
|
|
|
|
| Inr template ->
|
|
|
|
SW.expand template ~f:(fun loc var ->
|
|
|
|
match f loc var with
|
|
|
|
| None -> None
|
|
|
|
| Some e -> Some (VE.to_string ~dir e))
|
|
|
|
|
|
|
|
let expand ~generic ~special ~map ~dir ~f = function
|
|
|
|
| Inl x -> map x
|
|
|
|
| Inr template as x ->
|
|
|
|
match SW.just_a_var template with
|
|
|
|
| None -> generic ~dir (string ~dir ~f x)
|
|
|
|
| Some var ->
|
|
|
|
match f (SW.loc template) var with
|
|
|
|
| None -> generic ~dir (SW.to_string template)
|
|
|
|
| Some e -> special ~dir e
|
|
|
|
[@@inlined always]
|
|
|
|
|
|
|
|
let strings ~dir ~f x =
|
|
|
|
expand ~dir ~f x
|
|
|
|
~generic:(fun ~dir:_ x -> [x])
|
|
|
|
~special:VE.to_strings
|
|
|
|
~map:(fun x -> [x])
|
|
|
|
|
|
|
|
let path ~dir ~f x =
|
|
|
|
expand ~dir ~f x
|
|
|
|
~generic:VE.path_of_string
|
|
|
|
~special:VE.to_path
|
|
|
|
~map:(fun x -> x)
|
|
|
|
|
|
|
|
let prog_and_args ctx ~dir ~f x =
|
|
|
|
expand ~dir ~f x
|
|
|
|
~generic:(fun ~dir:_ s -> (Program.resolve ctx ~dir s, []))
|
|
|
|
~special:(VE.to_prog_and_args ctx)
|
|
|
|
~map:(fun x -> (x, []))
|
|
|
|
end
|
|
|
|
|
|
|
|
let rec expand ctx dir t ~f : Ast.t =
|
|
|
|
match t with
|
|
|
|
| Run (prog, args) ->
|
|
|
|
let args = List.concat_map args ~f:(E.strings ~dir ~f) in
|
|
|
|
let prog, more_args = E.prog_and_args ctx ~dir ~f prog in
|
|
|
|
Run (prog, more_args @ args)
|
|
|
|
| Chdir (fn, t) ->
|
|
|
|
let fn = E.path ~dir ~f fn in
|
|
|
|
Chdir (fn, expand ctx fn t ~f)
|
|
|
|
| Setenv (var, value, t) ->
|
|
|
|
Setenv (E.string ~dir ~f var, E.string ~dir ~f value,
|
|
|
|
expand ctx dir t ~f)
|
|
|
|
| Redirect (outputs, fn, t) ->
|
|
|
|
Redirect (outputs, E.path ~dir ~f fn, expand ctx dir t ~f)
|
|
|
|
| Ignore (outputs, t) ->
|
|
|
|
Ignore (outputs, expand ctx dir t ~f)
|
|
|
|
| Progn l -> Progn (List.map l ~f:(fun t -> expand ctx dir t ~f))
|
|
|
|
| Echo x -> Echo (E.string ~dir ~f x)
|
|
|
|
| Cat x -> Cat (E.path ~dir ~f x)
|
|
|
|
| Create_file x -> Create_file (E.path ~dir ~f x)
|
|
|
|
| Copy (x, y) ->
|
|
|
|
Copy (E.path ~dir ~f x, E.path ~dir ~f y)
|
|
|
|
| Symlink (x, y) ->
|
|
|
|
Symlink (E.path ~dir ~f x, E.path ~dir ~f y)
|
|
|
|
| Copy_and_add_line_directive (x, y) ->
|
|
|
|
Copy_and_add_line_directive (E.path ~dir ~f x, E.path ~dir ~f y)
|
|
|
|
| System x -> System (E.string ~dir ~f x)
|
|
|
|
| Bash x -> Bash (E.string ~dir ~f x)
|
|
|
|
| Update_file (x, y) -> Update_file (E.path ~dir ~f x, E.string ~dir ~f y)
|
|
|
|
| Rename (x, y) ->
|
|
|
|
Rename (E.path ~dir ~f x, E.path ~dir ~f y)
|
|
|
|
| Remove_tree x ->
|
|
|
|
Remove_tree (E.path ~dir ~f x)
|
|
|
|
| Mkdir x ->
|
2017-05-31 15:49:54 +00:00
|
|
|
match x with
|
|
|
|
| Inl path -> Mkdir path
|
|
|
|
| Inr tmpl ->
|
|
|
|
let path = E.path ~dir ~f x in
|
|
|
|
check_mkdir (SW.loc tmpl) path;
|
|
|
|
Mkdir path
|
2017-05-31 07:31:52 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
module E = struct
|
|
|
|
let string ~dir ~f template =
|
|
|
|
SW.partial_expand template ~f:(fun loc var ->
|
|
|
|
match f loc var with
|
|
|
|
| None -> None
|
|
|
|
| Some e -> Some (VE.to_string ~dir e))
|
|
|
|
|
|
|
|
let expand ~generic ~special ~dir ~f template =
|
|
|
|
match SW.just_a_var template with
|
|
|
|
| None -> begin
|
|
|
|
match string ~dir ~f template with
|
|
|
|
| Inl x -> Inl (generic ~dir x)
|
|
|
|
| Inr _ as x -> x
|
|
|
|
end
|
|
|
|
| Some var ->
|
|
|
|
match f (SW.loc template) var with
|
|
|
|
| None -> Inr template
|
|
|
|
| Some e -> Inl (special ~dir e)
|
|
|
|
|
|
|
|
let strings ~dir ~f x =
|
|
|
|
expand ~dir ~f x
|
|
|
|
~generic:(fun ~dir:_ x -> [x])
|
|
|
|
~special:VE.to_strings
|
|
|
|
|
|
|
|
let path ~dir ~f x =
|
|
|
|
expand ~dir ~f x
|
|
|
|
~generic:VE.path_of_string
|
|
|
|
~special:VE.to_path
|
|
|
|
|
|
|
|
let prog_and_args ctx ~dir ~f x =
|
|
|
|
expand ~dir ~f x
|
|
|
|
~generic:(fun ~dir s -> (Program.resolve ctx ~dir s, []))
|
|
|
|
~special:(VE.to_prog_and_args ctx)
|
|
|
|
|
|
|
|
let simple x =
|
|
|
|
match SW.just_text x with
|
|
|
|
| Some s -> Inl s
|
|
|
|
| None -> Inr x
|
|
|
|
end
|
|
|
|
|
|
|
|
(* Like [partial_expand] except we keep everything as a template. This is for when we
|
|
|
|
can't determine a chdir statically *)
|
|
|
|
let rec simple_expand t ~f : Partial.t =
|
2017-03-03 11:49:40 +00:00
|
|
|
match t with
|
|
|
|
| Run (prog, args) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
SW.iter prog ~f;
|
|
|
|
List.iter args ~f:(SW.iter ~f);
|
|
|
|
Run (Inr prog, List.map args ~f:E.simple)
|
2017-05-27 23:48:48 +00:00
|
|
|
| Chdir (fn, t) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
SW.iter fn ~f;
|
|
|
|
Chdir (Inr fn, simple_expand t ~f)
|
2017-03-03 11:49:40 +00:00
|
|
|
| Setenv (var, value, t) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
SW.iter var ~f;
|
|
|
|
SW.iter value ~f;
|
|
|
|
Setenv (E.simple var, E.simple value, simple_expand t ~f)
|
2017-03-13 08:10:33 +00:00
|
|
|
| Redirect (outputs, fn, t) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
SW.iter fn ~f;
|
|
|
|
Redirect (outputs, Inr fn, simple_expand t ~f)
|
2017-03-13 08:10:33 +00:00
|
|
|
| Ignore (outputs, t) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
Ignore (outputs, simple_expand t ~f)
|
|
|
|
| Progn l -> Progn (List.map l ~f:(simple_expand ~f))
|
|
|
|
| Echo x -> SW.iter x ~f; Echo (E.simple x)
|
|
|
|
| Cat x -> SW.iter x ~f; Cat (Inr x)
|
|
|
|
| Create_file x -> SW.iter x ~f; Create_file (Inr x)
|
2017-05-27 23:48:48 +00:00
|
|
|
| Copy (x, y) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
SW.iter x ~f;
|
|
|
|
SW.iter y ~f;
|
|
|
|
Copy (Inr x, Inr y)
|
|
|
|
| Copy_and_add_line_directive (x, y) ->
|
|
|
|
SW.iter x ~f;
|
|
|
|
SW.iter y ~f;
|
|
|
|
Copy_and_add_line_directive (Inr x, Inr y)
|
2017-05-27 23:48:48 +00:00
|
|
|
| Symlink (x, y) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
SW.iter x ~f;
|
|
|
|
SW.iter y ~f;
|
|
|
|
Symlink (Inr x, Inr y)
|
|
|
|
| Rename (x, y) ->
|
|
|
|
SW.iter x ~f;
|
|
|
|
SW.iter y ~f;
|
|
|
|
Rename (Inr x, Inr y)
|
|
|
|
| System x -> SW.iter x ~f; System (E.simple x)
|
|
|
|
| Bash x -> SW.iter x ~f; Bash (E.simple x)
|
|
|
|
| Update_file (x, y) ->
|
|
|
|
SW.iter x ~f;
|
|
|
|
SW.iter y ~f;
|
|
|
|
Update_file (Inr x, E.simple y)
|
|
|
|
| Remove_tree x -> SW.iter x ~f; Remove_tree (Inr x)
|
|
|
|
| Mkdir x -> SW.iter x ~f; Mkdir (Inr x)
|
|
|
|
|
|
|
|
let rec partial_expand ctx dir t ~f : Partial.t =
|
|
|
|
match t with
|
|
|
|
| Run (prog, args) ->
|
|
|
|
let args =
|
|
|
|
List.concat_map args ~f:(fun arg ->
|
|
|
|
match E.strings ~dir ~f arg with
|
|
|
|
| Inl args -> List.map args ~f:(fun x -> Inl x)
|
|
|
|
| Inr _ as x -> [x])
|
|
|
|
in
|
|
|
|
begin
|
|
|
|
match E.prog_and_args ctx ~dir ~f prog with
|
|
|
|
| Inl (prog, more_args) ->
|
|
|
|
let more_args = List.map more_args ~f:(fun x -> Inl x) in
|
|
|
|
Run (Inl prog, more_args @ args)
|
|
|
|
| Inr _ as prog ->
|
|
|
|
Run (prog, args)
|
|
|
|
end
|
|
|
|
| Chdir (fn, t) -> begin
|
|
|
|
let res = E.path ~dir ~f fn in
|
|
|
|
match res with
|
|
|
|
| Inl dir ->
|
|
|
|
Chdir (res, partial_expand ctx dir t ~f)
|
|
|
|
| Inr _ ->
|
|
|
|
let f loc x = ignore (f loc x : _ option) in
|
|
|
|
Chdir (res, simple_expand t ~f)
|
|
|
|
end
|
|
|
|
| Setenv (var, value, t) ->
|
|
|
|
Setenv (E.string ~dir ~f var, E.string ~dir ~f value,
|
|
|
|
partial_expand ctx dir t ~f)
|
|
|
|
| Redirect (outputs, fn, t) ->
|
|
|
|
Redirect (outputs, E.path ~dir ~f fn, partial_expand ctx dir t ~f)
|
|
|
|
| Ignore (outputs, t) ->
|
|
|
|
Ignore (outputs, partial_expand ctx dir t ~f)
|
|
|
|
| Progn l -> Progn (List.map l ~f:(fun t -> partial_expand ctx dir t ~f))
|
|
|
|
| Echo x -> Echo (E.string ~dir ~f x)
|
|
|
|
| Cat x -> Cat (E.path ~dir ~f x)
|
|
|
|
| Create_file x -> Create_file (E.path ~dir ~f x)
|
|
|
|
| Copy (x, y) ->
|
|
|
|
Copy (E.path ~dir ~f x, E.path ~dir ~f y)
|
|
|
|
| Symlink (x, y) ->
|
|
|
|
Symlink (E.path ~dir ~f x, E.path ~dir ~f y)
|
2017-05-27 23:48:48 +00:00
|
|
|
| Copy_and_add_line_directive (x, y) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
Copy_and_add_line_directive (E.path ~dir ~f x, E.path ~dir ~f y)
|
|
|
|
| System x -> System (E.string ~dir ~f x)
|
|
|
|
| Bash x -> Bash (E.string ~dir ~f x)
|
|
|
|
| Update_file (x, y) -> Update_file (E.path ~dir ~f x, E.string ~dir ~f y)
|
2017-05-27 23:48:48 +00:00
|
|
|
| Rename (x, y) ->
|
2017-05-31 07:31:52 +00:00
|
|
|
Rename (E.path ~dir ~f x, E.path ~dir ~f y)
|
2017-05-27 23:48:48 +00:00
|
|
|
| Remove_tree x ->
|
2017-05-31 07:31:52 +00:00
|
|
|
Remove_tree (E.path ~dir ~f x)
|
2017-05-29 13:51:46 +00:00
|
|
|
| Mkdir x ->
|
2017-05-31 15:49:54 +00:00
|
|
|
let res = E.path ~dir ~f x in
|
|
|
|
(match res with
|
|
|
|
| Inl path -> check_mkdir (SW.loc x) path
|
|
|
|
| Inr _ -> ());
|
|
|
|
Mkdir res
|
2017-05-27 23:48:48 +00:00
|
|
|
end
|
2017-03-03 11:49:40 +00:00
|
|
|
|
2017-05-28 00:29:12 +00:00
|
|
|
let fold_one_step t ~init:acc ~f =
|
|
|
|
match t with
|
|
|
|
| Chdir (_, t)
|
|
|
|
| Setenv (_, _, t)
|
|
|
|
| Redirect (_, _, t)
|
|
|
|
| Ignore (_, t) -> f acc t
|
|
|
|
| Progn l -> List.fold_left l ~init:acc ~f
|
|
|
|
| Run _
|
|
|
|
| Echo _
|
|
|
|
| Cat _
|
|
|
|
| Create_file _
|
|
|
|
| Copy _
|
|
|
|
| Symlink _
|
|
|
|
| Copy_and_add_line_directive _
|
|
|
|
| System _
|
|
|
|
| Bash _
|
|
|
|
| Update_file _
|
|
|
|
| Rename _
|
2017-05-29 13:51:46 +00:00
|
|
|
| Remove_tree _
|
|
|
|
| Mkdir _ -> acc
|
2017-05-28 00:29:12 +00:00
|
|
|
|
|
|
|
let rec map t ~fs ~fp =
|
2017-06-08 08:59:43 +00:00
|
|
|
match t with
|
|
|
|
| Run (This prog, args) ->
|
|
|
|
Run (This (fp prog), List.map args ~f:fs)
|
|
|
|
| Run (Not_found _ as nf, args) ->
|
|
|
|
Run (nf, List.map args ~f:fs)
|
|
|
|
| Chdir (fn, t) ->
|
|
|
|
Chdir (fp fn, map t ~fs ~fp)
|
|
|
|
| Setenv (var, value, t) ->
|
|
|
|
Setenv (fs var, fs value, map t ~fs ~fp)
|
|
|
|
| Redirect (outputs, fn, t) ->
|
|
|
|
Redirect (outputs, fp fn, map t ~fs ~fp)
|
|
|
|
| Ignore (outputs, t) ->
|
|
|
|
Ignore (outputs, map t ~fs ~fp)
|
|
|
|
| Progn l -> Progn (List.map l ~f:(fun t -> map t ~fs ~fp))
|
|
|
|
| Echo x -> Echo (fs x)
|
|
|
|
| Cat x -> Cat (fp x)
|
|
|
|
| Create_file x -> Create_file (fp x)
|
|
|
|
| Copy (x, y) -> Copy (fp x, fp y)
|
|
|
|
| Symlink (x, y) ->
|
|
|
|
Symlink (fp x, fp y)
|
|
|
|
| Copy_and_add_line_directive (x, y) ->
|
|
|
|
Copy_and_add_line_directive (fp x, fp y)
|
|
|
|
| System x -> System (fs x)
|
|
|
|
| Bash x -> Bash (fs x)
|
|
|
|
| Update_file (x, y) -> Update_file (fp x, fs y)
|
|
|
|
| Rename (x, y) -> Rename (fp x, fp y)
|
|
|
|
| Remove_tree x -> Remove_tree (fp x)
|
|
|
|
| Mkdir x -> Mkdir (fp x)
|
2017-05-28 00:29:12 +00:00
|
|
|
|
|
|
|
let updated_files =
|
|
|
|
let rec loop acc t =
|
|
|
|
let acc =
|
|
|
|
match t with
|
|
|
|
| Update_file (fn, _) -> Path.Set.add fn acc
|
|
|
|
| _ -> acc
|
|
|
|
in
|
|
|
|
fold_one_step t ~init:acc ~f:loop
|
|
|
|
in
|
|
|
|
fun t -> loop Path.Set.empty t
|
|
|
|
|
|
|
|
let chdirs =
|
|
|
|
let rec loop acc t =
|
|
|
|
let acc =
|
|
|
|
match t with
|
|
|
|
| Chdir (dir, _) -> Path.Set.add dir acc
|
|
|
|
| _ -> acc
|
|
|
|
in
|
|
|
|
fold_one_step t ~init:acc ~f:loop
|
|
|
|
in
|
|
|
|
fun t -> loop Path.Set.empty t
|
|
|
|
|
2017-05-27 23:48:48 +00:00
|
|
|
open Future
|
|
|
|
|
|
|
|
let get_std_output : _ -> Future.std_output_to = function
|
|
|
|
| None -> Terminal
|
|
|
|
| Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc }
|
|
|
|
|
2017-05-30 16:35:49 +00:00
|
|
|
type exec_context =
|
|
|
|
{ context : Context.t option
|
|
|
|
; purpose : Future.purpose
|
|
|
|
; env : string array
|
|
|
|
}
|
|
|
|
|
|
|
|
let run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
|
2017-05-27 23:48:48 +00:00
|
|
|
let stdout_to = get_std_output stdout_to in
|
|
|
|
let stderr_to = get_std_output stderr_to in
|
2017-05-30 16:35:49 +00:00
|
|
|
let env = Context.extend_env ~vars:env_extra ~env:ectx.env in
|
|
|
|
Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to ~stderr_to
|
|
|
|
~purpose:ectx.purpose
|
2017-05-27 23:48:48 +00:00
|
|
|
(Path.reach_for_running ~from:dir prog) args
|
|
|
|
|
2017-05-30 16:35:49 +00:00
|
|
|
let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
|
2017-05-27 23:48:48 +00:00
|
|
|
match t with
|
2017-05-30 16:35:49 +00:00
|
|
|
| Run (This prog, args) ->
|
|
|
|
run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args
|
|
|
|
| Run (Not_found prog, _) ->
|
|
|
|
Utils.program_not_found prog ?context:(Option.map ectx.context ~f:(fun c -> c.name))
|
2017-05-27 23:48:48 +00:00
|
|
|
| Chdir (dir, t) ->
|
2017-05-30 16:35:49 +00:00
|
|
|
exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
| Setenv (var, value, t) ->
|
2017-05-30 16:35:49 +00:00
|
|
|
exec t ~ectx ~dir ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
~env_extra:(Env_var_map.add env_extra ~key:var ~data:value)
|
|
|
|
| Redirect (outputs, fn, t) ->
|
2017-05-30 16:35:49 +00:00
|
|
|
redirect ~ectx ~dir outputs fn t ~env_extra ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
| Ignore (outputs, t) ->
|
2017-05-30 16:35:49 +00:00
|
|
|
redirect ~ectx ~dir outputs Config.dev_null t ~env_extra ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
| Progn l ->
|
2017-05-30 16:35:49 +00:00
|
|
|
exec_list l ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
| Echo str ->
|
|
|
|
return
|
|
|
|
(match stdout_to with
|
|
|
|
| None -> print_string str; flush stdout
|
|
|
|
| Some (_, oc) -> output_string oc str)
|
|
|
|
| Cat fn ->
|
|
|
|
Io.with_file_in (Path.to_string fn) ~f:(fun ic ->
|
|
|
|
let oc =
|
|
|
|
match stdout_to with
|
|
|
|
| None -> stdout
|
|
|
|
| Some (_, oc) -> oc
|
|
|
|
in
|
|
|
|
Io.copy_channels ic oc);
|
|
|
|
return ()
|
|
|
|
| Create_file fn ->
|
2017-03-13 08:10:33 +00:00
|
|
|
let fn = Path.to_string fn in
|
2017-05-27 23:48:48 +00:00
|
|
|
if Sys.file_exists fn then Sys.remove fn;
|
|
|
|
Unix.close (Unix.openfile fn [O_CREAT; O_TRUNC; O_WRONLY] 0o666);
|
|
|
|
return ()
|
|
|
|
| Copy (src, dst) ->
|
|
|
|
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst);
|
|
|
|
return ()
|
|
|
|
| Symlink (src, dst) ->
|
|
|
|
if Sys.win32 then
|
|
|
|
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)
|
|
|
|
else begin
|
|
|
|
let src =
|
|
|
|
if Path.is_root dst then
|
|
|
|
Path.to_string src
|
|
|
|
else
|
|
|
|
Path.reach ~from:(Path.parent dst) src
|
|
|
|
in
|
|
|
|
let dst = Path.to_string dst in
|
|
|
|
match Unix.readlink dst with
|
|
|
|
| target ->
|
|
|
|
if target <> src then begin
|
|
|
|
Unix.unlink dst;
|
|
|
|
Unix.symlink src dst
|
|
|
|
end
|
|
|
|
| exception _ ->
|
|
|
|
Unix.symlink src dst
|
|
|
|
end;
|
|
|
|
return ()
|
|
|
|
| Copy_and_add_line_directive (src, dst) ->
|
|
|
|
Io.with_file_in (Path.to_string src) ~f:(fun ic ->
|
|
|
|
Io.with_file_out (Path.to_string dst) ~f:(fun oc ->
|
|
|
|
let fn = Path.drop_build_context src in
|
|
|
|
Printf.fprintf oc "# 1 %S\n" (Path.to_string fn);
|
|
|
|
Io.copy_channels ic oc));
|
|
|
|
return ()
|
|
|
|
| System cmd ->
|
|
|
|
let path, arg =
|
|
|
|
Utils.system_shell_exn ~needed_to:"interpret (system ...) actions"
|
2017-03-13 08:10:33 +00:00
|
|
|
in
|
2017-05-30 16:35:49 +00:00
|
|
|
run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to path [arg; cmd]
|
2017-05-27 23:48:48 +00:00
|
|
|
| Bash cmd ->
|
2017-05-30 16:35:49 +00:00
|
|
|
run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
(Utils.bash_exn ~needed_to:"interpret (bash ...) actions")
|
|
|
|
["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
|
|
|
| Update_file (fn, s) ->
|
|
|
|
let fn = Path.to_string fn in
|
|
|
|
if Sys.file_exists fn && Io.read_file fn = s then
|
|
|
|
()
|
|
|
|
else
|
|
|
|
Io.write_file fn s;
|
|
|
|
return ()
|
|
|
|
| Rename (src, dst) ->
|
|
|
|
Unix.rename (Path.to_string src) (Path.to_string dst);
|
|
|
|
return ()
|
|
|
|
| Remove_tree path ->
|
|
|
|
Path.rm_rf path;
|
|
|
|
return ()
|
2017-05-29 13:51:46 +00:00
|
|
|
| Mkdir path ->
|
|
|
|
(match Path.kind path with
|
|
|
|
| External _ ->
|
2017-05-31 15:49:54 +00:00
|
|
|
(* Internally we make sure never to do that, and [Unexpanded.*expand] check that *)
|
|
|
|
Sexp.code_error
|
|
|
|
"(mkdir ...) is not supported for paths outside of the workspace"
|
|
|
|
[ "mkdir", Path.sexp_of_t path ]
|
2017-05-29 13:51:46 +00:00
|
|
|
| Local path ->
|
|
|
|
Path.Local.mkdir_p path);
|
|
|
|
return ()
|
2017-05-27 23:48:48 +00:00
|
|
|
|
2017-05-30 16:35:49 +00:00
|
|
|
and redirect outputs fn t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
|
2017-05-27 23:48:48 +00:00
|
|
|
let fn = Path.to_string fn in
|
|
|
|
let oc = Io.open_out fn in
|
|
|
|
let out = Some (fn, oc) in
|
|
|
|
let stdout_to, stderr_to =
|
|
|
|
match outputs with
|
|
|
|
| Stdout -> (out, stderr_to)
|
|
|
|
| Stderr -> (stdout_to, out)
|
|
|
|
| Outputs -> (out, out)
|
2017-03-03 11:49:40 +00:00
|
|
|
in
|
2017-05-30 16:35:49 +00:00
|
|
|
exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to >>| fun () ->
|
2017-05-27 23:48:48 +00:00
|
|
|
close_out oc
|
|
|
|
|
2017-05-30 16:35:49 +00:00
|
|
|
and exec_list l ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
|
2017-05-27 23:48:48 +00:00
|
|
|
match l with
|
|
|
|
| [] ->
|
|
|
|
Future.return ()
|
|
|
|
| [t] ->
|
2017-05-30 16:35:49 +00:00
|
|
|
exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
| t :: rest ->
|
2017-05-30 16:35:49 +00:00
|
|
|
exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to >>= fun () ->
|
|
|
|
exec_list rest ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
|
2017-05-27 23:48:48 +00:00
|
|
|
|
|
|
|
let exec ~targets ?context t =
|
2017-03-03 11:49:40 +00:00
|
|
|
let env =
|
2017-05-27 23:48:48 +00:00
|
|
|
match (context : Context.t option) with
|
2017-03-03 11:49:40 +00:00
|
|
|
| None -> Lazy.force Context.initial_env
|
|
|
|
| Some c -> c.env
|
|
|
|
in
|
2017-03-30 16:36:58 +00:00
|
|
|
let targets = Path.Set.elements targets in
|
|
|
|
let purpose = Future.Build_job targets in
|
2017-05-30 16:35:49 +00:00
|
|
|
let ectx = { purpose; context; env } in
|
|
|
|
exec t ~ectx ~dir:Path.root ~env_extra:Env_var_map.empty
|
2017-03-13 08:10:33 +00:00
|
|
|
~stdout_to:None ~stderr_to:None
|
2017-03-03 15:26:14 +00:00
|
|
|
|
2017-03-31 14:06:53 +00:00
|
|
|
let sandbox t ~sandboxed ~deps ~targets =
|
2017-05-28 00:29:12 +00:00
|
|
|
Progn
|
|
|
|
[ Progn (List.filter_map deps ~f:(fun path ->
|
2017-05-27 23:48:48 +00:00
|
|
|
if Path.is_local path then
|
|
|
|
Some (Ast.Symlink (path, sandboxed path))
|
|
|
|
else
|
|
|
|
None))
|
2017-05-28 00:29:12 +00:00
|
|
|
; map t ~fs:(fun x -> x) ~fp:sandboxed
|
|
|
|
; Progn (List.filter_map targets ~f:(fun path ->
|
2017-05-27 23:48:48 +00:00
|
|
|
if Path.is_local path then
|
|
|
|
Some (Ast.Rename (sandboxed path, path))
|
|
|
|
else
|
|
|
|
None))
|
|
|
|
]
|
2017-05-28 01:46:07 +00:00
|
|
|
|
|
|
|
module Infer = struct
|
|
|
|
module S = Path.Set
|
|
|
|
module Outcome = struct
|
|
|
|
type t =
|
|
|
|
{ deps : S.t
|
|
|
|
; targets : S.t
|
|
|
|
}
|
|
|
|
end
|
|
|
|
open Outcome
|
|
|
|
|
|
|
|
let ( +@ ) acc fn = { acc with targets = S.add fn acc.targets }
|
2017-05-30 16:39:23 +00:00
|
|
|
let ( +< ) acc fn = { acc with deps = S.add fn acc.deps }
|
2017-05-28 01:46:07 +00:00
|
|
|
|
|
|
|
let rec infer acc t =
|
|
|
|
match t with
|
2017-05-30 16:35:49 +00:00
|
|
|
| Run (This prog, _) -> acc +< prog
|
|
|
|
| Run (Not_found _, _) -> acc
|
|
|
|
| Redirect (_, fn, t) -> infer (acc +@ fn) t
|
|
|
|
| Cat fn -> acc +< fn
|
|
|
|
| Create_file fn -> acc +@ fn
|
|
|
|
| Update_file (fn, _) -> acc +@ fn
|
2017-05-30 16:39:23 +00:00
|
|
|
| Rename (src, dst) -> acc +< src +@ dst
|
2017-05-28 01:46:07 +00:00
|
|
|
| Copy (src, dst)
|
|
|
|
| Copy_and_add_line_directive (src, dst)
|
|
|
|
| Symlink (src, dst) -> acc +< src +@ dst
|
|
|
|
| Chdir (_, t)
|
|
|
|
| Setenv (_, _, t)
|
|
|
|
| Ignore (_, t) -> infer acc t
|
|
|
|
| Progn l -> List.fold_left l ~init:acc ~f:infer
|
|
|
|
| Echo _
|
|
|
|
| System _
|
2017-05-30 16:39:23 +00:00
|
|
|
| Bash _
|
|
|
|
| Remove_tree _
|
2017-05-29 13:51:46 +00:00
|
|
|
| Mkdir _ -> acc
|
2017-05-28 01:46:07 +00:00
|
|
|
|
|
|
|
let infer t =
|
2017-05-30 16:39:23 +00:00
|
|
|
let { deps; targets } = infer { deps = S.empty; targets = S.empty } t in
|
|
|
|
(* A file can be inferred as both a dependency and a target, for instance:
|
|
|
|
|
|
|
|
{[
|
|
|
|
(progn (copy a b) (copy b c))
|
|
|
|
]}
|
|
|
|
*)
|
|
|
|
{ deps = S.diff deps targets; targets }
|
2017-05-31 07:31:52 +00:00
|
|
|
|
|
|
|
let ( +@? ) acc fn =
|
|
|
|
match fn with
|
|
|
|
| Inl fn -> { acc with targets = S.add fn acc.targets }
|
|
|
|
| Inr _ -> acc
|
|
|
|
let ( +<? ) acc fn =
|
|
|
|
match fn with
|
|
|
|
| Inl fn -> { acc with deps = S.add fn acc.deps }
|
|
|
|
| Inr _ -> acc
|
|
|
|
|
|
|
|
let rec partial acc (t : Unexpanded.Partial.t) =
|
|
|
|
match t with
|
|
|
|
| Run (Inl (This prog), _) -> acc +< prog
|
|
|
|
| Run (_, _) -> acc
|
|
|
|
| Redirect (_, fn, t) -> partial (acc +@? fn) t
|
|
|
|
| Cat fn -> acc +<? fn
|
|
|
|
| Create_file fn -> acc +@? fn
|
|
|
|
| Update_file (fn, _) -> acc +@? fn
|
|
|
|
| Rename (src, dst) -> acc +<? src +@? dst
|
|
|
|
| Copy (src, dst)
|
|
|
|
| Copy_and_add_line_directive (src, dst)
|
|
|
|
| Symlink (src, dst) -> acc +<? src +@? dst
|
|
|
|
| Chdir (_, t)
|
|
|
|
| Setenv (_, _, t)
|
|
|
|
| Ignore (_, t) -> partial acc t
|
|
|
|
| Progn l -> List.fold_left l ~init:acc ~f:partial
|
|
|
|
| Echo _
|
|
|
|
| System _
|
|
|
|
| Bash _
|
|
|
|
| Remove_tree _
|
|
|
|
| Mkdir _ -> acc
|
|
|
|
|
|
|
|
let ( +@? ) acc fn =
|
|
|
|
match fn with
|
|
|
|
| Inl fn -> { acc with targets = S.add fn acc.targets }
|
2017-05-31 15:49:54 +00:00
|
|
|
| Inr sw -> Loc.fail (SW.loc sw) "Cannot determine this target statically."
|
2017-05-31 07:31:52 +00:00
|
|
|
|
|
|
|
let rec partial_with_all_targets acc (t : Unexpanded.Partial.t) =
|
|
|
|
match t with
|
|
|
|
| Run (Inl (This prog), _) -> acc +< prog
|
|
|
|
| Run (_, _) -> acc
|
|
|
|
| Redirect (_, fn, t) -> partial_with_all_targets (acc +@? fn) t
|
|
|
|
| Cat fn -> acc +<? fn
|
|
|
|
| Create_file fn -> acc +@? fn
|
|
|
|
| Update_file (fn, _) -> acc +@? fn
|
|
|
|
| Rename (src, dst) -> acc +<? src +@? dst
|
|
|
|
| Copy (src, dst)
|
|
|
|
| Copy_and_add_line_directive (src, dst)
|
|
|
|
| Symlink (src, dst) -> acc +<? src +@? dst
|
|
|
|
| Chdir (_, t)
|
|
|
|
| Setenv (_, _, t)
|
|
|
|
| Ignore (_, t) -> partial_with_all_targets acc t
|
|
|
|
| Progn l -> List.fold_left l ~init:acc ~f:partial_with_all_targets
|
|
|
|
| Echo _
|
|
|
|
| System _
|
|
|
|
| Bash _
|
|
|
|
| Remove_tree _
|
|
|
|
| Mkdir _ -> acc
|
|
|
|
|
|
|
|
let partial ~all_targets t =
|
|
|
|
let acc = { deps = S.empty; targets = S.empty } in
|
|
|
|
let { deps; targets } =
|
|
|
|
if all_targets then
|
|
|
|
partial_with_all_targets acc t
|
|
|
|
else
|
|
|
|
partial acc t
|
|
|
|
in
|
|
|
|
{ deps = S.diff deps targets; targets }
|
2017-05-28 01:46:07 +00:00
|
|
|
end
|