From 373e6c252400ea10c87e1d209e5e3dd78e7c4731 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 31 May 2017 08:31:52 +0100 Subject: [PATCH] Allow ${...:...} for in (do ...) and add more checks Check that targets written by the user are a superset of inferred targets. --- src/action.ml | 435 +++++++++++++++++++++++++++++---------- src/action.mli | 70 ++++--- src/gen_rules.ml | 18 +- src/jbuild_types.ml | 2 +- src/string_with_vars.ml | 37 +++- src/string_with_vars.mli | 5 +- src/super_context.ml | 239 ++++++++++----------- src/super_context.mli | 15 +- 8 files changed, 549 insertions(+), 272 deletions(-) diff --git a/src/action.ml b/src/action.ml index b716cac3..bae86e5c 100644 --- a/src/action.ml +++ b/src/action.ml @@ -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 or (not_found ) 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 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 + acc +@? fn + | Update_file (fn, _) -> acc +@? fn + | Rename (src, dst) -> acc + acc + 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 + acc +@? fn + | Update_file (fn, _) -> acc +@? fn + | Rename (src, dst) -> acc + acc + 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 diff --git a/src/action.mli b/src/action.mli index e4c668d9..6f30ca32 100644 --- a/src/action.mli +++ b/src/action.mli @@ -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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index e9410309..5fcce529 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -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 ( diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index 2b6bb3b6..2ecf742a 100644 --- a/src/jbuild_types.ml +++ b/src/jbuild_types.ml @@ -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 diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index 18d613c0..d4597e37 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -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 *) diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index 5a12c84b..15b12f53 100644 --- a/src/string_with_vars.mli +++ b/src/string_with_vars.mli @@ -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 diff --git a/src/super_context.ml b/src/super_context.ml index ab40b373..566965d9 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -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 diff --git a/src/super_context.mli b/src/super_context.mli index d178a77e..4f5f4d9f 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -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