From 614dbc6f6bfa5f8f0cc43370279a5197888c2dee Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sat, 31 Dec 2016 15:12:39 +0000 Subject: [PATCH] Setup copy rules for all source files This is cleaner and allow dependencies on files that do not appear in static deps or targets. With this patch, one can now build all JS packages at once. --- src/build_system.ml | 105 ++++++++++++++++++------------------------- src/build_system.mli | 2 +- src/file_tree.ml | 76 +++++++++++++++++++++++++++++++ src/file_tree.mli | 20 +++++++++ src/gen_rules.ml | 18 +++++--- src/gen_rules.mli | 1 + src/jbuild_load.ml | 61 +++++++++++-------------- src/jbuild_load.mli | 7 +-- src/main.ml | 6 +-- 9 files changed, 187 insertions(+), 109 deletions(-) create mode 100644 src/file_tree.ml create mode 100644 src/file_tree.mli diff --git a/src/build_system.ml b/src/build_system.ml index fac86595..b6f72406 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -168,31 +168,13 @@ module Build_interpret = struct | Fanout (a, b) -> loop a (loop b acc) | Paths fns -> Pset.union fns acc | Vpath (Vspec.T (fn, _)) -> Pset.add fn acc - | Paths_glob (dir, re) -> - let src_dir = - match Path.extract_build_context dir with - | None -> dir - | Some (_, dir) -> dir - in - let files = - Path.readdir src_dir - |> List.filter_map ~f:(fun fn -> - if Re.execp re fn then begin - let path = Path.relative src_dir fn in - if Path.is_directory path then - None - else - Some path - end else - None) - |> Pset.of_list - in - let files = + | Paths_glob (dir, re) -> begin match Pmap.find dir (Lazy.force all_targets_by_dir) with - | None -> files - | Some targets -> Pset.union files targets - in - Pset.union files acc + | None -> Pset.empty + | Some targets -> + Pset.filter targets ~f:(fun path -> + Re.execp re (Path.basename path)) + end | Dyn_paths t -> loop t acc | Record_lib_deps _ -> acc in @@ -357,33 +339,47 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = ; exec } in - create_file_specs t target_specs rule ~allow_override; - rule + create_file_specs t target_specs rule ~allow_override -let copy_rules ~all_deps ~all_targets = - let contexts = Context.all () in - Pset.fold (Pset.union all_deps all_targets) ~init:[] ~f:(fun fn acc -> - match Path.extract_build_context fn with - | Some (name, src) -> - if String_map.mem name contexts && - Path.exists src && - not (Pset.mem src all_targets) then - Build.copy ~src ~dst:fn :: acc - else - acc - | None -> - acc - ) +let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir = + String_map.iter (Context.all ()) ~f:(fun ~key:_ ~data:(ctx : Context.t) -> + let ctx_dir = ctx.build_dir in + Pset.iter all_non_target_source_files ~f:(fun path -> + let build = Build.copy ~src:path ~dst:(Path.append ctx_dir path) in + (* We temporarily allow overrides while setting up copy rules + from the source directory so that artifact that are already + present in the source directory are not re-computed. -let create ~rules = + This allows to keep generated files in tarballs. Maybe we + should allow it on a case-by-case basis though. *) + compile_rule t (Pre_rule.make build) + ~all_targets_by_dir + ~allow_override:true)) + +let create ~file_tree ~rules = let rules = List.map rules ~f:Pre_rule.make in - let all_targets = + let all_source_files = + File_tree.fold file_tree ~init:Pset.empty ~f:(fun dir acc -> + let path = File_tree.Dir.path dir in + Pset.union acc + (File_tree.Dir.files dir + |> String_set.elements + |> List.map ~f:(Path.relative path) + |> Pset.of_list)) + in + let all_copy_targets = + String_map.fold (Context.all ()) ~init:Pset.empty ~f:(fun ~key:_ ~data:(ctx : Context.t) acc -> + Pset.union acc (Pset.elements all_source_files + |> List.map ~f:(Path.append ctx.build_dir) + |> Pset.of_list)) + in + let all_other_targets = List.fold_left rules ~init:Pset.empty ~f:(fun acc { Pre_rule.targets; _ } -> List.fold_left targets ~init:acc ~f:(fun acc target -> Pset.add (Target.path target) acc)) in let all_targets_by_dir = lazy ( - Pset.elements all_targets + Pset.elements (Pset.union all_copy_targets all_other_targets) |> List.filter_map ~f:(fun path -> if Path.is_root path then None @@ -393,25 +389,10 @@ let create ~rules = |> Pmap.map ~f:Pset.of_list ) in let t = { files = Hashtbl.create 1024 } in - let rules = - List.map rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false) - in - let all_deps = - List.fold_left rules ~init:Pset.empty ~f:(fun acc { Rule.deps; _ } -> - Pset.union acc deps) - in - (* We temporarily allow overrides while setting up copy rules from the source directory - so that artifact that are already present in the source directory are not - re-computed. - - This allows to keep generated files in tarballs. Maybe we should allow it on a - case-by-case basis though. - *) - List.iter (copy_rules ~all_deps ~all_targets) - ~f:(fun build -> - ignore (compile_rule t (Pre_rule.make build) - ~all_targets_by_dir:(lazy (assert false)) - ~allow_override:true : Rule.t)); + List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false); + setup_copy_rules t ~all_targets_by_dir + ~all_non_target_source_files: + (Pset.diff all_source_files all_other_targets); t let remove_old_artifacts t = diff --git a/src/build_system.mli b/src/build_system.mli index b3411fc6..f06ba513 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -4,7 +4,7 @@ open! Import type t -val create : rules:(unit, unit) Build.t list -> t +val create : file_tree:File_tree.t -> rules:(unit, unit) Build.t list -> t module Build_error : sig type t diff --git a/src/file_tree.ml b/src/file_tree.ml new file mode 100644 index 00000000..27c1079c --- /dev/null +++ b/src/file_tree.ml @@ -0,0 +1,76 @@ +open! Import + +module Dir = struct + type t = + { path : Path.t + ; files : String_set.t + ; sub_dirs : t String_map.t + } + + let path t = t.path + let files t = t.files + let sub_dirs t = t.sub_dirs + + let rec fold t ~init ~f = + let init = f t init in + String_map.fold t.sub_dirs ~init ~f:(fun ~key:_ ~data:t acc -> + fold t ~init:acc ~f) +end + +type t = + { root : Dir.t + ; dirs : Dir.t Path.Map.t + } + +let root t = t.root + +let always_ignore = + String_set.of_list + [ "" + ; "_build" + ; ".git" + ; ".hg" + ; "_darcs" + ] + +let ignore_file = function + | "" + | "_build" + | ".git" + | ".hg" + | "_darcs" + | "." -> true + | fn -> fn.[0] = '.' && fn.[1] = '#' + +let load path = + let rec walk path : Dir.t = + let files, sub_dirs = + Path.readdir path + |> List.filter ~f:(fun fn -> + not (ignore_file fn)) + |> List.partition_map ~f:(fun fn -> + let path = Path.relative path fn in + if Path.exists path && Path.is_directory path then + Inr (fn, walk path) + else + Inl fn) + in + { path + ; files = String_set.of_list files + ; sub_dirs = String_map.of_alist_exn sub_dirs + } + in + let root = walk path in + let dirs = + Dir.fold root ~init:Path.Map.empty ~f:(fun dir acc -> + Path.Map.add acc ~key:dir.path ~data:dir) + in + { root + ; dirs + } + +let fold t ~init ~f = + Path.Map.fold t.dirs ~init ~f:(fun ~key:_ ~data:dir acc -> f dir acc) + +let find_dir t path = + Path.Map.find path t.dirs diff --git a/src/file_tree.mli b/src/file_tree.mli new file mode 100644 index 00000000..1f5fdbe7 --- /dev/null +++ b/src/file_tree.mli @@ -0,0 +1,20 @@ +open! Import + + +module Dir : sig + type t + + val path : t -> Path.t + val files : t -> String_set.t + val sub_dirs : t -> t String_map.t +end + +type t + +val load : Path.t -> t + +val fold : t -> init:'a -> f:(Dir.t -> 'a -> 'a) -> 'a + +val root : t -> Dir.t + +val find_dir : t -> Path.t -> Dir.t option diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 72d26f63..76f2c7d5 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -65,10 +65,11 @@ let obj_name_of_basename fn = | Some i -> String.sub fn ~pos:0 ~len:i module type Params = sig - val context : Context.t - val tree : Alias.tree - val stanzas : (Path.t * Jbuild_types.Stanza.t list) list - val packages : string list + val context : Context.t + val file_tree : File_tree.t + val tree : Alias.tree + val stanzas : (Path.t * Jbuild_types.Stanza.t list) list + val packages : string list val filter_out_optional_stanzas_with_missing_deps : bool end @@ -1363,7 +1364,11 @@ module Gen(P : Params) = struct let rules { src_dir; ctx_dir; stanzas } = let files = lazy ( - let src_files = Path.readdir src_dir |> String_set.of_list in + let src_files = + match File_tree.find_dir P.file_tree src_dir with + | None -> String_set.empty + | Some dir -> File_tree.Dir.files dir + in let files_produced_by_rules = List.concat_map stanzas ~f:(fun stanza -> match (stanza : Stanza.t) with @@ -1528,11 +1533,12 @@ module Gen(P : Params) = struct ~dst:(Path.relative Path.root fn))) end -let gen ~context ~tree ~stanzas ~packages +let gen ~context ~file_tree ~tree ~stanzas ~packages ?(filter_out_optional_stanzas_with_missing_deps=true) () = let module M = Gen(struct let context = context + let file_tree = file_tree let tree = tree let stanzas = stanzas let packages = packages diff --git a/src/gen_rules.mli b/src/gen_rules.mli index 419e7baa..31efd46a 100644 --- a/src/gen_rules.mli +++ b/src/gen_rules.mli @@ -1,5 +1,6 @@ val gen : context:Context.t + -> file_tree:File_tree.t -> tree:Alias.tree -> stanzas:(Path.t * Jbuild_types.Stanza.t list) list -> packages:string list diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 46a83392..c61e9b8d 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -2,61 +2,54 @@ open Import open Jbuild_types type conf = - { tree : Alias.tree - ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list - ; packages : string list + { file_tree : File_tree.t + ; tree : Alias.tree + ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list + ; packages : string list } let load fn ~dir = (dir, Sexp_load.many fn Stanza.t) -let always_ignore = - String_set.of_list - [ "" - ; "_build" - ; ".git" - ; ".hg" - ] - -let load () = +let load ftree = let rec walk dir stanzas = - let files = Path.readdir dir |> String_set.of_list in - let ignore_set = + let path = File_tree.Dir.path dir in + let files = File_tree.Dir.files dir in + let sub_dirs = File_tree.Dir.sub_dirs dir in + let sub_dirs = if String_set.mem "jbuild-ignore" files then - String_set.union - (lines_of_file (Path.to_string (Path.relative dir "jbuild-ignore")) - |> String_set.of_list) - always_ignore + let ignore_set = + String_set.of_list + (lines_of_file (Path.to_string (Path.relative path "jbuild-ignore"))) + in + String_map.filter sub_dirs ~f:(fun fn _ -> + not (String_set.mem fn ignore_set)) else - always_ignore + sub_dirs in let children, stanzas = - String_set.fold files ~init:([], stanzas) ~f:(fun fn ((children, stanzas) as acc) -> - if String_set.mem fn ignore_set || fn.[0] = '.' then - acc - else - let fn = Path.relative dir fn in - if Path.exists fn && Path.is_directory fn then - let child, stanzas, _ = walk fn stanzas in - (child :: children, stanzas) - else - acc) + String_map.fold sub_dirs ~init:([], stanzas) ~f:(fun ~key:_ ~data:dir (children, stanzas) -> + let child, stanzas = walk dir stanzas in + (child :: children, stanzas)) in let stanzas = if String_set.mem "jbuild" files then - load (Path.to_string (Path.relative dir "jbuild")) ~dir :: stanzas + load (Path.to_string (Path.relative path "jbuild")) ~dir:path :: stanzas else stanzas in - (Alias.Node (dir, children), stanzas, files) + (Alias.Node (path, children), stanzas) in - let tree, stanzas, files = walk Path.root [] in + let ftree = File_tree.load Path.root in + let root = File_tree.root ftree in + let tree, stanzas = walk root [] in let packages = - String_set.fold files ~init:[] ~f:(fun fn acc -> + String_set.fold (File_tree.Dir.files root) ~init:[] ~f:(fun fn acc -> match Filename.split_ext fn with | Some (pkg, ".opam") -> pkg :: acc | _ -> acc) in - { tree + { file_tree = ftree + ; tree ; stanzas ; packages } diff --git a/src/jbuild_load.mli b/src/jbuild_load.mli index de922114..1cbadcac 100644 --- a/src/jbuild_load.mli +++ b/src/jbuild_load.mli @@ -1,8 +1,9 @@ type conf = - { tree : Alias.tree - ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list - ; packages : string list + { file_tree : File_tree.t + ; tree : Alias.tree + ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list + ; packages : string list } val load : unit -> conf diff --git a/src/main.ml b/src/main.ml index bb4b6fcd..19d8a108 100644 --- a/src/main.ml +++ b/src/main.ml @@ -47,13 +47,13 @@ let internal argv = () let setup ?filter_out_optional_stanzas_with_missing_deps () = - let { Jbuild_load. tree; stanzas; packages } = Jbuild_load.load () in + let { Jbuild_load. file_tree; tree; stanzas; packages } = Jbuild_load.load () in Lazy.force Context.default >>= fun ctx -> let rules = - Gen_rules.gen ~context:ctx ~tree ~stanzas ~packages + Gen_rules.gen ~context:ctx ~file_tree ~tree ~stanzas ~packages ?filter_out_optional_stanzas_with_missing_deps () in - let bs = Build_system.create ~rules in + let bs = Build_system.create ~file_tree ~rules in return (bs, stanzas, ctx) let external_lib_deps ~packages =