Address feedback plus some clean up

Signed-off-by: Andrey Mokhov <[email protected]>
ocaml · Oct 25, 2021 · a6eec30 · a6eec30
1 parent af76741
commit a6eec30
Show file tree

Hide file tree

Showing 6 changed files with 143 additions and 79 deletions.
diff --git a/bin/exec.ml b/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

diff --git a/otherlibs/stdune-unstable/user_error.ml b/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))

diff --git a/src/dune_engine/action_builder.ml b/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 }
 

diff --git a/src/dune_engine/rule.ml b/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

diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml
@@ -114,49 +114,64 @@ 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
-    | Created -> ()
-    | Already_exists -> (* CR-someday amokhov: Should we clear it? *) ()
-    | Missing_parent_directory -> assert false);
-    match Dune_filesystem_stubs.read_directory_with_kinds src 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 ]
-          | S_DIR ->
-            loop ~src ~dst ~dst_parent:(Path.Build.relative dst_parent file)
-          | _ ->
-            User_error.raise ~loc
-              [ Pp.textf "Rule produced a file with unrecognised kind %S"
-                  (Dune_filesystem_stubs.File_kind.to_string kind)
-              ])
-    | 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)
-        ]
-    | 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)
-        ; Pp.verbatim (Unix.error_message unix_error)
-        ]
+let rename_dir_recursively =
+  let dst_dir_to_string ~dst_dir =
+    Path.Build.drop_build_context_exn dst_dir
+    |> Path.Source.to_string_maybe_quoted
   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
+  let src_dir_to_string ~src_dir =
+    Path.Build.to_string src_dir
+    |> Path.of_string |> Path.drop_optional_build_context_maybe_sandboxed
+    |> Path.to_string_maybe_quoted
+  in
+  fun ~loc ~src_dir ~dst_dir ->
+    let rec loop ~src_dir ~dst_dir =
+      (match Fpath.mkdir (Path.Build.to_string dst_dir) with
+      | Created -> ()
+      | 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."
+              (dst_dir_to_string ~dst_dir)
+          ]
+      | Missing_parent_directory -> assert false);
+      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) ->
+            match (kind : Dune_filesystem_stubs.File_kind.t) with
+            | S_REG ->
+              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 ->
+              let src_dir = Path.Build.relative src_dir file in
+              let dst_dir = Path.Build.relative dst_dir file in
+              loop ~src_dir ~dst_dir
+            | _ ->
+              User_error.raise ~loc
+                [ Pp.textf "Rule produced a file with unrecognised kind %S"
+                    (Dune_filesystem_stubs.File_kind.to_string kind)
+                ])
+      | Error (ENOENT, _, _) ->
+        User_error.raise ~loc
+          [ Pp.textf "Rule failed to produce directory %S"
+              (src_dir_to_string ~src_dir)
+          ]
+      | Error (unix_error, _, _) ->
+        User_error.raise ~loc
+          [ Pp.textf "Rule produced unreadable directory %S"
+              (src_dir_to_string ~src_dir)
+          ; Pp.verbatim (Unix.error_message unix_error)
+          ]
+    in
+    loop ~src_dir ~dst_dir |> Path.Build.Set.of_list
 
 let move_targets_to_build_dir t ~loc ~targets =
   Targets.to_list_map targets

diff --git a/test/blackbox-tests/test-cases/directory-targets.t/run.t b/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]