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

@@ -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) ->
+      | Paths_glob (dir, re) -> begin
-        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 =
           match Pmap.find dir (Lazy.force all_targets_by_dir) with
-          | None -> files
+          | None -> Pset.empty
-          | Some targets -> Pset.union files targets
+          | Some targets ->
-        in
+            Pset.filter targets ~f:(fun path ->
-        Pset.union files acc
+                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;
+  create_file_specs t target_specs rule ~allow_override
-  rule
 
-let copy_rules ~all_deps ~all_targets =
+let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir =
-  let contexts = Context.all () in
+  String_map.iter (Context.all ()) ~f:(fun ~key:_ ~data:(ctx : Context.t) ->
-  Pset.fold (Pset.union all_deps all_targets) ~init:[] ~f:(fun fn acc ->
+    let ctx_dir = ctx.build_dir in
-    match Path.extract_build_context fn with
+    Pset.iter all_non_target_source_files ~f:(fun path ->
-    | Some (name, src) ->
+      let build = Build.copy ~src:path ~dst:(Path.append ctx_dir path) in
-      if String_map.mem name contexts &&
+      (* We temporarily allow overrides while setting up copy rules
-         Path.exists src              &&
+         from the source directory so that artifact that are already
-         not (Pset.mem src all_targets) then
+         present in the source directory are not re-computed.
-        Build.copy ~src ~dst:fn :: acc
-      else
-        acc
-    | None ->
-      acc
-  )
 
-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.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false);
-    List.map rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false)
+  setup_copy_rules t ~all_targets_by_dir
-  in
+    ~all_non_target_source_files:
-  let all_deps =
+      (Pset.diff all_source_files all_other_targets);
-    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));
   t
 
 let remove_old_artifacts t =

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

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

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

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 context   : Context.t
-  val tree     : Alias.tree
+  val file_tree : File_tree.t
-  val stanzas  : (Path.t * Jbuild_types.Stanza.t list) list
+  val tree      : Alias.tree
-  val packages : string list
+  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

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

src/jbuild_load.ml

@@ -2,61 +2,54 @@ open Import
 open Jbuild_types
 
 type conf =
-  { tree     : Alias.tree
+  { file_tree : File_tree.t
-  ; stanzas  : (Path.t * Jbuild_types.Stanza.t list) list
+  ; tree      : Alias.tree
-  ; packages : string list
+  ; 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 =
+let load ftree =
-  String_set.of_list
-    [ ""
-    ; "_build"
-    ; ".git"
-    ; ".hg"
-    ]
-
-let load () =
   let rec walk dir stanzas =
-    let files = Path.readdir dir |> String_set.of_list in
+    let path = File_tree.Dir.path dir in
-    let ignore_set =
+    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
+        let ignore_set =
-          (lines_of_file (Path.to_string (Path.relative dir "jbuild-ignore"))
+          String_set.of_list
-           |> String_set.of_list)
+            (lines_of_file (Path.to_string (Path.relative path "jbuild-ignore")))
-          always_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) ->
+      String_map.fold sub_dirs ~init:([], stanzas) ~f:(fun ~key:_ ~data:dir (children, stanzas) ->
-        if String_set.mem fn ignore_set || fn.[0] = '.' then
+          let child, stanzas = walk dir stanzas in
-          acc
+          (child :: children, stanzas))
-        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)
     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
   }

src/jbuild_load.mli

@@ -1,8 +1,9 @@
 
 type conf =
-  { tree     : Alias.tree
+  { file_tree : File_tree.t
-  ; stanzas  : (Path.t * Jbuild_types.Stanza.t list) list
+  ; tree      : Alias.tree
-  ; packages : string list
+  ; stanzas   : (Path.t * Jbuild_types.Stanza.t list) list
+  ; packages  : string list
   }
 
 val load : unit -> conf

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 =