Revert "refactor(rules): remove support for patch back into source tree (#10771)"

This reverts commit ebc7035.

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

src/dune_engine/diff_promotion.ml

@@ -90,7 +90,16 @@ module File = struct
   ;;
 end
 
-type db = File.t list
+type op =
+  | File of File.t
+  | Delete of Path.Source.t
+
+let dyn_of_op = function
+  | File f -> Dyn.variant "File" [ File.to_dyn f ]
+  | Delete d -> Dyn.variant "Delete" [ Path.Source.to_dyn d ]
+;;
+
+type db = op list
 
 let db : db ref = ref []
 let clear_cache () = db := []
@@ -100,7 +109,7 @@ let register_dep ~source_file ~correction_file =
   let src = snd (Path.Build.split_sandbox_root correction_file) in
   Dune_trace.emit Promote (fun () ->
     Dune_trace.Event.Promote.register `Direct src source_file);
-  db := { src; staging = None; dst = source_file } :: !db
+  db := File { src; staging = None; dst = source_file } :: !db
 ;;
 
 let register_intermediate ~source_file ~correction_file =
@@ -110,28 +119,30 @@ let register_intermediate ~source_file ~correction_file =
   let staging = File.in_staging_area source_file in
   Path.mkdir_p (Path.build (Option.value_exn (Path.Build.parent staging)));
   Unix.rename (Path.Build.to_string correction_file) (Path.Build.to_string staging);
-  db := { src; staging = Some staging; dst = source_file } :: !db
+  db := File { src; staging = Some staging; dst = source_file } :: !db
 ;;
 
 module P = Persistent.Make (struct
-    type t = File.t list
+    type t = db
 
     let name = "TO-PROMOTE"
-    let version = 3
-    let to_dyn = Dyn.list File.to_dyn
+    let version = 4
+    let to_dyn = Dyn.list dyn_of_op
 
     let test_example () =
-      [ { File.src = Path.Build.(relative root "foo")
-        ; dst = Path.Source.of_string "bar"
-        ; staging = Some Path.Build.(relative root "baz")
-        }
+      [ File
+          { File.src = Path.Build.(relative root "foo")
+          ; dst = Path.Source.of_string "bar"
+          ; staging = Some Path.Build.(relative root "baz")
+          }
+      ; Delete (Path.Source.of_string "foo")
       ]
     ;;
   end)
 
 let db_file = Path.relative Path.build_dir ".to-promote"
 
-let dump_db db =
+let dump_db (db : db) =
   if Path.build_dir_exists ()
   then (
     match db with
@@ -143,43 +154,54 @@ let dump_db db =
 let load_db () = Option.value ~default:[] (P.load db_file)
 
 let group_by_targets db =
-  List.map db ~f:(fun { File.src; staging; dst } -> dst, (src, staging))
+  List.map db ~f:(fun op ->
+    match op with
+    | Delete f -> f, `Delete
+    | File { File.src; staging; dst } -> dst, `Promote (src, staging))
   |> Path.Source.Map.of_list_multi
   (* Sort the list of possible sources for deterministic behavior *)
-  |> Path.Source.Map.map
-       ~f:(List.sort ~compare:(fun (x, _) (y, _) -> Path.Build.compare x y))
+  |> Path.Source.Map.map ~f:(List.sort ~compare:Poly.compare)
 ;;
 
 let promote_one dst srcs =
   match srcs with
   | [] -> assert false
-  | (src, staging) :: others ->
+  | op :: others ->
     (* We used to remove promoted files from the digest cache, to force Dune
-         to redigest them on the next run. We did this because on OSX [mtime] is
-         not precise enough and if a file is modified and promoted quickly, it
-         looked like it hadn't changed even though it might have.
-
-         aalekseyev: This is probably unnecessary now, depending on when
-         [do_promote] runs (before or after [invalidate_cached_timestamps]).
-
-         amokhov: I removed this logic. In the current state of the world, files
-         in the build directory should be redigested automatically (plus we do
-         not promote into the build directory anyway), and source digests should
-         be correctly invalidated via [fs_memo]. If that doesn't happen, we
-         should fix [fs_memo] instead of manually resetting the caches here. *)
-    File.promote { src; staging; dst };
-    List.iter others ~f:(fun (path, _staging) ->
+       to redigest them on the next run. We did this because on OSX [mtime] is
+       not precise enough and if a file is modified and promoted quickly, it
+       looked like it hadn't changed even though it might have.
+
+       aalekseyev: This is probably unnecessary now, depending on when
+       [do_promote] runs (before or after [invalidate_cached_timestamps]).
+
+       amokhov: I removed this logic. In the current state of the world, files
+       in the build directory should be redigested automatically (plus we do
+       not promote into the build directory anyway), and source digests should
+       be correctly invalidated via [fs_memo]. If that doesn't happen, we
+       should fix [fs_memo] instead of manually resetting the caches here. *)
+    (match op with
+     | `Promote (src, staging) -> File.promote { src; staging; dst }
+     | `Delete -> Unix.unlink (Path.Source.to_string dst));
+    List.iter others ~f:(fun op ->
+      let path =
+        match op with
+        | `Promote (src, _) -> Path.build src
+        | `Delete -> Path.source dst
+      in
       Console.print
-        [ Pp.textf " -> ignored %s." (Path.to_string_maybe_quoted (Path.build path))
-        ; Pp.space
-        ])
+        [ Pp.textf " -> ignored %s." (Path.to_string_maybe_quoted path); Pp.space ])
 ;;
 
 let do_promote_all db = group_by_targets db |> Path.Source.Map.iteri ~f:promote_one
 
 let do_promote_these db files =
   let by_targets = group_by_targets db in
-  let by_targets, missing =
+  let ( (by_targets :
+          [> `Delete | `Promote of Path.Build.t * Path.Build.t option ] list
+            Path.Source.Map.t)
+      , missing )
+    =
     let files = Path.Source.Set.of_list files in
     Path.Source.Set.fold files ~init:(by_targets, []) ~f:(fun fn (map, missing) ->
       match Path.Source.Map.find map fn with
@@ -190,8 +212,10 @@ let do_promote_these db files =
   in
   let remaining =
     Path.Source.Map.to_list by_targets
-    |> List.concat_map ~f:(fun (dst, srcs) ->
-      List.map srcs ~f:(fun (src, staging) -> { File.src; staging; dst }))
+    |> List.concat_map ~f:(fun (dst, ops) ->
+      List.map ops ~f:(function
+        | `Delete -> Delete dst
+        | `Promote (src, staging) -> File { File.src; staging; dst }))
   in
   (* [group_by_targets] will sort all files, but the [fold] above reverses
      the list of missing files. Here we re-reverse it so it is sorted.
@@ -236,7 +260,13 @@ type all =
 (** [partition_db db files_to_promote] splits [files_to_promote] into two lists
     - The files present in [db] as actual [File.t]s.
     - The files absent from [db] as [Path]s. *)
-let partition_db db files_to_promote =
+let partition_db (db : db) files_to_promote =
+  let db =
+    (* CR-soon rgrinberg: communicate deletions to the user *)
+    List.filter_map db ~f:(function
+      | File f -> Some f
+      | Delete _ -> None)
+  in
   let present, missing =
     match files_to_promote with
     | Files_to_promote.All -> db, []
@@ -248,3 +278,5 @@ let partition_db db files_to_promote =
   in
   { present; missing }
 ;;
+
+let register_delete src = db := Delete src :: !db

src/dune_engine/diff_promotion.mli

@@ -51,3 +51,5 @@ val register_intermediate
     refers to a path in the build dir, not in the sandbox (it can point to the
     sandbox, but the sandbox root will be stripped). *)
 val register_dep : source_file:Path.Source.t -> correction_file:Path.Build.t -> unit
+
+val register_delete : Path.Source.t -> unit

src/dune_engine/sandbox.ml

@@ -181,26 +181,7 @@ let create ~mode ~rule_loc ~dirs ~deps ~rule_dir ~rule_digest =
   in
   Option.iter dune_stats ~f:(fun trace -> Dune_trace.Out.finish trace event);
   match mode with
-  | Patch_back_source_tree ->
-    (* Only supported on Linux because we rely on the mtime changing to detect
-       when a file changes. This doesn't work on OSX for instance as the file
-       system granularity is 1s, which is too coarse. *)
-    (match Platform.OS.value with
-     | Linux -> ()
-     | _ ->
-       User_error.raise
-         ~loc:rule_loc
-         [ Pp.textf
-             "(mode patch-back-source-tree) is only supported on Linux at the moment."
-         ]);
-    (* We expect this call to [snapshot t] to return the same set of files as
-       [deps], given that's exactly what we just copied in the sandbox. So in
-       theory, we could iterate over [deps] rather than scan the file system.
-       However, the code is simpler if we just call [snapshot t] before and
-       after running the action. Given that [patch_back_source_tree] is a dodgy
-       feature that we hope to get rid of in the long run, we favor code
-       simplicity over performance. *)
-    { t with snapshot = Some (snapshot t) }
+  | Patch_back_source_tree -> { t with snapshot = Some (snapshot t) }
   | _ -> t
 ;;
 
@@ -217,35 +198,38 @@ let rename_optional_file ~src ~dst =
      | () -> ())
 ;;
 
-let apply_changes_to_source_tree t ~old_snapshot =
+let apply_changes_to_source_tree t (targets : Targets.Validated.t) ~old_snapshot =
   let new_snapshot = snapshot t in
   (* Same as promotion: make the file writable when copying to the source
      tree. *)
   let in_source_tree p =
-    Path.extract_build_context_dir_maybe_sandboxed p
-    |> Option.value_exn
-    |> snd
-    |> Path.source
+    Path.extract_build_context_dir_maybe_sandboxed p |> Option.value_exn |> snd
   in
   let copy_file p =
-    let in_source_tree = in_source_tree p in
-    Fpath.unlink_no_err (Path.to_string in_source_tree);
-    Option.iter (Path.parent in_source_tree) ~f:Path.mkdir_p;
-    Io.copy_file ~src:p ~dst:in_source_tree ()
-  in
-  let delete_file p =
-    let in_source_tree = in_source_tree p in
-    Fpath.unlink_no_err (Path.to_string in_source_tree)
+    let source_file = in_source_tree p in
+    let correction_file = Path.as_in_build_dir_exn p in
+    Diff_promotion.register_intermediate ~source_file ~correction_file
   in
+  let delete_file file = in_source_tree file |> Diff_promotion.register_delete in
+  (* CR-soon rgrinberg: handle deleting directories *)
+  let target_root_in_sandbox = map_path t targets.root in
   Path.Map.iter2 old_snapshot new_snapshot ~f:(fun p before after ->
-    match before, after with
-    | None, None -> assert false
-    | None, Some _ -> copy_file p
-    | Some _, None -> delete_file p
-    | Some before, Some after ->
-      (match Cached_digest.Reduced_stats.compare before after with
-       | Eq -> ()
-       | Lt | Gt -> copy_file p))
+    if
+      not
+        (let dir = Path.as_in_build_dir_exn (Path.parent_exn p) in
+         Path.Build.equal dir target_root_in_sandbox
+         &&
+         let basename = Path.basename p in
+         Filename.Set.mem targets.files basename || Filename.Set.mem targets.dirs basename)
+    then (
+      match before, after with
+      | None, None -> assert false
+      | None, Some _ -> copy_file p
+      | Some _, None -> delete_file p
+      | Some before, Some after ->
+        (match Cached_digest.Reduced_stats.compare before after with
+         | Eq -> ()
+         | Lt | Gt -> copy_file p)))
 ;;
 
 let hint_delete_dir =
@@ -260,7 +244,7 @@ let move_targets_to_build_dir t ~should_be_skipped ~(targets : Targets.Validated
   =
   maybe_async (fun () ->
     Option.iter t.snapshot ~f:(fun old_snapshot ->
-      apply_changes_to_source_tree t ~old_snapshot);
+      apply_changes_to_source_tree t targets ~old_snapshot);
     Targets.Validated.iter
       targets
       ~file:(fun target ->

src/dune_engine/sandbox_config.ml

@@ -63,6 +63,12 @@ module Partial = struct
       | _ -> None)
   ;;
 
+  let patch_back_source_tree =
+    Sandbox_mode.Dict.of_func (function
+      | Some Patch_back_source_tree -> Some true
+      | _ -> Some false)
+  ;;
+
   let disallow (mode : Sandbox_mode.t) =
     Sandbox_mode.Dict.of_func (fun mode' ->
       if Sandbox_mode.equal mode mode' then Some false else None)

src/dune_engine/sandbox_config.mli

@@ -47,5 +47,6 @@ module Partial : sig
   val no_special_requirements : t
   val no_sandboxing : t
   val needs_sandboxing : t
+  val patch_back_source_tree : t
   val disallow : Sandbox_mode.t -> t
 end

src/dune_lang/dep_conf.ml

@@ -17,26 +17,30 @@ module Glob_files = struct
 end
 
 module Sandbox_config = struct
-  type t = Loc.t * [ `None | `Always | `Preserve_file_kind ] list
-
-  let equal =
-    Tuple.T2.equal
-      Loc.equal
-      (List.equal (fun a b ->
-         match a, b with
-         | `None, `None | `Always, `Always | `Preserve_file_kind, `Preserve_file_kind ->
-           true
-         | _, _ -> false))
-  ;;
+  type mode =
+    [ `None
+    | `Always
+    | `Preserve_file_kind
+    | `Patch_back_source_tree
+    ]
+
+  type t = Loc.t * mode list
+
+  let equal_mode : mode -> mode -> bool = Poly.equal
+  let equal = Tuple.T2.equal Loc.equal (List.equal equal_mode)
 
   let all =
-    [ "none", `None; "always", `Always; "preserve_file_kind", `Preserve_file_kind ]
+    [ "none", `None, (1, 12)
+    ; "always", `Always, (1, 12)
+    ; "preserve_file_kind", `Preserve_file_kind, (1, 12)
+    ; "patch_back_source_tree", `Patch_back_source_tree, (3, 22)
+    ]
   ;;
 
   let loc (loc, _) = loc
 
   let string_of_mode mode =
-    List.find_map all ~f:(fun (s, mode') ->
+    List.find_map all ~f:(fun (s, mode', _) ->
       if Poly.equal mode mode' then Some s else None)
     |> Option.value_exn
   ;;
@@ -46,7 +50,13 @@ module Sandbox_config = struct
   ;;
 
   let decode : t Decoder.t =
-    Syntax.since Stanza.syntax (1, 12) >>> located (repeat (enum all))
+    let all =
+      List.map all ~f:(fun (name, mode, version) ->
+        ( name
+        , let+ () = Syntax.since Stanza.syntax version in
+          mode ))
+    in
+    located (repeat (enum' all))
   ;;
 
   let fold (_, xs) ~f ~init = List.fold_left xs ~init ~f:(fun acc a -> f a acc)

src/dune_lang/dep_conf.mli

@@ -21,7 +21,10 @@ module Sandbox_config : sig
 
   val fold
     :  t
-    -> f:([ `None | `Always | `Preserve_file_kind ] -> 'acc -> 'acc)
+    -> f:
+         ([ `None | `Always | `Preserve_file_kind | `Patch_back_source_tree ]
+          -> 'acc
+          -> 'acc)
     -> init:'acc
     -> 'acc
 end

src/dune_rules/dep_conf_eval.ml

@@ -9,6 +9,7 @@ let make_sandboxing_config config =
       | `None -> Sandbox_config.Partial.no_sandboxing
       | `Always -> Sandbox_config.Partial.needs_sandboxing
       | `Preserve_file_kind -> Sandbox_config.Partial.disallow Sandbox_mode.symlink
+      | `Patch_back_source_tree -> Sandbox_config.Partial.patch_back_source_tree
     in
     partial :: acc)
   |> Dune_engine.Sandbox_config.Partial.merge ~loc