Address feedback plus some clean up

Signed-off-by: Andrey Mokhov <[email protected]>

Author: snowleopard

bin/exec.ml

@@ -72,10 +72,11 @@ let term =
       let not_found () =
         let open Memo.Build.O in
         let+ hints =
-          (* CR-someday amokhov: Currently we do not provide hints for directory
-             targets but it would be nice to do that. *)
           (* Good candidates for the "./x.exe" instead of "x.exe" error are
-             executables present in the current directory *)
+             executables present in the current directory. Note: we do not check
+             directory targets here; even if they do indeed include a matching
+             executable, they would be located in a subdirectory of [dir], so
+             it's unclear if that's what the user wanted. *)
           let+ candidates =
             Build_system.file_targets_of ~dir:(Path.build dir)
             >>| Path.Set.to_list

otherlibs/stdune-unstable/path.ml

@@ -686,6 +686,12 @@ module Build = struct
     | None ->
       Code_error.raise "Path.Build.drop_build_context_exn" [ ("t", to_dyn t) ]
 
+  let drop_build_context_maybe_sandboxed_exn t =
+    match extract_build_context_dir_maybe_sandboxed t with
+    | Some (_, t) -> t
+    | None ->
+      Code_error.raise "Path.Build.drop_build_context_maybe_sandboxed_exn" [ ("t", to_dyn t) ]
+
   let build_dir = Fdecl.create Kind.to_dyn
 
   let build_dir_prefix = Fdecl.create Dyn.Encoder.opaque

otherlibs/stdune-unstable/path.mli

@@ -156,6 +156,8 @@ module Build : sig
 
   val drop_build_context_exn : t -> Source.t
 
+  val drop_build_context_maybe_sandboxed_exn : t -> Source.t
+
   (** [Source.t] here is a lie in some cases: consider when the context name
       happens to be ["install"] or [".alias"]. *)
   val extract_build_context : t -> (string * Source.t) option

otherlibs/stdune-unstable/user_error.ml

@@ -68,13 +68,13 @@ let has_embedded_location annots =
   List.exists annots ~f:(fun annot ->
       Annot.Has_embedded_location.check annot (fun () -> true) (fun () -> false))
 
+let has_location (msg : User_message.t) annots =
+  (not (is_loc_none msg.loc)) || has_embedded_location annots
+
 let needs_stack_trace annots =
   List.exists annots ~f:(fun annot ->
       Annot.Needs_stack_trace.check annot (fun () -> true) (fun () -> false))
 
-let has_location (msg : User_message.t) annots =
-  (not (is_loc_none msg.loc)) || has_embedded_location annots
-
 let () =
   Printexc.register_printer (function
     | E (t, []) -> Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t))

src/dune_engine/action_builder.ml

@@ -185,8 +185,8 @@ module With_targets = struct
     | xs ->
       let build, targets =
         List.fold_left xs ~init:([], Targets.empty)
-          ~f:(fun (acc_build, acc_targets) x ->
-            (x.build :: acc_build, Targets.combine acc_targets x.targets))
+          ~f:(fun (builds, targets) x ->
+            (x.build :: builds, Targets.combine x.targets targets))
       in
       { build = all (List.rev build); targets }
 

src/dune_engine/build_system.ml

@@ -1543,7 +1543,7 @@ end = struct
 
   module Exec_result = struct
     type t =
-      { paths_in_directory_targets : Path.Build.Set.t
+      { files_in_directory_targets : Path.Build.Set.t
       ; action_exec_result : Action_exec.Exec_result.t
       }
   end
@@ -1601,13 +1601,13 @@ end = struct
             Action_exec.exec ~root ~context ~env ~targets ~rule_loc:loc
               ~build_deps ~execution_parameters action
           in
-          let paths_in_directory_targets =
+          let files_in_directory_targets =
             match sandbox with
             | None -> Path.Build.Set.empty
             | Some sandbox ->
               Sandbox.move_targets_to_build_dir sandbox ~loc ~targets
           in
-          { Exec_result.paths_in_directory_targets; action_exec_result })
+          { Exec_result.files_in_directory_targets; action_exec_result })
     in
     Option.iter sandbox ~f:Sandbox.destroy;
     (* All went well, these targets are no longer pending *)
@@ -1977,7 +1977,7 @@ end = struct
                   | _ ->
                     let targets =
                       Path.Build.Set.union file_targets
-                        exec_result.paths_in_directory_targets
+                        exec_result.files_in_directory_targets
                     in
                     Fiber.return
                       (compute_target_digests_or_raise_error

src/dune_engine/rule.ml

@@ -101,36 +101,39 @@ let make ?(sandbox = Sandbox_config.default) ?(mode = Mode.Standard) ~context
                (action, deps))
          })
   in
-  match Targets.validate targets with
-  | No_targets -> (
-    match info with
-    | From_dune_file loc ->
-      User_error.raise ~loc [ Pp.text "Rule has no targets specified" ]
-    | Internal
-    | Source_file_copy _ ->
-      Code_error.raise "Rule.Targets: An internal rule with no targets" [])
-  | Inconsistent_parent_dir -> (
-    match info with
-    | From_dune_file loc ->
-      User_error.raise ~loc
-        [ Pp.text "Rule has targets in different directories.\nTargets:"
-        ; Targets.pp targets
-        ]
-    | Internal
-    | Source_file_copy _ ->
-      Code_error.raise "Rule has targets in different directories"
-        [ ("targets", Targets.to_dyn targets) ])
-  | Valid { parent_dir = dir } ->
-    let loc =
+  let dir =
+    match Targets.validate targets with
+    | Valid { parent_dir } -> parent_dir
+    | No_targets -> (
       match info with
-      | From_dune_file loc -> loc
-      | Internal ->
-        Loc.in_file
-          (Path.drop_optional_build_context
-             (Path.build (Path.Build.relative dir "_unknown_")))
-      | Source_file_copy p -> Loc.in_file (Path.source p)
-    in
-    { id = Id.gen (); targets; context; action; mode; info; loc; dir }
+      | From_dune_file loc ->
+        User_error.raise ~loc [ Pp.text "Rule has no targets specified" ]
+      | Internal
+      | Source_file_copy _ ->
+        Code_error.raise "Rule.Targets: An internal rule with no targets" [])
+    | Inconsistent_parent_dir -> (
+      match info with
+      | From_dune_file loc ->
+        User_error.raise ~loc
+          [ Pp.text "Rule has targets in different directories.\nTargets:"
+          ; Targets.pp targets
+          ]
+      | Internal
+      | Source_file_copy _ ->
+        Code_error.raise
+          "Rule.Targets: An internal rule has targets in different directories"
+          [ ("targets", Targets.to_dyn targets) ])
+  in
+  let loc =
+    match info with
+    | From_dune_file loc -> loc
+    | Internal ->
+      Loc.in_file
+        (Path.drop_optional_build_context
+           (Path.build (Path.Build.relative dir "_unknown_")))
+    | Source_file_copy p -> Loc.in_file (Path.source p)
+  in
+  { id = Id.gen (); targets; context; action; mode; info; loc; dir }
 
 let set_action t action =
   let action = Action_builder.memoize "Rule.set_action" action in

src/dune_engine/sandbox.ml

@@ -115,22 +115,35 @@ let rename_optional_file ~src ~dst =
 (* Recursively move regular files from [src] to [dst] and return the set of
    moved files. *)
 let rename_dir_recursively ~loc ~src_dir ~dst_dir =
-  let rec loop ~src ~dst ~dst_parent =
-    (match Fpath.mkdir dst with
+  let rec loop ~src_dir ~dst_dir =
+    (match Fpath.mkdir (Path.Build.to_string dst_dir) with
     | Created -> ()
-    | Already_exists -> (* CR-someday amokhov: Should we clear it? *) ()
+    | Already_exists ->
+      User_error.raise ~loc
+        ~annots:[ User_error.Annot.Needs_stack_trace.make () ]
+        [ Pp.textf
+            "This rule defines a directory target %S whose name conflicts with \
+             an internal directory used by Dune. Please use a different name."
+            (Path.Build.drop_build_context_exn dst_dir
+            |> Path.Source.to_string_maybe_quoted)
+        ]
     | Missing_parent_directory -> assert false);
-    match Dune_filesystem_stubs.read_directory_with_kinds src with
+    match
+      Dune_filesystem_stubs.read_directory_with_kinds
+        (Path.Build.to_string src_dir)
+    with
     | Ok files ->
       List.concat_map files ~f:(fun (file, kind) ->
-          let src = Filename.concat src file in
-          let dst = Filename.concat dst file in
           match (kind : Dune_filesystem_stubs.File_kind.t) with
           | S_REG ->
-            Unix.rename src dst;
-            [ Path.Build.relative dst_parent file ]
+            let src = Path.Build.relative src_dir file in
+            let dst = Path.Build.relative dst_dir file in
+            Unix.rename (Path.Build.to_string src) (Path.Build.to_string dst);
+            [ dst ]
           | S_DIR ->
-            loop ~src ~dst ~dst_parent:(Path.Build.relative dst_parent file)
+            loop
+              ~src_dir:(Path.Build.relative src_dir file)
+              ~dst_dir:(Path.Build.relative dst_dir file)
           | _ ->
             User_error.raise ~loc
               [ Pp.textf "Rule produced a file with unrecognised kind %S"
@@ -139,31 +152,27 @@ let rename_dir_recursively ~loc ~src_dir ~dst_dir =
     | Error (ENOENT, _, _) ->
       User_error.raise ~loc
         [ Pp.textf "Rule failed to produce directory %S"
-            (Path.of_string src
-           |> Path.drop_optional_build_context_maybe_sandboxed
-           |> Path.to_string_maybe_quoted)
+            (Path.Build.drop_build_context_maybe_sandboxed_exn src_dir
+            |> Path.Source.to_string_maybe_quoted)
         ]
     | Error (unix_error, _, _) ->
       User_error.raise ~loc
         [ Pp.textf "Rule produced unreadable directory %S"
-            (Path.of_string src
-           |> Path.drop_optional_build_context_maybe_sandboxed
-           |> Path.to_string_maybe_quoted)
+            (Path.Build.drop_build_context_maybe_sandboxed_exn src_dir
+            |> Path.Source.to_string_maybe_quoted)
         ; Pp.verbatim (Unix.error_message unix_error)
         ]
   in
-  loop
-    ~src:(Path.Build.to_string src_dir)
-    ~dst:(Path.Build.to_string dst_dir)
-    ~dst_parent:dst_dir
-  |> Path.Build.Set.of_list
+  loop ~src_dir ~dst_dir |> Path.Build.Set.of_list
 
 let move_targets_to_build_dir t ~loc ~targets =
-  Targets.to_list_map targets
-    ~file:(fun target ->
-      rename_optional_file ~src:(map_path t target) ~dst:target)
-    ~dir:(fun target ->
-      rename_dir_recursively ~loc ~src_dir:(map_path t target) ~dst_dir:target)
-  |> snd |> Path.Build.Set.union_all
+  let (_file_targets_renamed : unit list), files_moved_in_directory_targets =
+    Targets.to_list_map targets
+      ~file:(fun target ->
+        rename_optional_file ~src:(map_path t target) ~dst:target)
+      ~dir:(fun target ->
+        rename_dir_recursively ~loc ~src_dir:(map_path t target) ~dst_dir:target)
+  in
+  Path.Build.Set.union_all files_moved_in_directory_targets
 
 let destroy t = Path.rm_rf (Path.build t.dir)

src/dune_engine/sandbox.mli

@@ -20,7 +20,7 @@ val create :
   -> t
 
 (** Move the targets created by the action from the sandbox to the build
-    directory. Returns the set of paths discovered in directory targets. *)
+    directory. Returns the set of files discovered in directory targets. *)
 val move_targets_to_build_dir :
   t -> loc:Loc.t -> targets:Targets.t -> Path.Build.Set.t
 

test/blackbox-tests/test-cases/directory-targets.t/run.t

@@ -315,3 +315,48 @@ and the second one because of the lack of early cutoff.
   running
           bash contents
   running
+
+Check that Dune clears stale files from directory targets.
+
+  $ cat > dune <<EOF
+  > (rule
+  >   (deps src_a src_b src_c (sandbox always))
+  >   (targets output/*)
+  >   (action (bash "echo running; mkdir -p output/subdir; cat src_a > output/new-a; cat src_b > output/subdir/b")))
+  > (rule
+  >   (deps output)
+  >   (target contents)
+  >   (action (bash "echo running; echo 'new-a:' > contents; cat output/new-a >> contents; echo 'b:' >> contents; cat output/subdir/b >> contents")))
+  > EOF
+
+  $ dune build contents
+          bash output
+  running
+          bash contents
+  running
+
+Note that the stale "output/a" file got removed.
+
+  $ ls _build/default/output | sort
+  new-a
+  subdir
+
+Directory target whose name conflicts with an internal directory used by Dune.
+
+  $ cat > dune <<EOF
+  > (rule
+  >   (deps (sandbox always))
+  >   (targets .dune/*)
+  >   (action (bash "mkdir .dune; echo hello > .dune/hello")))
+  > EOF
+
+  $ dune build .dune/hello
+  File "dune", line 1, characters 0-110:
+  1 | (rule
+  2 |   (deps (sandbox always))
+  3 |   (targets .dune/*)
+  4 |   (action (bash "mkdir .dune; echo hello > .dune/hello")))
+  Error: This rule defines a directory target ".dune" whose name conflicts with
+  an internal directory used by Dune. Please use a different name.
+  -> required by _build/default/.dune/hello
+  [1]