Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix promotion of directory targets without files in them #11203

Closed
wants to merge 1 commit into from
+71 −29
Closed

Fix promotion of directory targets without files in them #11203

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
77 changes: 48 additions & 29 deletions src/dune_targets/dune_targets.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -217,35 +217,54 @@ 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
if not (Filename.Map.is_empty filenames)
then Path.Local.Map.add_exn dirs local filenames
else dirs
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 path dirs =
match Path.Local.parent path with
| Some p when Path.Local.is_root p -> dirs
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is it a problem that this doesn't stop at the root of the project/workspace?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Or does it stop at the project root? I notice that the Path.Local module treats "." as the root so perhaps in practice this traversal never goes above the project root since the current directory will be somewhere in the project. If this is the case I think it deserves a comment explaining it, especially since my first instinct as a reader is to assume that Path.Local.is_root checks whether a path is "/" rather than ".".

| Some parent -> parent_dirs parent @@ Path.Local.Set.add dirs parent
| None -> 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 ->
Path.Local.Map.update files parent_dir ~f:(function
| Some _ as x -> x
| None -> Some Filename.Map.empty))
|> Result.ok
in
let directory root dirname =
let open Result.O in
Expand Down
23 changes: 23 additions & 0 deletions test/blackbox-tests/test-cases/directory-targets/github10609/run.t
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,23 @@
We test that a directory target with only other subdirs can be
properly promoted.

$ cat > dune-project <<EOF
> (lang dune 3.16)
> (using directory-targets 0.1)
> EOF

$ cat > dune <<EOF
> (rule
> (targets (dir foo))
> (mode (promote (until-clean)))
> (action
> (progn
> (run mkdir -p foo/bar)
> (run touch foo/bar/file1)
> (run mkdir -p foo/bar/baz/qux)
> (run touch foo/bar/baz/qux/file2))))
> EOF

$ dune build foo
$ ls foo/bar/baz/qux
file2
Loading