Allow ${...:...} for in (do ...) and add more checks
Check that targets written by the user are a superset of inferred targets.
This commit is contained in:
parent
81e6ebd09b
commit
373e6c2524
411
src/action.ml
411
src/action.ml
|
@ -19,6 +19,16 @@ module Program = struct
|
|||
| _ ->
|
||||
Loc.fail (Sexp.Ast.loc sexp)
|
||||
"S-expression of the form <atom> or (not_found <atom>) expected"
|
||||
|
||||
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
|
||||
end
|
||||
|
||||
module Var_expansion = struct
|
||||
|
@ -58,64 +68,29 @@ module Var_expansion = struct
|
|||
| Paths ([p], Concat) -> p
|
||||
| Paths (l, Concat) ->
|
||||
path_of_string ~dir (concat (List.map l ~f:(string_of_path ~dir)))
|
||||
end
|
||||
|
||||
module Expand = struct
|
||||
module V = Var_expansion
|
||||
module SW = String_with_vars
|
||||
|
||||
let string ~dir ~f template =
|
||||
SW.expand template ~f:(fun var ->
|
||||
match f var with
|
||||
| None -> None
|
||||
| Some e -> Some (V.to_string ~dir e))
|
||||
|
||||
let expand ~generic ~special ~dir ~f template =
|
||||
match SW.just_a_var template with
|
||||
| None -> generic ~dir (string ~dir ~f template)
|
||||
| Some var ->
|
||||
match f var with
|
||||
| None -> generic ~dir (SW.to_string template)
|
||||
| Some e -> special ~dir e
|
||||
|
||||
let strings ~dir ~f template =
|
||||
expand ~dir ~f template
|
||||
~generic:(fun ~dir:_ x -> [x])
|
||||
~special:V.to_strings
|
||||
|
||||
let path ~dir ~f template =
|
||||
expand ~dir ~f template
|
||||
~generic:V.path_of_string
|
||||
~special:V.to_path
|
||||
|
||||
let prog_and_args ctx ~dir ~f template =
|
||||
let resolve s =
|
||||
if String.contains s '/' then
|
||||
Program.This (Path.relative dir s)
|
||||
else
|
||||
match Context.which ctx s with
|
||||
| Some p -> Program.This p
|
||||
| None -> Not_found s
|
||||
in
|
||||
expand ~dir ~f template
|
||||
~generic:(fun ~dir:_ s -> (resolve s, []))
|
||||
~special:(fun ~dir exp ->
|
||||
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 s, [])
|
||||
| Paths ([], _) | Strings ([], _) -> (resolve "", [])
|
||||
| Paths ([p], _) -> (This p, [])
|
||||
| Strings ([s], _) -> (resolve ctx ~dir s, [])
|
||||
| Paths ([], _) | Strings ([], _) -> (Not_found "", [])
|
||||
| Paths (l, Concat) ->
|
||||
(Program.This
|
||||
(V.path_of_string ~dir (V.concat (List.map l ~f:(V.string_of_path ~dir)))),
|
||||
(This
|
||||
(path_of_string ~dir
|
||||
(concat (List.map l ~f:(string_of_path ~dir)))),
|
||||
[])
|
||||
| Strings (l, Concat) ->
|
||||
(resolve (V.concat l), l)
|
||||
(resolve ~dir ctx (concat l), l)
|
||||
| Paths (p :: l, Split) ->
|
||||
(This p, List.map l ~f:(V.string_of_path ~dir))
|
||||
(This p, List.map l ~f:(string_of_path ~dir))
|
||||
| Strings (s :: l, Split) ->
|
||||
(resolve s, l))
|
||||
(resolve ~dir ctx s, l)
|
||||
end
|
||||
|
||||
module VE = Var_expansion
|
||||
module SW = String_with_vars
|
||||
|
||||
module Outputs = struct
|
||||
include Action_intf.Outputs
|
||||
|
||||
|
@ -204,9 +179,9 @@ struct
|
|||
end
|
||||
|
||||
module type Ast = Action_intf.Ast
|
||||
with type program := Program.t
|
||||
with type path := Path.t
|
||||
with type string := String.t
|
||||
with type program = Program.t
|
||||
with type path = Path.t
|
||||
with type string = String.t
|
||||
module rec Ast : Ast = Ast
|
||||
|
||||
include Make_ast
|
||||
|
@ -219,16 +194,14 @@ include Make_ast
|
|||
end)
|
||||
(Ast)
|
||||
|
||||
type action = t
|
||||
|
||||
module Unexpanded = struct
|
||||
module type Ast = 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 Ast : Ast = Ast
|
||||
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
|
||||
|
||||
include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Ast)
|
||||
include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Uast)
|
||||
|
||||
let t sexp =
|
||||
match sexp with
|
||||
|
@ -237,66 +210,232 @@ module Unexpanded = struct
|
|||
"if you meant for this to be executed with bash, write (bash \"...\") instead"
|
||||
| List _ -> t sexp
|
||||
|
||||
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
|
||||
| Redirect (_, fn, t) -> fold t ~init:(f acc fn) ~f
|
||||
| Ignore (_, t) -> fold t ~init:acc ~f
|
||||
| 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
|
||||
| Create_file x -> f acc x
|
||||
| Copy (x, y) -> f (f acc x) y
|
||||
| Symlink (x, y) -> f (f acc x) y
|
||||
| Copy_and_add_line_directive (x, y) -> f (f acc x) y
|
||||
| System x -> f acc x
|
||||
| Bash x -> f acc x
|
||||
| Update_file (x, y) -> f (f acc x) y
|
||||
| Rename (x, y) -> f (f acc x) y
|
||||
| Remove_tree x
|
||||
| Mkdir x -> f acc x
|
||||
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
|
||||
|
||||
let fold_vars t ~init ~f =
|
||||
fold t ~init ~f:(fun acc pat ->
|
||||
String_with_vars.fold ~init:acc pat ~f)
|
||||
include Past
|
||||
|
||||
let rec expand ctx dir t ~f : action =
|
||||
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 prog, more_args = Expand.prog_and_args ctx ~dir ~f prog in
|
||||
Run (prog,
|
||||
more_args @ List.concat_map args ~f:(Expand.strings ~dir ~f))
|
||||
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 = Expand.path ~dir ~f fn in
|
||||
let fn = E.path ~dir ~f fn in
|
||||
Chdir (fn, expand ctx fn t ~f)
|
||||
| Setenv (var, value, t) ->
|
||||
Setenv (Expand.string ~dir ~f var, Expand.string ~dir ~f value,
|
||||
Setenv (E.string ~dir ~f var, E.string ~dir ~f value,
|
||||
expand ctx dir t ~f)
|
||||
| Redirect (outputs, fn, t) ->
|
||||
Redirect (outputs, Expand.path ~dir ~f fn, expand ctx dir t ~f)
|
||||
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 (Expand.string ~dir ~f x)
|
||||
| Cat x -> Cat (Expand.path ~dir ~f x)
|
||||
| Create_file x -> Create_file (Expand.path ~dir ~f x)
|
||||
| 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 (Expand.path ~dir ~f x, Expand.path ~dir ~f y)
|
||||
Copy (E.path ~dir ~f x, E.path ~dir ~f y)
|
||||
| Symlink (x, y) ->
|
||||
Symlink (Expand.path ~dir ~f x, Expand.path ~dir ~f y)
|
||||
Symlink (E.path ~dir ~f x, E.path ~dir ~f y)
|
||||
| Copy_and_add_line_directive (x, y) ->
|
||||
Copy_and_add_line_directive (Expand.path ~dir ~f x, Expand.path ~dir ~f y)
|
||||
| System x -> System (Expand.string ~dir ~f x)
|
||||
| Bash x -> Bash (Expand.string ~dir ~f x)
|
||||
| Update_file (x, y) -> Update_file (Expand.path ~dir ~f x, Expand.string ~dir ~f 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 (Expand.path ~dir ~f x, Expand.path ~dir ~f y)
|
||||
Rename (E.path ~dir ~f x, E.path ~dir ~f y)
|
||||
| Remove_tree x ->
|
||||
Remove_tree (Expand.path ~dir ~f x)
|
||||
Remove_tree (E.path ~dir ~f x)
|
||||
| Mkdir x ->
|
||||
Mkdir (Expand.path ~dir ~f x)
|
||||
Mkdir (E.path ~dir ~f x)
|
||||
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 =
|
||||
match t with
|
||||
| Run (prog, args) ->
|
||||
SW.iter prog ~f;
|
||||
List.iter args ~f:(SW.iter ~f);
|
||||
Run (Inr prog, List.map args ~f:E.simple)
|
||||
| Chdir (fn, t) ->
|
||||
SW.iter fn ~f;
|
||||
Chdir (Inr fn, simple_expand t ~f)
|
||||
| Setenv (var, value, t) ->
|
||||
SW.iter var ~f;
|
||||
SW.iter value ~f;
|
||||
Setenv (E.simple var, E.simple value, simple_expand t ~f)
|
||||
| Redirect (outputs, fn, t) ->
|
||||
SW.iter fn ~f;
|
||||
Redirect (outputs, Inr fn, simple_expand t ~f)
|
||||
| Ignore (outputs, t) ->
|
||||
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)
|
||||
| Copy (x, y) ->
|
||||
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)
|
||||
| Symlink (x, y) ->
|
||||
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)
|
||||
| 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 ->
|
||||
Mkdir (E.path ~dir ~f x)
|
||||
end
|
||||
|
||||
let fold_one_step t ~init:acc ~f =
|
||||
|
@ -586,4 +725,72 @@ module Infer = struct
|
|||
]}
|
||||
*)
|
||||
{ deps = S.diff deps targets; targets }
|
||||
|
||||
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 }
|
||||
| Inr _ -> die "cannot determine target"
|
||||
|
||||
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 }
|
||||
end
|
||||
|
|
|
@ -34,6 +34,49 @@ val updated_files : t -> Path.Set.t
|
|||
(** Return the list of directories the action chdirs to *)
|
||||
val chdirs : t -> Path.Set.t
|
||||
|
||||
module Unexpanded : sig
|
||||
type action = t
|
||||
|
||||
include Action_intf.Ast
|
||||
with type program := String_with_vars.t
|
||||
with type path := String_with_vars.t
|
||||
with type string := String_with_vars.t
|
||||
|
||||
val t : t Sexp.Of_sexp.t
|
||||
val sexp_of_t : t Sexp.To_sexp.t
|
||||
|
||||
module Partial : sig
|
||||
include 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
|
||||
|
||||
val expand
|
||||
: Context.t
|
||||
-> Path.t
|
||||
-> t
|
||||
-> f:(Loc.t -> String.t -> Var_expansion.t option)
|
||||
-> action
|
||||
end
|
||||
|
||||
val partial_expand
|
||||
: Context.t
|
||||
-> Path.t
|
||||
-> t
|
||||
-> f:(Loc.t -> string -> Var_expansion.t option)
|
||||
-> Partial.t
|
||||
end with type action := t
|
||||
|
||||
val exec : targets:Path.Set.t -> ?context:Context.t -> t -> unit Future.t
|
||||
|
||||
(* Return a sandboxed version of an action *)
|
||||
val sandbox
|
||||
: t
|
||||
-> sandboxed:(Path.t -> Path.t)
|
||||
-> deps:Path.t list
|
||||
-> targets:Path.t list
|
||||
-> t
|
||||
|
||||
(** Infer dependencies and targets.
|
||||
|
||||
This currently doesn't support well (rename ...) and (remove-tree ...). However these
|
||||
|
@ -48,28 +91,7 @@ module Infer : sig
|
|||
end
|
||||
|
||||
val infer : t -> Outcome.t
|
||||
|
||||
(** If [all_targets] is [true] and a target cannot be determined statically, fail *)
|
||||
val partial : all_targets:bool -> Unexpanded.Partial.t -> Outcome.t
|
||||
end
|
||||
|
||||
module Unexpanded : sig
|
||||
type action = t
|
||||
|
||||
include Action_intf.Ast
|
||||
with type program := String_with_vars.t
|
||||
with type path := String_with_vars.t
|
||||
with type string := String_with_vars.t
|
||||
|
||||
val t : t Sexp.Of_sexp.t
|
||||
val sexp_of_t : t Sexp.To_sexp.t
|
||||
val fold_vars : t -> init:'a -> f:('a -> Loc.t -> string -> 'a) -> 'a
|
||||
val expand : Context.t -> Path.t -> t -> f:(string -> Var_expansion.t option) -> action
|
||||
end with type action := t
|
||||
|
||||
val exec : targets:Path.Set.t -> ?context:Context.t -> t -> unit Future.t
|
||||
|
||||
(* Return a sandboxed version of an action *)
|
||||
val sandbox
|
||||
: t
|
||||
-> sandboxed:(Path.t -> Path.t)
|
||||
-> deps:Path.t list
|
||||
-> targets:Path.t list
|
||||
-> t
|
||||
|
|
|
@ -476,9 +476,17 @@ module Gen(P : Params) = struct
|
|||
| User rules |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let do_rule (conf : Do.t) ~dir =
|
||||
let do_rule (conf : Do.t) ~dir ~package_context =
|
||||
SC.add_rule sctx
|
||||
(SC.Do_action.run sctx conf.action ~dir)
|
||||
(Build.return []
|
||||
>>>
|
||||
SC.Action.run
|
||||
sctx
|
||||
conf.action
|
||||
~dir
|
||||
~dep_kind:Required
|
||||
~targets:Infer
|
||||
~package_context)
|
||||
|
||||
let user_rule (rule : Rule.t) ~dir ~package_context =
|
||||
let targets = List.map rule.targets ~f:(Path.relative dir) in
|
||||
|
@ -490,7 +498,7 @@ module Gen(P : Params) = struct
|
|||
rule.action
|
||||
~dir
|
||||
~dep_kind:Required
|
||||
~targets
|
||||
~targets:(Static targets)
|
||||
~package_context)
|
||||
|
||||
let alias_rules (alias_conf : Alias_conf.t) ~dir ~package_context =
|
||||
|
@ -525,7 +533,7 @@ module Gen(P : Params) = struct
|
|||
action
|
||||
~dir
|
||||
~dep_kind:Required
|
||||
~targets:[]
|
||||
~targets:(Static [])
|
||||
~package_context
|
||||
; Build.create_file digest_path
|
||||
])
|
||||
|
@ -604,7 +612,7 @@ module Gen(P : Params) = struct
|
|||
let dir = ctx_dir in
|
||||
match (stanza : Stanza.t) with
|
||||
| Rule rule -> user_rule rule ~dir ~package_context
|
||||
| Do conf -> do_rule conf ~dir
|
||||
| Do conf -> do_rule conf ~dir ~package_context
|
||||
| Alias alias -> alias_rules alias ~dir ~package_context
|
||||
| Library _ | Executables _ | Provides _ | Install _ -> ());
|
||||
let files = lazy (
|
||||
|
|
|
@ -909,7 +909,7 @@ module Foreach = struct
|
|||
| Error (dup, _, _) ->
|
||||
Loc.fail loc "variable %s appears twice in this pattern" dup
|
||||
in
|
||||
expand_sexps (fun v -> String_map.find v env) sexps)
|
||||
expand_sexps (fun _loc v -> String_map.find v env) sexps)
|
||||
end
|
||||
|
||||
module Stanza = struct
|
||||
|
|
|
@ -72,6 +72,11 @@ let just_a_var t =
|
|||
| [Var (_, s)] -> Some s
|
||||
| _ -> None
|
||||
|
||||
let just_text t =
|
||||
match t.items with
|
||||
| [Text s] -> Some s
|
||||
| _ -> None
|
||||
|
||||
let sexp_of_var_syntax = function
|
||||
| Parens -> Sexp.Atom "parens"
|
||||
| Braces -> Sexp.Atom "braces"
|
||||
|
@ -90,6 +95,11 @@ let fold t ~init ~f =
|
|||
| Text _ -> acc
|
||||
| Var (_, v) -> f acc t.loc v)
|
||||
|
||||
let iter t ~f =
|
||||
List.iter t.items ~f:(function
|
||||
| Text _ -> ()
|
||||
| Var (_, v) -> f t.loc v)
|
||||
|
||||
let vars t = fold t ~init:String_set.empty ~f:(fun acc _ x -> String_set.add x acc)
|
||||
|
||||
let string_of_var syntax v =
|
||||
|
@ -101,11 +111,36 @@ let expand t ~f =
|
|||
List.map t.items ~f:(function
|
||||
| Text s -> s
|
||||
| Var (syntax, v) ->
|
||||
match f v with
|
||||
match f t.loc v with
|
||||
| Some x -> x
|
||||
| None -> string_of_var syntax v)
|
||||
|> String.concat ~sep:""
|
||||
|
||||
let concat_rev = function
|
||||
| [] -> ""
|
||||
| [s] -> s
|
||||
| l -> String.concat (List.rev l) ~sep:" "
|
||||
|
||||
let partial_expand t ~f =
|
||||
let commit_text acc_text acc =
|
||||
let s = concat_rev acc_text in
|
||||
if s = "" then acc else Text s :: acc
|
||||
in
|
||||
let rec loop acc_text acc items =
|
||||
match items with
|
||||
| [] -> begin
|
||||
match acc with
|
||||
| [] -> Inl (concat_rev acc_text)
|
||||
| _ -> Inr { t with items = List.rev (commit_text acc_text acc) }
|
||||
end
|
||||
| Text s :: items -> loop (s :: acc_text) acc items
|
||||
| Var (_, v) as it :: items ->
|
||||
match f t.loc v with
|
||||
| None -> loop [] (it :: commit_text acc_text acc) items
|
||||
| Some s -> loop (s :: acc_text) acc items
|
||||
in
|
||||
loop [] [] t.items
|
||||
|
||||
let to_string t =
|
||||
match t.items with
|
||||
(* [to_string is only called from action.ml, always on [t]s of this form *)
|
||||
|
|
|
@ -16,9 +16,12 @@ val to_string : t -> string
|
|||
val raw : loc:Loc.t -> string -> t
|
||||
|
||||
val just_a_var : t -> string option
|
||||
val just_text : t -> string option
|
||||
|
||||
val vars : t -> String_set.t
|
||||
|
||||
val fold : t -> init:'a -> f:('a -> Loc.t -> string -> 'a) -> 'a
|
||||
val iter : t -> f:(Loc.t -> string -> unit) -> unit
|
||||
|
||||
val expand : t -> f:(string -> string option) -> string
|
||||
val expand : t -> f:(Loc.t -> string -> string option) -> string
|
||||
val partial_expand : t -> f:(Loc.t -> string -> string option) -> (string, t) either
|
||||
|
|
|
@ -1,6 +1,8 @@
|
|||
open Import
|
||||
open Jbuild_types
|
||||
|
||||
module Pset = Path.Set
|
||||
|
||||
module Dir_with_jbuild = struct
|
||||
type t =
|
||||
{ src_dir : Path.t
|
||||
|
@ -74,7 +76,7 @@ let get_external_dir t ~dir =
|
|||
External_dir.create ~dir)
|
||||
|
||||
let expand_vars t ~dir s =
|
||||
String_with_vars.expand s ~f:(function
|
||||
String_with_vars.expand s ~f:(fun _loc -> function
|
||||
| "ROOT" -> Some (Path.reach ~from:dir t.context.build_dir)
|
||||
| var -> String_map.find var t.vars)
|
||||
|
||||
|
@ -110,9 +112,9 @@ let create
|
|||
| _ -> None))
|
||||
in
|
||||
let dirs_with_dot_opam_files =
|
||||
Path.Set.elements dirs_with_dot_opam_files
|
||||
Pset.elements dirs_with_dot_opam_files
|
||||
|> List.map ~f:(Path.append context.build_dir)
|
||||
|> Path.Set.of_list
|
||||
|> Pset.of_list
|
||||
in
|
||||
let libs =
|
||||
Lib_db.create context.findlib internal_libraries
|
||||
|
@ -417,7 +419,7 @@ module Deps = struct
|
|||
| Files_recursively_in s ->
|
||||
let path = Path.relative dir (expand_vars t ~dir s) in
|
||||
Build.files_recursively_in ~dir:path ~file_tree:t.file_tree
|
||||
>>^ Path.Set.elements
|
||||
>>^ Pset.elements
|
||||
|
||||
let interpret t ~dir l =
|
||||
Build.all (List.map l ~f:(dep t ~dir))
|
||||
|
@ -454,58 +456,36 @@ let parse_bang var : Action.Var_expansion.Concat_or_split.t * string =
|
|||
else
|
||||
(Concat, var)
|
||||
|
||||
module Do_action = struct
|
||||
open Build.O
|
||||
module U = Action.Unexpanded
|
||||
|
||||
let run t action ~dir =
|
||||
let action =
|
||||
Action.Unexpanded.expand t.context dir action ~f:(fun var ->
|
||||
let cos, var = parse_bang var in
|
||||
match var with
|
||||
| "ROOT" -> Some (Paths ([t.context.build_dir], cos))
|
||||
| var ->
|
||||
match expand_var_no_root t var with
|
||||
| Some s -> Some (Strings ([s], cos))
|
||||
| None -> None)
|
||||
in
|
||||
let { Action.Infer.Outcome.deps; targets } = Action.Infer.infer action in
|
||||
Build.path_set deps
|
||||
>>>
|
||||
Build.action ~dir ~targets:(Path.Set.elements targets) action
|
||||
end
|
||||
|
||||
module Action = struct
|
||||
open Build.O
|
||||
module U = Action.Unexpanded
|
||||
|
||||
type targets =
|
||||
| Static of Path.t list
|
||||
| Infer
|
||||
|
||||
type resolved_forms =
|
||||
{ (* Mapping from ${...} forms to their resolutions *)
|
||||
artifacts : Action.Var_expansion.t String_map.t
|
||||
mutable artifacts : Action.Var_expansion.t String_map.t
|
||||
; (* Failed resolutions *)
|
||||
failures : fail list
|
||||
mutable failures : fail list
|
||||
; (* All "name" for ${lib:name:...}/${lib-available:name} forms *)
|
||||
lib_deps : Build.lib_deps
|
||||
; vdeps : (unit, Action.Var_expansion.t) Build.t String_map.t
|
||||
mutable lib_deps : Build.lib_deps
|
||||
; mutable vdeps : (unit, Action.Var_expansion.t) Build.t String_map.t
|
||||
}
|
||||
|
||||
let add_artifact ?lib_dep acc ~key result =
|
||||
let lib_deps =
|
||||
match lib_dep with
|
||||
| None -> acc.lib_deps
|
||||
| Some (lib, kind) -> String_map.add acc.lib_deps ~key:lib ~data:kind
|
||||
in
|
||||
(match lib_dep with
|
||||
| None -> ()
|
||||
| Some (lib, kind) ->
|
||||
acc.lib_deps <- String_map.add acc.lib_deps ~key:lib ~data:kind);
|
||||
match result with
|
||||
| Ok path ->
|
||||
{ acc with
|
||||
artifacts = String_map.add acc.artifacts ~key ~data:path
|
||||
; lib_deps
|
||||
}
|
||||
| Ok exp ->
|
||||
acc.artifacts <- String_map.add acc.artifacts ~key ~data:exp;
|
||||
Some exp
|
||||
| Error fail ->
|
||||
{ acc with
|
||||
failures = fail :: acc.failures
|
||||
; lib_deps
|
||||
}
|
||||
acc.failures <- fail :: acc.failures;
|
||||
None
|
||||
|
||||
let ok_path x = Ok (Action.Var_expansion.Paths ([x], Concat))
|
||||
let ok_string x = Ok (Action.Var_expansion.Strings ([x], Concat))
|
||||
|
@ -514,15 +494,16 @@ module Action = struct
|
|||
| Ok x -> ok_path x
|
||||
| Error _ as e -> e
|
||||
|
||||
let extract_artifacts sctx ~dir ~dep_kind ~package_context t =
|
||||
let init =
|
||||
let expand_step1 sctx ~dir ~dep_kind ~package_context t =
|
||||
let acc =
|
||||
{ artifacts = String_map.empty
|
||||
; failures = []
|
||||
; lib_deps = String_map.empty
|
||||
; vdeps = String_map.empty
|
||||
}
|
||||
in
|
||||
U.fold_vars t ~init ~f:(fun acc loc key ->
|
||||
let t =
|
||||
U.partial_expand sctx.context dir t ~f:(fun loc key ->
|
||||
let module A = Artifacts in
|
||||
let open Action.Var_expansion in
|
||||
let cos, var = parse_bang key in
|
||||
|
@ -552,44 +533,49 @@ module Action = struct
|
|||
| None -> Strings ([""], Concat)
|
||||
| Some s -> Strings ([s], Concat)
|
||||
in
|
||||
{ acc with vdeps = String_map.add acc.vdeps ~key ~data:x }
|
||||
acc.vdeps <- String_map.add acc.vdeps ~key ~data:x;
|
||||
| Error s ->
|
||||
{ acc with failures = { fail = fun () -> Loc.fail loc "%s" s } :: acc.failures }
|
||||
end
|
||||
acc.failures <- { fail = fun () -> Loc.fail loc "%s" s } :: acc.failures
|
||||
end; None
|
||||
| Some ("read", s) -> begin
|
||||
let path = Path.relative dir s in
|
||||
let data =
|
||||
Build.contents path
|
||||
>>^ fun s -> Strings ([s], cos)
|
||||
in
|
||||
{acc with vdeps = String_map.add acc.vdeps ~key ~data }
|
||||
end
|
||||
acc.vdeps <- String_map.add acc.vdeps ~key ~data
|
||||
end; None
|
||||
| Some ("read-lines", s) -> begin
|
||||
let path = Path.relative dir s in
|
||||
let data =
|
||||
Build.lines_of path
|
||||
>>^ fun l -> Strings (l, cos)
|
||||
in
|
||||
{acc with vdeps = String_map.add acc.vdeps ~key ~data }
|
||||
end
|
||||
acc.vdeps <- String_map.add acc.vdeps ~key ~data
|
||||
end; None
|
||||
| Some ("read-strings", s) -> begin
|
||||
let path = Path.relative dir s in
|
||||
let data =
|
||||
Build.strings path
|
||||
>>^ fun l -> Strings (l, cos)
|
||||
in
|
||||
{acc with vdeps = String_map.add acc.vdeps ~key ~data }
|
||||
end
|
||||
| _ -> acc)
|
||||
acc.vdeps <- String_map.add acc.vdeps ~key ~data
|
||||
end; None
|
||||
| _ ->
|
||||
match expand_var_no_root sctx var with
|
||||
| Some s -> Some (Strings ([s], cos))
|
||||
| None -> None)
|
||||
in
|
||||
(t, acc)
|
||||
|
||||
let expand_var =
|
||||
fun sctx ~artifacts ~targets ~deps var_name ->
|
||||
let expand_step2 sctx ~dir ~artifacts ~targets ~deps t =
|
||||
let open Action.Var_expansion in
|
||||
let cos, var_name = parse_bang var_name in
|
||||
match String_map.find var_name artifacts with
|
||||
U.Partial.expand sctx.context dir t ~f:(fun _loc key ->
|
||||
match String_map.find key artifacts with
|
||||
| Some _ as opt -> opt
|
||||
| None ->
|
||||
match var_name with
|
||||
let cos, var = parse_bang key in
|
||||
match var with
|
||||
| "@" -> Some (Paths (targets, cos))
|
||||
| "<" ->
|
||||
Some
|
||||
|
@ -604,20 +590,40 @@ module Action = struct
|
|||
| var ->
|
||||
match expand_var_no_root sctx var with
|
||||
| Some s -> Some (Strings ([s], cos))
|
||||
| None -> None
|
||||
| None -> None)
|
||||
|
||||
let run sctx t ~dir ~dep_kind ~targets ~package_context
|
||||
: (Path.t list, Action.t) Build.t =
|
||||
let forms = extract_artifacts sctx ~dir ~dep_kind ~package_context t in
|
||||
let t, forms = expand_step1 sctx ~dir ~dep_kind ~package_context t in
|
||||
let { Action.Infer.Outcome. deps; targets } =
|
||||
match targets with
|
||||
| Infer -> Action.Infer.partial t ~all_targets:true
|
||||
| Static targets_written_by_user ->
|
||||
let targets_written_by_user = Pset.of_list targets_written_by_user in
|
||||
let { Action.Infer.Outcome. deps; targets } =
|
||||
Action.Infer.partial t ~all_targets:false
|
||||
in
|
||||
let missing = Pset.diff targets targets_written_by_user in
|
||||
if not (Pset.is_empty missing) then
|
||||
Loc.warn (Loc.in_file (Utils.jbuild_name_in ~dir))
|
||||
"Missing targets in user action:\n%s"
|
||||
(List.map (Pset.elements missing) ~f:(fun target ->
|
||||
sprintf "- %s" (Utils.describe_target target))
|
||||
|> String.concat ~sep:"\n");
|
||||
{ deps; targets = Pset.union targets targets_written_by_user }
|
||||
in
|
||||
let targets = Pset.elements targets in
|
||||
let build =
|
||||
Build.record_lib_deps_simple ~dir forms.lib_deps
|
||||
>>>
|
||||
Build.path_set deps
|
||||
>>>
|
||||
Build.path_set
|
||||
(String_map.fold forms.artifacts ~init:Path.Set.empty
|
||||
(String_map.fold forms.artifacts ~init:Pset.empty
|
||||
~f:(fun ~key:_ ~data:exp acc ->
|
||||
match exp with
|
||||
| Action.Var_expansion.Paths (ps, _) ->
|
||||
Path.Set.union acc (Path.Set.of_list ps)
|
||||
Pset.union acc (Pset.of_list ps)
|
||||
| Strings _ -> acc))
|
||||
>>>
|
||||
Build.arr (fun paths -> ((), paths))
|
||||
|
@ -629,8 +635,9 @@ module Action = struct
|
|||
List.fold_left2 vdeps vals ~init:forms.artifacts ~f:(fun acc (var, _) value ->
|
||||
String_map.add acc ~key:var ~data:value)
|
||||
in
|
||||
U.expand sctx.context dir t
|
||||
~f:(expand_var sctx ~artifacts ~targets ~deps))
|
||||
expand_step2 sctx ~dir ~artifacts ~targets ~deps t
|
||||
(* CR-someday jdimino: we could infer again to find more dependencies/check
|
||||
targets again *))
|
||||
>>>
|
||||
Build.action_dyn () ~dir ~targets
|
||||
in
|
||||
|
@ -814,7 +821,7 @@ module PP = struct
|
|||
action)))
|
||||
~dir
|
||||
~dep_kind
|
||||
~targets:[dst]
|
||||
~targets:(Static [dst])
|
||||
~package_context))
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
|
||||
|
|
|
@ -119,24 +119,19 @@ module Deps : sig
|
|||
val interpret : t -> dir:Path.t -> Dep_conf.t list -> (unit, Path.t list) Build.t
|
||||
end
|
||||
|
||||
(** Interpret "do" actions, for which targes are inferred *)
|
||||
module Do_action : sig
|
||||
val run
|
||||
: t
|
||||
-> Action.Unexpanded.t
|
||||
-> dir:Path.t
|
||||
-> (unit, Action.t) Build.t
|
||||
end
|
||||
|
||||
(** Interpret action written in jbuild files *)
|
||||
module Action : sig
|
||||
type targets =
|
||||
| Static of Path.t list
|
||||
| Infer
|
||||
|
||||
(** The arrow takes as input the list of actual dependencies *)
|
||||
val run
|
||||
: t
|
||||
-> Action.Unexpanded.t
|
||||
-> dir:Path.t
|
||||
-> dep_kind:Build.lib_dep_kind
|
||||
-> targets:Path.t list
|
||||
-> targets:targets
|
||||
-> package_context:Pkgs.t
|
||||
-> (Path.t list, Action.t) Build.t
|
||||
end
|
||||
|
|
Loading…
Reference in New Issue