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:
Jeremie Dimino 2017-05-31 08:31:52 +01:00
parent 81e6ebd09b
commit 373e6c2524
8 changed files with 549 additions and 272 deletions

View File

@ -9,7 +9,7 @@ module Program = struct
| Not_found of string
let sexp_of_t = function
| This p -> Path.sexp_of_t p
| This p -> Path.sexp_of_t p
| Not_found s -> List [Atom "not_found"; Atom s]
let t sexp =
@ -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,63 +68,28 @@ module Var_expansion = struct
| Paths ([p], Concat) -> p
| Paths (l, Concat) ->
path_of_string ~dir (concat (List.map l ~f:(string_of_path ~dir)))
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)
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 ->
match exp with
| Paths ([p], _) -> (This p , [])
| Strings ([s], _) -> (resolve s, [])
| Paths ([], _) | Strings ([], _) -> (resolve "", [])
| Paths (l, Concat) ->
(Program.This
(V.path_of_string ~dir (V.concat (List.map l ~f:(V.string_of_path ~dir)))),
[])
| Strings (l, Concat) ->
(resolve (V.concat l), l)
| Paths (p :: l, Split) ->
(This p, List.map l ~f:(V.string_of_path ~dir))
| Strings (s :: l, Split) ->
(resolve 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 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 ->
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) ->
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))
SW.iter prog ~f;
List.iter args ~f:(SW.iter ~f);
Run (Inr prog, List.map args ~f:E.simple)
| Chdir (fn, t) ->
let fn = Expand.path ~dir ~f fn in
Chdir (fn, expand ctx fn t ~f)
SW.iter fn ~f;
Chdir (Inr fn, simple_expand t ~f)
| Setenv (var, value, t) ->
Setenv (Expand.string ~dir ~f var, Expand.string ~dir ~f value,
expand ctx dir t ~f)
SW.iter var ~f;
SW.iter value ~f;
Setenv (E.simple var, E.simple value, simple_expand t ~f)
| Redirect (outputs, fn, t) ->
Redirect (outputs, Expand.path ~dir ~f fn, expand ctx dir t ~f)
SW.iter fn ~f;
Redirect (outputs, Inr fn, simple_expand 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)
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) ->
Copy (Expand.path ~dir ~f x, Expand.path ~dir ~f y)
| Symlink (x, y) ->
Symlink (Expand.path ~dir ~f x, Expand.path ~dir ~f y)
SW.iter x ~f;
SW.iter y ~f;
Copy (Inr x, Inr 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)
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) ->
Rename (Expand.path ~dir ~f x, Expand.path ~dir ~f 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 (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
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

View File

@ -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

View File

@ -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 (

View File

@ -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

View File

@ -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 *)

View File

@ -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

View File

@ -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,82 +494,88 @@ 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 module A = Artifacts in
let open Action.Var_expansion in
let cos, var = parse_bang key in
match String.lsplit2 var ~on:':' with
| Some ("exe" , s) -> add_artifact acc ~key (ok_path (Path.relative dir s))
| Some ("path" , s) -> add_artifact acc ~key (ok_path (Path.relative dir s))
| Some ("bin" , s) ->
add_artifact acc ~key (A.binary (artifacts sctx) s |> map_result)
| Some ("lib" , s)
| Some ("libexec" , s) ->
let lib_dep, res = A.file_of_lib (artifacts sctx) ~from:dir s in
add_artifact acc ~key ~lib_dep:(lib_dep, dep_kind) (map_result res)
| Some ("lib-available", lib) ->
add_artifact acc ~key ~lib_dep:(lib, Optional)
(ok_string (string_of_bool (Libs.lib_is_available sctx ~from:dir lib)))
(* CR-someday jdimino: allow this only for (jbuild_version jane_street) *)
| Some ("findlib" , s) ->
let lib_dep, res =
A.file_of_lib (artifacts sctx) ~from:dir s ~use_provides:true
in
add_artifact acc ~key ~lib_dep:(lib_dep, Required) (map_result res)
| Some ("version", s) -> begin
match Pkgs.resolve package_context s with
| Ok p ->
let x =
Pkg_version.read sctx p >>^ function
| None -> Strings ([""], Concat)
| Some s -> Strings ([s], Concat)
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
match String.lsplit2 var ~on:':' with
| Some ("exe" , s) -> add_artifact acc ~key (ok_path (Path.relative dir s))
| Some ("path" , s) -> add_artifact acc ~key (ok_path (Path.relative dir s))
| Some ("bin" , s) ->
add_artifact acc ~key (A.binary (artifacts sctx) s |> map_result)
| Some ("lib" , s)
| Some ("libexec" , s) ->
let lib_dep, res = A.file_of_lib (artifacts sctx) ~from:dir s in
add_artifact acc ~key ~lib_dep:(lib_dep, dep_kind) (map_result res)
| Some ("lib-available", lib) ->
add_artifact acc ~key ~lib_dep:(lib, Optional)
(ok_string (string_of_bool (Libs.lib_is_available sctx ~from:dir lib)))
(* CR-someday jdimino: allow this only for (jbuild_version jane_street) *)
| Some ("findlib" , s) ->
let lib_dep, res =
A.file_of_lib (artifacts sctx) ~from:dir s ~use_provides:true
in
add_artifact acc ~key ~lib_dep:(lib_dep, Required) (map_result res)
| Some ("version", s) -> begin
match Pkgs.resolve package_context s with
| Ok p ->
let x =
Pkg_version.read sctx p >>^ function
| None -> Strings ([""], Concat)
| Some s -> Strings ([s], Concat)
in
acc.vdeps <- String_map.add acc.vdeps ~key ~data:x;
| Error s ->
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:x }
| Error s ->
{ acc with failures = { fail = fun () -> Loc.fail loc "%s" s } :: acc.failures }
end
| 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
| 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
| 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
| 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.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.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 open Action.Var_expansion in
let cos, var_name = parse_bang var_name in
match String_map.find var_name artifacts with
let expand_step2 sctx ~dir ~artifacts ~targets ~deps t =
let open Action.Var_expansion in
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

View File

@ -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