Refactor Dune_engine.Targets

src/dune_engine/build_system.ml

@@ -307,6 +307,15 @@ end = struct
         ; attached_to_alias : bool
         }
 
+  let maybe_async_rule_file_op f =
+    (* It would be nice to do this check only once and return a function, but the
+       type of this function would need to be polymorphic which is forbidden by
+       the relaxed value restriction. *)
+    match Config.(get background_file_system_operations_in_rule_execution) with
+    | `Enabled -> Scheduler.async_exn f
+    | `Disabled -> Fiber.return (f ())
+  ;;
+
   let execute_action_for_rule
     ~rule_kind
     ~rule_digest
@@ -363,7 +372,7 @@ end = struct
         else Action.progn [ action; Action.write_file stamp_file "" ]
     in
     let* () =
-      Targets.maybe_async (fun () ->
+      maybe_async_rule_file_op (fun () ->
         Action.chdirs action
         |> Path.Build.Set.iter ~f:(fun p -> Path.mkdir_p (Path.build p)))
     in
@@ -405,9 +414,9 @@ end = struct
             | Some runner -> Action_runner.exec_action runner input
           in
           let* action_exec_result = Action_exec.Exec_result.ok_exn action_exec_result in
-          let+ produced_targets =
+          let* () =
             match sandbox with
-            | None -> Targets.Produced.produced_after_rule_executed_exn ~loc targets
+            | None -> Fiber.return ()
             | Some sandbox ->
               (* The stamp file for anonymous actions is always created outside
                  the sandbox, so we can't move it. *)
@@ -416,9 +425,14 @@ end = struct
                 | Normal_rule -> fun (_ : Path.Build.t) -> false
                 | Anonymous_action { stamp_file; _ } -> Path.Build.equal stamp_file
               in
-              Sandbox.move_targets_to_build_dir sandbox ~loc ~should_be_skipped ~targets
+              Sandbox.move_targets_to_build_dir sandbox ~should_be_skipped ~targets
+          in
+          let+ produced_targets =
+            maybe_async_rule_file_op (fun () -> Targets.Produced.of_validated targets)
           in
-          { Exec_result.produced_targets; action_exec_result }))
+          match produced_targets with
+          | Ok produced_targets -> { Exec_result.produced_targets; action_exec_result }
+          | Error error -> User_error.raise ~loc (Targets.Produced.Error.message error)))
   ;;
 
   let promote_targets ~rule_mode ~dir ~targets ~promote_source =
@@ -467,7 +481,7 @@ end = struct
     wrap_fiber (fun () ->
       let open Fiber.O in
       report_evaluated_rule_exn config;
-      let* () = Targets.maybe_async (fun () -> Path.mkdir_p (Path.build dir)) in
+      let* () = maybe_async_rule_file_op (fun () -> Path.mkdir_p (Path.build dir)) in
       let is_action_dynamic = Action.is_dynamic action.action in
       let sandbox_mode =
         select_sandbox_mode
@@ -535,7 +549,7 @@ end = struct
             Path.Build.Set.iter targets.dirs ~f:Cached_digest.remove
           in
           let* () =
-            Targets.maybe_async (fun () ->
+            maybe_async_rule_file_op (fun () ->
               Path.Build.Set.iter targets.files ~f:Path.Build.unlink_no_err;
               Path.Build.Set.iter targets.dirs ~f:(fun dir -> Path.rm_rf (Path.build dir)))
           in

src/dune_engine/rule_cache.ml

@@ -108,7 +108,7 @@ module Workspace_local = struct
       | Targets_missing
       | Dynamic_deps_changed
       | Always_rerun
-      | Error_while_collecting_directory_targets of Unix_error.Detailed.t
+      | Error_while_collecting_directory_targets of Targets.Produced.Error.t
 
     let report ~head_target reason =
       let reason =
@@ -123,10 +123,10 @@ module Workspace_local = struct
         | Targets_changed -> "target changed in build dir"
         | Always_rerun -> "not trying to use the cache"
         | Dynamic_deps_changed -> "dynamic dependencies changed"
-        | Error_while_collecting_directory_targets unix_error ->
+        | Error_while_collecting_directory_targets error ->
           sprintf
             "error while collecting directory targets: %s"
-            (Unix_error.Detailed.to_string_hum unix_error)
+            (Targets.Produced.Error.to_string_hum error)
       in
       Console.print_user_message
         (User_message.make
@@ -143,15 +143,14 @@ module Workspace_local = struct
     : (Digest.t Targets.Produced.t, Miss_reason.t) Result.t
     =
     match Targets.Produced.of_validated targets with
-    | Error (_, unix_error) -> Miss (Error_while_collecting_directory_targets unix_error)
+    | Error error -> Miss (Error_while_collecting_directory_targets error)
     | Ok targets ->
       (match
-         Targets.Produced.Option.mapi targets ~f:(fun target () ->
-           Cached_digest.build_file ~allow_dirs:true target
-           |> Cached_digest.Digest_result.to_option)
+         Targets.Produced.collect_digests targets ~all_errors:false ~f:(fun target () ->
+           Cached_digest.build_file ~allow_dirs:true target)
        with
-       | Some produced_targets -> Hit produced_targets
-       | None -> Miss Targets_missing)
+       | Ok produced_targets -> Hit produced_targets
+       | Error _ -> Miss Targets_missing)
   ;;
 
   let lookup_impl ~rule_digest ~targets ~env ~build_deps =

src/dune_engine/sandbox.ml

@@ -244,53 +244,6 @@ let rename_optional_file ~src ~dst =
      | () -> ())
 ;;
 
-(* Recursively collect regular files from [src] to [dst] and return the set of
-   of files collected. *)
-let collect_dir_recursively ~loc ~src_dir ~dst_dir =
-  let rec loop ~src_dir ~dst_dir =
-    match
-      Dune_filesystem_stubs.read_directory_with_kinds (Path.Build.to_string src_dir)
-    with
-    | Ok files ->
-      List.map files ~f:(fun (file, kind) ->
-        match (kind : File_kind.t) with
-        | S_LNK
-          (* TODO symlinks outside of the sandbox are going to be broken,
-             but users shouldn't be doing this anyway. *)
-        | S_REG -> Appendable_list.singleton (dst_dir, file)
-        | S_DIR ->
-          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"
-                (File_kind.to_string kind)
-            ])
-      |> Appendable_list.concat
-    | Error (ENOENT, _, _) ->
-      User_error.raise
-        ~loc
-        [ Pp.textf
-            "Rule failed to produce directory %S"
-            (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.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_dir ~dst_dir
-;;
-
 let apply_changes_to_source_tree t ~old_snapshot =
   let new_snapshot = snapshot t in
   (* Same as promotion: make the file writable when copying to the source
@@ -329,45 +282,39 @@ let hint_delete_dir =
   ]
 ;;
 
-let move_targets_to_build_dir t ~loc ~should_be_skipped ~(targets : Targets.Validated.t)
-  : unit Targets.Produced.t Fiber.t
+let move_targets_to_build_dir t ~should_be_skipped ~(targets : Targets.Validated.t)
+  : unit Fiber.t
   =
   maybe_async (fun () ->
     Option.iter t.snapshot ~f:(fun old_snapshot ->
       apply_changes_to_source_tree t ~old_snapshot);
     Path.Build.Set.iter targets.files ~f:(fun target ->
       if not (should_be_skipped target)
       then rename_optional_file ~src:(map_path t target) ~dst:target);
-    let discovered_targets =
-      Path.Build.Set.to_list_map targets.dirs ~f:(fun target ->
-        let src_dir = map_path t target in
-        let files = collect_dir_recursively ~loc ~src_dir ~dst_dir:target in
-        (match Path.Untracked.stat (Path.build target) with
-         | Error (Unix.ENOENT, _, _) -> ()
-         | Error e ->
-           User_error.raise
-             ~hints:hint_delete_dir
-             [ Pp.textf "unable to stat %s" (Path.Build.to_string_maybe_quoted target)
-             ; Pp.text "reason:"
-             ; Pp.text (Unix_error.Detailed.to_string_hum e)
-             ]
-         | Ok { Unix.st_kind; _ } ->
-           (* We clean up all targets (including directory targets) before
-              running an action, so this branch should be unreachable unless
-              the rule somehow escaped the sandbox *)
-           User_error.raise
-             ~hints:hint_delete_dir
-             [ Pp.textf
-                 "Target %s of kind %S already exists in the build directory"
-                 (Path.Build.to_string_maybe_quoted target)
-                 (File_kind.to_string_hum st_kind)
-             ]);
-        Path.rename (Path.build src_dir) (Path.build target);
-        files)
-      |> Appendable_list.concat
-      |> Appendable_list.to_list
-    in
-    Targets.Produced.expand_validated_exn targets discovered_targets)
+    Path.Build.Set.iter targets.dirs ~f:(fun target ->
+      let src_dir = map_path t target in
+      (match Path.Untracked.stat (Path.build target) with
+       | Error (Unix.ENOENT, _, _) -> ()
+       | Error e ->
+         User_error.raise
+           ~hints:hint_delete_dir
+           [ Pp.textf "unable to stat %s" (Path.Build.to_string_maybe_quoted target)
+           ; Pp.text "reason:"
+           ; Pp.text (Unix_error.Detailed.to_string_hum e)
+           ]
+       | Ok { Unix.st_kind; _ } ->
+         (* We clean up all targets (including directory targets) before
+            running an action, so this branch should be unreachable unless
+            the rule somehow escaped the sandbox *)
+         User_error.raise
+           ~hints:hint_delete_dir
+           [ Pp.textf
+               "Target %s of kind %S already exists in the build directory"
+               (Path.Build.to_string_maybe_quoted target)
+               (File_kind.to_string_hum st_kind)
+           ]);
+      if Path.Untracked.exists (Path.build src_dir)
+      then Path.rename (Path.build src_dir) (Path.build target)))
 ;;
 
 let failed_to_delete_sandbox dir reason =

src/dune_engine/sandbox.mli

@@ -26,9 +26,8 @@ val create
     Expands [targets] with the set of files discovered in directory targets. *)
 val move_targets_to_build_dir
   :  t
-  -> loc:Loc.t
   -> should_be_skipped:(Path.Build.t -> bool)
   -> targets:Targets.Validated.t
-  -> unit Targets.Produced.t Fiber.t
+  -> unit Fiber.t
 
 val destroy : t -> unit Fiber.t