Add the parent directories of the files

Signed-off-by: Alpha DIALLO <moyodiallo@gmail.com>
moyodiallo · Oct 17, 2024 · b00b92e · b00b92e
1 parent 5019bce
commit b00b92e
Show file tree

Hide file tree

Showing 2 changed files with 52 additions and 29 deletions.
diff --git a/src/dune_targets/dune_targets.ml b/src/dune_targets/dune_targets.ml
@@ -217,33 +217,56 @@ module Produced = struct
 
   let of_validated =
     (* The call sites ensure that [dir = Path.Build.append_local validated.root local]. *)
-    let rec collect (dir : Path.Build.t) (local : Path.Local.t)
-      : (unit Filename.Map.t Path.Local.Map.t, Error.t) result
-      =
-      match Path.readdir_unsorted_with_kinds (Path.build dir) with
-      | Error (Unix.ENOENT, _, _) -> Error (Missing_dir dir)
-      | Error e -> Error (Unreadable_dir (dir, e))
-      | Ok dir_contents ->
-        let open Result.O in
-        let+ filenames, dirs =
-          Result.List.fold_left
-            dir_contents
-            ~init:(Filename.Map.empty, Path.Local.Map.empty)
-            ~f:(fun (acc_filenames, acc_dirs) (filename, kind) ->
-              match (kind : File_kind.t) with
-              (* CR-someday rleshchinskiy: Make semantics of symlinks more consistent. *)
-              | S_LNK | S_REG ->
-                Ok (Filename.Map.add_exn acc_filenames filename (), acc_dirs)
-              | S_DIR ->
-                let+ dir =
-                  collect
-                    (Path.Build.relative dir filename)
-                    (Path.Local.relative local filename)
-                in
-                acc_filenames, Path.Local.Map.union_exn acc_dirs dir
-              | _ -> Error (Unsupported_file (Path.Build.relative dir filename, kind)))
-        in
-        Path.Local.Map.add_exn dirs local filenames
+    let collect dir local =
+      let rec collect (dir : Path.Build.t) (local : Path.Local.t)
+        : (unit Filename.Map.t Path.Local.Map.t, Error.t) result
+        =
+        match Path.readdir_unsorted_with_kinds (Path.build dir) with
+        | Error (Unix.ENOENT, _, _) -> Error (Missing_dir dir)
+        | Error e -> Error (Unreadable_dir (dir, e))
+        | Ok dir_contents ->
+          let open Result.O in
+          let+ filenames, dirs =
+            Result.List.fold_left
+              dir_contents
+              ~init:(Filename.Map.empty, Path.Local.Map.empty)
+              ~f:(fun (acc_filenames, acc_dirs) (filename, kind) ->
+                match (kind : File_kind.t) with
+                (* CR-someday rleshchinskiy: Make semantics of symlinks more consistent. *)
+                | S_LNK | S_REG ->
+                  Ok (Filename.Map.add_exn acc_filenames filename (), acc_dirs)
+                | S_DIR ->
+                  let+ dir =
+                    collect
+                      (Path.Build.relative dir filename)
+                      (Path.Local.relative local filename)
+                  in
+                  acc_filenames, Path.Local.Map.union_exn acc_dirs dir
+                | _ -> Error (Unsupported_file (Path.Build.relative dir filename, kind)))
+          in
+          if not (Filename.Map.is_empty filenames)
+          then Path.Local.Map.add_exn dirs local filenames
+          else dirs
+      in
+      let rec parent_dirs local dirs =
+        let parent = Path.Local.parent local in
+        if Option.forall parent ~f:(fun p -> not @@ Path.Local.is_root p)
+        then
+          parent_dirs (Option.value_exn parent)
+          @@ Path.Local.Set.add dirs (Option.value_exn parent)
+        else dirs
+      in
+      let open Result.O in
+      let* files = collect dir local in
+      let parent_dirs =
+        Path.Local.Map.foldi files ~init:Path.Local.Set.empty ~f:(fun dir _ dirs ->
+          parent_dirs dir dirs)
+      in
+      Path.Local.Set.fold parent_dirs ~init:files ~f:(fun parent_dir files ->
+        if not @@ Path.Local.Map.mem files parent_dir
+        then Path.Local.Map.add_exn files parent_dir Filename.Map.empty
+        else files)
+      |> Result.ok
     in
     let directory root dirname =
       let open Result.O in

diff --git a/test/blackbox-tests/test-cases/directory-targets/github10609/run.t b/test/blackbox-tests/test-cases/directory-targets/github10609/run.t
@@ -20,5 +20,5 @@ properly promoted.
   > EOF
 
   $ dune build node_modules
-  $ ls node_modules
-  node-cmake
+  $ ls node_modules/node-cmake/node_modules/ansi-regex
+  index.js