From 30a914278e250f72d51af7a7f6387bdebb1bef8e Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Fri, 29 Sep 2017 16:06:29 +0100 Subject: [PATCH] All aliases on the command line are recursive Calling 'jbuilder build @path/x' always request the alias `x` in `path` and all its descendant. To implement that, change the build system interface to take an arbitrary request as argument. --- bin/main.ml | 52 +++++++++++++++++++++++-------------- src/alias.ml | 28 ++++++++++++++++++++ src/alias.mli | 6 +++++ src/build_system.ml | 62 +++++++++++++++++++++++++++++++++++++------- src/build_system.mli | 34 ++++++++++++++++-------- src/file_tree.mli | 7 +++++ src/gen_rules.ml | 2 +- src/main.ml | 8 ++++-- src/main.mli | 1 + 9 files changed, 156 insertions(+), 44 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 4c94ed57..c240536a 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -70,8 +70,23 @@ module Main = struct ?filter_out_optional_stanzas_with_missing_deps () end +type target = + | File of Path.t + | Alias_rec of Alias.t + +let request_of_targets (setup : Main.setup) targets = + let open Build.O in + List.fold_left targets ~init:(Build.return ()) ~f:(fun acc target -> + acc >>> + match target with + | File path -> Build.path path + | Alias_rec alias -> + Alias.dep_rec ~loc:(Loc.in_file "") + ~file_tree:setup.file_tree alias) + let do_build (setup : Main.setup) targets = - Build_system.do_build_exn setup.build_system targets + Build_system.do_build_exn setup.build_system + ~request:(request_of_targets setup targets) let find_root () = let cwd = Sys.getcwd () in @@ -338,10 +353,6 @@ let resolve_package_install setup pkg = | Error () -> die "Unknown package %s!%s" pkg (hint pkg (String_map.keys setup.packages)) -type target = - | File of Path.t - | Alias of Path.t * Alias.t - let target_hint (setup : Main.setup) path = assert (Path.is_local path); let sub_dir = Path.parent path in @@ -381,7 +392,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = else let dir = Path.parent path in let name = Path.basename path in - [Alias (path, Alias.make ~dir name)] + [Alias_rec (Alias.make ~dir name)] else let path = Path.relative Path.root (prefix_target common s) in let can't_build path = @@ -420,13 +431,13 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = List.iter targets ~f:(function | File path -> Log.info log @@ "- " ^ (Path.to_string path) - | Alias (path, _) -> - Log.info log @@ "- alias " ^ (Path.to_string path)); + | Alias_rec alias -> + let path = Alias.fully_qualified_name alias in + Log.info log @@ "- recursive alias " ^ + (Path.to_string_maybe_quoted path)); flush stdout; end; - List.map targets ~f:(function - | File path -> path - | Alias (_, alias) -> Alias.file alias) + targets let build_targets = let doc = "Build the given targets, or all installable targets if none are given." in @@ -471,7 +482,7 @@ let runtest = let targets = List.map dirs ~f:(fun dir -> let dir = Path.(relative root) (prefix_target common dir) in - Alias.file (Alias.runtest ~dir)) + Alias_rec (Alias.runtest ~dir)) in do_build setup targets) in ( Term.(const go @@ -522,9 +533,10 @@ let external_lib_deps = (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false >>= fun setup -> let targets = resolve_targets ~log common setup targets in + let request = request_of_targets setup targets in let failure = String_map.fold ~init:false - (Build_system.all_lib_deps_by_context setup.build_system targets) + (Build_system.all_lib_deps_by_context setup.build_system ~request) ~f:(fun ~key:context_name ~data:lib_deps acc -> let internals = Jbuild.Stanzas.lib_names @@ -623,12 +635,12 @@ let rules = Future.Scheduler.go ~log (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false >>= fun setup -> - let targets = + let request = match targets with - | [] -> Build_system.all_targets setup.build_system - | _ -> resolve_targets ~log common setup targets + | [] -> Build.paths (Build_system.all_targets setup.build_system) + | _ -> resolve_targets ~log common setup targets |> request_of_targets setup in - Build_system.build_rules setup.build_system targets ~recursive >>= fun rules -> + Build_system.build_rules setup.build_system ~request ~recursive >>= fun rules -> let print oc = let ppf = Format.formatter_of_out_channel oc in Sexp.prepare_formatter ppf; @@ -918,10 +930,10 @@ let utop = let target = match resolve_targets ~log common setup [utop_target] with | [] -> die "no libraries defined in %s" dir - | [target] -> target - | _::_::_ -> assert false + | [File target] -> target + | [Alias_rec _] | _::_::_ -> assert false in - do_build setup [target] >>| fun () -> + do_build setup [File target] >>| fun () -> (setup.build_system, context, Path.to_string target) ) |> Future.Scheduler.go ~log in Build_system.dump_trace build_system; diff --git a/src/alias.ml b/src/alias.ml index cfbfb996..c33c3812 100644 --- a/src/alias.ml +++ b/src/alias.ml @@ -32,12 +32,40 @@ let of_path path = let name t = Path.basename (Fq_name.path t.name) let dir t = Path.parent (Fq_name.path t.name) +let fully_qualified_name t = Fq_name.path t.name + let make name ~dir = assert (not (String.contains name '/')); of_path (Path.relative dir name) let dep t = Build.path t.file +let dep_rec ~loc ~file_tree t = + let path = Path.parent (Fq_name.path t.name) |> Path.drop_build_context in + let name = Path.basename (Fq_name.path t.name) in + match File_tree.find_dir file_tree path with + | None -> Build.fail { fail = fun () -> + Loc.fail loc "Don't know about directory %s!" (Path.to_string_maybe_quoted path) } + | Some dir -> + let open Build.O in + File_tree.Dir.fold dir ~traverse_ignored_dirs:false ~init:(Build.return true) + ~f:(fun dir acc -> + let path = File_tree.Dir.path dir in + let t = of_path (Path.relative path name) in + acc + >>> + Build.if_file_exists t.file + ~then_:(Build.path t.file + >>^ + fun _ -> false) + ~else_:(Build.arr (fun x -> x))) + >>^ function + | false -> () + | true -> + Loc.fail loc "This recursive alias is empty.\n\ + Alias %S is not defined in %s or any of its descendants." + name (Path.to_string_maybe_quoted path) + let file t = t.file let file_with_digest_suffix t ~digest = diff --git a/src/alias.mli b/src/alias.mli index 637ec0c3..ffca98b7 100644 --- a/src/alias.mli +++ b/src/alias.mli @@ -11,6 +11,8 @@ val make : string -> dir:Path.t -> t val name : t -> string val dir : t -> Path.t +val fully_qualified_name : t -> Path.t + val default : dir:Path.t -> t val runtest : dir:Path.t -> t val install : dir:Path.t -> t @@ -18,6 +20,10 @@ val doc : dir:Path.t -> t val dep : t -> ('a, 'a) Build.t +(** Implements [(alias_rec ...)] in dependency specification and + [@alias] on the command line. *) +val dep_rec : loc:Loc.t -> file_tree:File_tree.t -> t -> (unit, unit) Build.t + (** File that represent the alias in the filesystem. It is a file under [_build/.aliases]. *) val file : t -> Path.t diff --git a/src/build_system.ml b/src/build_system.ml index 70a0b4f0..876461e4 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -125,6 +125,7 @@ type t = [(deps (filename + contents), targets (filename only), action)] *) trace : (Path.t, Digest.t) Hashtbl.t ; mutable local_mkdirs : Path.Local.Set.t + ; all_targets_by_dir : Pset.t Pmap.t Lazy.t } let all_targets t = Hashtbl.fold t.files ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) @@ -304,6 +305,9 @@ module Build_exec = struct let dyn_deps = ref Pset.empty in let action = exec dyn_deps (Build.repr t) x in (action, !dyn_deps) + + let exec_nop bs t x = + snd (exec bs (Build.O.(>>^) t (fun () -> Action.Progn [])) x) end (* This variable is filled during the creation of the build system. Once the build system @@ -638,6 +642,7 @@ let create ~contexts ~file_tree ~rules = ; files = Hashtbl.create 1024 ; trace = Trace.load () ; local_mkdirs = Path.Local.Set.empty + ; all_targets_by_dir } in List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~copy_source:false); setup_copy_rules t ~all_targets_by_dir @@ -717,13 +722,34 @@ let remove_old_artifacts t = walk (Config.local_install_dir ~context:ctx.name); ) -let do_build_exn t targets = - remove_old_artifacts t; - all_unit (List.map targets ~f:(fun fn -> wait_for_file t fn ~targeting:fn)) +let eval_request t ~request ~process_target = + let { Build_interpret.Static_deps. + rule_deps + ; action_deps = static_deps + } = Build_interpret.static_deps request ~all_targets_by_dir:t.all_targets_by_dir + in -let do_build t targets = + let process_targets ts = + Future.all_unit (List.map (Pset.elements ts) ~f:process_target) + in + + Future.both + (process_targets static_deps) + (Future.all_unit (List.map (Pset.elements rule_deps) ~f:(fun fn -> + wait_for_file t fn ~targeting:fn)) + >>= fun () -> + let dyn_deps = Build_exec.exec_nop t request () in + process_targets (Pset.diff dyn_deps static_deps)) + >>| fun ((), ()) -> () + +let do_build_exn t ~request = + remove_old_artifacts t; + eval_request t ~request ~process_target:(fun fn -> + wait_for_file t fn ~targeting:fn) + +let do_build t ~request = try - Ok (do_build_exn t targets) + Ok (do_build_exn t ~request) with Build_error.E e -> Error e @@ -760,7 +786,16 @@ let rules_for_targets t targets = Path.to_string (Pset.choose rule.Internal_rule.targets)) |> String.concat ~sep:"\n-> ") -let all_lib_deps t targets = +let static_deps_of_request t request = + let { Build_interpret.Static_deps. + rule_deps + ; action_deps + } = Build_interpret.static_deps request ~all_targets_by_dir:t.all_targets_by_dir + in + Pset.elements (Pset.union rule_deps action_deps) + +let all_lib_deps t ~request = + let targets = static_deps_of_request t request in List.fold_left (rules_for_targets t targets) ~init:Pmap.empty ~f:(fun acc rule -> let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in @@ -771,7 +806,8 @@ let all_lib_deps t targets = | None, Some b -> Some b | Some a, Some b -> Some (Build.merge_lib_deps a b))) -let all_lib_deps_by_context t targets = +let all_lib_deps_by_context t ~request = + let targets = static_deps_of_request t request in List.fold_left (rules_for_targets t targets) ~init:[] ~f:(fun acc rule -> let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in Path.Map.fold lib_deps ~init:acc ~f:(fun ~key:path ~data:lib_deps acc -> @@ -817,7 +853,7 @@ module Rule_closure = rules_for_files graph (Pset.elements t.deps) end) -let build_rules t ?(recursive=false) targets = +let build_rules ?(recursive=false) t ~request = let rules_seen = ref Id_set.empty in let rules = ref [] in let rec loop fn = @@ -863,7 +899,10 @@ let build_rules t ?(recursive=false) targets = return () end in - Future.all_unit (List.map targets ~f:loop) + let targets = ref Pset.empty in + eval_request t ~request ~process_target:(fun fn -> + targets := Pset.add fn !targets; + loop fn) >>= fun () -> Future.all !rules >>| fun rules -> @@ -872,7 +911,10 @@ let build_rules t ?(recursive=false) targets = Pset.fold r.targets ~init:acc ~f:(fun fn acc -> Pmap.add acc ~key:fn ~data:r)) in - match Rule_closure.top_closure rules (rules_for_files rules targets) with + match + Rule_closure.top_closure rules + (rules_for_files rules (Pset.elements !targets)) + with | Ok l -> l | Error cycle -> die "dependency cycle detected:\n %s" diff --git a/src/build_system.mli b/src/build_system.mli index 0099770c..1eac9030 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -23,16 +23,28 @@ module Build_error : sig end (** Do the actual build *) -val do_build : t -> Path.t list -> (unit Future.t, Build_error.t) result -val do_build_exn : t -> Path.t list -> unit Future.t +val do_build + : t + -> request:(unit, unit) Build.t + -> (unit Future.t, Build_error.t) result +val do_build_exn + : t + -> request:(unit, unit) Build.t + -> unit Future.t -(** Return all the library dependencies (as written by the user) needed to build these - targets *) -val all_lib_deps : t -> Path.t list -> Build.lib_deps Path.Map.t +(** Return all the library dependencies (as written by the user) + needed to build this request *) +val all_lib_deps + : t + -> request:(unit, unit) Build.t + -> Build.lib_deps Path.Map.t -(** Return all the library dependencies required to build these targets, by context - name *) -val all_lib_deps_by_context : t -> Path.t list -> Build.lib_deps String_map.t +(** Return all the library dependencies required to build this + request, by context name *) +val all_lib_deps_by_context + : t + -> request:(unit, unit) Build.t + -> Build.lib_deps String_map.t (** List of all buildable targets *) val all_targets : t -> Path.t list @@ -58,9 +70,9 @@ end [recursive] is [true], return all the rules needed to build the given targets and their transitive dependencies. *) val build_rules - : t - -> ?recursive:bool (* default false *) - -> Path.t list + : ?recursive:bool (* default false *) + -> t + -> request:(unit, unit) Build.t -> Rule.t list Future.t val all_targets_ever_built diff --git a/src/file_tree.mli b/src/file_tree.mli index e71ee5be..44a339a3 100644 --- a/src/file_tree.mli +++ b/src/file_tree.mli @@ -10,6 +10,13 @@ module Dir : sig (** Whether this directory is ignored by a [jbuild-ignore] file in one of its ancestor directories. *) val ignored : t -> bool + + val fold + : t + -> traverse_ignored_dirs:bool + -> init:'a + -> f:(t -> 'a -> 'a) + -> 'a end type t diff --git a/src/gen_rules.ml b/src/gen_rules.ml index a381eda6..b227cce2 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -1151,6 +1151,6 @@ let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) >>| fun l -> let rules, context_names_and_stanzas = List.split l in (Alias.rules aliases - ~prefixes:(Path.root :: List.map contexts ~f:(fun c -> c.Context.build_dir)) ~file_tree + ~prefixes:(Path.root :: List.map contexts ~f:(fun c -> c.Context.build_dir)) ~file_tree @ List.concat rules, String_map.of_alist_exn context_names_and_stanzas) diff --git a/src/main.ml b/src/main.ml index 569a2b51..6329704c 100644 --- a/src/main.ml +++ b/src/main.ml @@ -6,6 +6,7 @@ type setup = ; stanzas : (Path.t * Jbuild.Scope.t * Jbuild.Stanzas.t) list String_map.t ; contexts : Context.t list ; packages : Package.t String_map.t + ; file_tree : File_tree.t } let package_install_file { packages; _ } pkg = @@ -54,6 +55,7 @@ let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps ; stanzas ; contexts ; packages = conf.packages + ; file_tree = conf.file_tree } let external_lib_deps ?log ~packages () = @@ -71,7 +73,8 @@ let external_lib_deps ?log ~packages () = | Some stanzas -> let internals = Jbuild.Stanzas.lib_names stanzas in Path.Map.map - (Build_system.all_lib_deps setup.build_system install_files) + (Build_system.all_lib_deps setup.build_system + ~request:(Build.paths install_files)) ~f:(String_map.filter ~f:(fun name _ -> not (String_set.mem name internals)))) @@ -211,7 +214,8 @@ let bootstrap () = ~extra_ignored_subtrees:ignored_during_bootstrap () >>= fun { build_system = bs; _ } -> - Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) + Build_system.do_build_exn bs + ~request:(Build.path (Path.(relative root) (pkg ^ ".install")))) in try main () diff --git a/src/main.mli b/src/main.mli index f7167eb8..d8c573ac 100644 --- a/src/main.mli +++ b/src/main.mli @@ -7,6 +7,7 @@ type setup = stanzas : (Path.t * Scope.t * Stanzas.t) list String_map.t ; contexts : Context.t list ; packages : Package.t String_map.t + ; file_tree : File_tree.t } (* Returns [Error ()] if [pkg] is unknown *)