Improvements to diff? semantics

CHANGES.md

@@ -91,11 +91,19 @@
 - Get rid of ad-hoc rules for guessing the version. Dune now only
   relies on the version written in the `dune-project` file and no
   longer read `VERSION` or similar files (#2541, @diml)
+
+- In `(diff? x y)` action, require `x` to exist and register a 
+  dependency on that file. (#2486, @aalekseyev)
 
 - On Windows, an .exe suffix is no longer added implicitly to binary names that
   already end in .exe. Second, when resolving binary names, .opt variants are no
   longer chosen automatically. (#2543, @nojb)
 
+- Make `(diff? x y)` move the correction file (`y`) away from the build 
+  directory to promotion staging area.
+  This makes corrections work with sandboxing and in general reduces build 
+  directory pollution. (#2486, @aalekseyev, fixes #2482)
+
 1.11.0 (23/07/2019)
 -------------------
 

doc/concepts.rst

@@ -622,9 +622,10 @@ The following constructions are available:
 - ``(diff <file1> <file2>)`` is similar to ``(run diff <file1>
   <file2>)`` but is better and allows promotion.  See `Diffing and
   promotion`_ for more details
-- ``(diff? <file1> <file2>)`` is the same as ``(diff <file1>
-  <file2>)`` except that it is ignored when ``<file1>`` or ``<file2>``
-  doesn't exists
+- ``(diff? <file1> <file2>)`` is similar to ``(diff <file1>
+  <file2>)`` except that ``<file2>`` should be produced by a part of the
+  same action rather than be a dependency, is optional and will
+  be consumed by ``diff?``.
 - ``(cmp <file1> <file2>)`` is similar to ``(run cmp <file1>
   <file2>)`` but allows promotion.  See `Diffing and promotion`_ for
   more details

src/dune/action_exec.ml

@@ -141,40 +141,55 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from =
         Digest.generic data
       in
       exec_echo stdout_to (Digest.to_string_raw s)
-  | Diff ({ optional = _; file1; file2; mode } as diff) ->
-      if Diff.eq_files diff then
-        Fiber.return ()
-      else
-        let is_copied_from_source_tree file =
-          match Path.extract_build_context_dir_maybe_sandboxed file with
-          | None ->
-              false
-          | Some (_, file) ->
-              Path.exists (Path.source file)
-        in
-        if
-          is_copied_from_source_tree file1
-          && not (is_copied_from_source_tree file2)
-        then
-          Promotion.File.register
-            { src =
-                snd
-                  (Path.Build.split_sandbox_root
-                     (Path.as_in_build_dir_exn file2))
-            ; dst =
-                snd
-                  (Option.value_exn
-                     (Path.extract_build_context_dir_maybe_sandboxed file1))
-            };
+  | Diff ({ optional; file1; file2; mode } as diff) ->
+    let remove_intermediate_file () =
+      if optional then
+        (try Path.unlink file2 with
+         | (Unix.Unix_error (ENOENT, _, _)) -> ())
+    in
+    if Diff.eq_files diff then
+      (remove_intermediate_file ();
+       Fiber.return ())
+    else begin
+      let is_copied_from_source_tree file =
+        match Path.extract_build_context_dir_maybe_sandboxed file with
+        | None -> false
+        | Some (_, file) -> Path.exists (Path.source file)
+      in
+      Fiber.finalize (fun () ->
         if mode = Binary then
           User_error.raise
             [ Pp.textf "Files %s and %s differ."
                 (Path.to_string_maybe_quoted file1)
                 (Path.to_string_maybe_quoted file2)
             ]
         else
-          Print_diff.print file1 file2
-            ~skip_trailing_cr:(mode = Text && Sys.win32)
+          Print_diff.print file1 file2 ~skip_trailing_cr:(mode = Text && Sys.win32))
+        ~finally:(fun () ->
+          (match optional with
+          | false ->
+            if is_copied_from_source_tree file1 &&
+               (not (is_copied_from_source_tree file2)) then begin
+              Promotion.File.register_dep
+                ~source_file:
+                  (snd (Option.value_exn (
+                     Path.extract_build_context_dir_maybe_sandboxed file1)))
+                ~correction_file:
+                  (Path.as_in_build_dir_exn file2)
+            end
+          | true ->
+            if is_copied_from_source_tree file1 then begin
+              Promotion.File.register_intermediate
+                ~source_file:
+                  (snd (Option.value_exn (
+                     Path.extract_build_context_dir_maybe_sandboxed file1)))
+                ~correction_file:
+                  (Path.as_in_build_dir_exn file2)
+            end else
+              remove_intermediate_file ());
+          Fiber.return ()
+        )
+    end
   | Merge_files_into (sources, extras, target) ->
       let lines =
         List.fold_left

src/dune/action_unexpanded.ml

@@ -414,12 +414,9 @@ module Infer = struct
       | Digest_files l ->
           List.fold_left l ~init:acc ~f:( +< )
       | Diff { optional; file1; file2; mode = _ } ->
-          if optional then
-            acc
-          else
-            acc +< file1 +< file2
+        if optional then acc +< file1 else acc +< file1 +< file2
       | Merge_files_into (sources, _extras, target) ->
-          List.fold_left sources ~init:acc ~f:( +< ) +@+ target
+        List.fold_left sources ~init:acc ~f:( +< ) +@+ target
       | Echo _ | System _ | Bash _ | Remove_tree _ | Mkdir _ ->
           acc
 

src/dune/diff.ml

@@ -32,6 +32,6 @@ let decode_binary path =
   and+ file2 = path in
   { optional = false; file1; file2; mode = Binary }
 
-let eq_files { optional; mode; file1; file2 } =
-  (optional && not (Path.exists file1 && Path.exists file2))
+let eq_files { optional ; mode; file1; file2 } =
+  (optional && not (Path.exists file2))
   || Mode.compare_files mode file1 file2 = Eq

src/dune/print_diff.ml

@@ -18,8 +18,8 @@ let print ?(skip_trailing_cr = Sys.win32) path1 path2 =
   let fallback () =
     User_error.raise ~loc
       [ Pp.textf "Files %s and %s differ."
-          (Path.to_string_maybe_quoted path1)
-          (Path.to_string_maybe_quoted path2)
+          (Path.to_string_maybe_quoted (Path.drop_optional_sandbox_root path1))
+          (Path.to_string_maybe_quoted (Path.drop_optional_sandbox_root path2))
       ]
   in
   let normal_diff () =

src/dune/promotion.ml

@@ -1,44 +1,80 @@
 open! Stdune
 
+let staging_area =
+  Path.Build.relative Path.Build.root ".promotion-staging"
+
 module File = struct
   type t =
     { src : Path.Build.t
+    ; staging : Path.Build.t option
     ; dst : Path.Source.t
     }
 
-  let to_dyn { src; dst } =
+  let in_staging_area source =
+    Path.Build.append_source staging_area source
+
+  let to_dyn { src; staging; dst } =
     let open Dyn.Encoder in
-    record [ ("src", Path.Build.to_dyn src); ("dst", Path.Source.to_dyn dst) ]
+    record
+      [ ("src", Path.Build.to_dyn src)
+      ; "staging", option Path.Build.to_dyn staging
+      ; ("dst", Path.Source.to_dyn dst)
+      ]
 
   let db : t list ref = ref []
 
-  let register t = db := t :: !db
-
-  let promote { src; dst } =
-    let src_exists = Path.exists (Path.build src) in
+  let register_dep ~source_file ~correction_file =
+    db :=
+      { src = snd (Path.Build.split_sandbox_root correction_file);
+        staging = None;
+        dst = source_file;
+      } :: !db
+
+  let register_intermediate ~source_file ~correction_file =
+    let staging = 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);
+    let src = snd (Path.Build.split_sandbox_root correction_file) in
+    db := { src; staging = Some staging; dst = source_file } :: !db
+
+  let promote { src; staging; dst } =
+    let correction_file =
+      Option.value staging ~default:src
+    in
+    let correction_exists = Path.exists (Path.build correction_file) in
     Console.print
-      (Format.sprintf
-         ( if src_exists then
+      (if correction_exists then
+         Format.sprintf
            "Promoting %s to %s.@."
-         else
-           "Skipping promotion of %s to %s as the file is missing.@." )
-         (Path.to_string_maybe_quoted (Path.build src))
-         (Path.Source.to_string_maybe_quoted dst));
-    if src_exists then
-      Io.copy_file ~src:(Path.build src) ~dst:(Path.source dst) ()
+           (Path.to_string_maybe_quoted (Path.build src))
+           (Path.Source.to_string_maybe_quoted dst)
+       else
+         (Format.sprintf
+            "Skipping promotion of %s to %s as the %s is missing.@.")
+           (Path.to_string_maybe_quoted (Path.build src))
+           (Path.Source.to_string_maybe_quoted dst)
+           (match staging with
+            | None -> "file"
+            | Some staging ->
+              Format.sprintf "staging file (%s)"
+                (Path.to_string_maybe_quoted (Path.build staging)))
+      )
+    ;
+    if correction_exists then
+      Io.copy_file ~src:(Path.build correction_file) ~dst:(Path.source dst) ()
 end
 
 let clear_cache () = File.db := []
 
 let () = Hooks.End_of_build.always clear_cache
 
-module P = Persistent.Make (struct
-  type t = File.t list
-
-  let name = "TO-PROMOTE"
-
-  let version = 1
-end)
+module P = Persistent.Make(struct
+    type t = File.t list
+    let name = "TO-PROMOTE"
+    let version = 2
+  end)
 
 let db_file = Path.relative Path.build_dir ".to-promote"
 
@@ -53,10 +89,12 @@ 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; dst } -> (dst, src))
+  List.map db ~f:(fun { File. src; staging; dst } ->
+    (dst, (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:Path.Build.compare)
+  |> Path.Source.Map.map
+       ~f:(List.sort ~compare:(fun (x, _) (y, _) -> Path.Build.compare x y))
 
 type files_to_promote =
   | All
@@ -81,39 +119,45 @@ let do_promote db files_to_promote =
   let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in
   let promote_one dst srcs =
     match srcs with
-    | [] ->
-        assert false
-    | src :: others ->
-        (* We remove the files from the digest cache to force a rehash on the
-           next run. We do this because on OSX [mtime] is not precise enough
-           and if a file is modified and promoted quickly, it will look like it
-           hasn't changed even though it might have. *)
-        List.iter dirs_to_clear_from_cache ~f:(fun dir ->
-            Cached_digest.remove (Path.append_source dir dst));
-        File.promote { src; dst };
-        List.iter others ~f:(fun path ->
-            Format.eprintf " -> ignored %s.@."
-              (Path.to_string_maybe_quoted (Path.build path)))
+    | [] -> assert false
+    | (src, staging) :: others ->
+      (* We remove the files from the digest cache to force a rehash
+         on the next run. We do this because on OSX [mtime] is not
+         precise enough and if a file is modified and promoted
+         quickly, it will look like it hasn'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])
+      *)
+      List.iter dirs_to_clear_from_cache ~f:(fun dir ->
+        Cached_digest.remove (Path.append_source dir dst));
+      File.promote { src; staging; dst };
+      List.iter others ~f:(fun (path, _staging) ->
+        Format.eprintf " -> ignored %s.@."
+          (Path.to_string_maybe_quoted (Path.build path)))
   in
   match files_to_promote with
   | All ->
       Path.Source.Map.iteri by_targets ~f:promote_one;
       []
   | These (files, on_missing) ->
-      let files = Path.Source.Set.of_list files |> Path.Source.Set.to_list in
-      let by_targets =
-        List.fold_left files ~init:by_targets ~f:(fun map fn ->
-            match Path.Source.Map.find by_targets fn with
-            | None ->
-                on_missing fn;
-                map
-            | Some srcs ->
-                promote_one fn srcs;
-                Path.Source.Map.remove by_targets fn)
-      in
-      Path.Source.Map.to_list by_targets
-      |> List.concat_map ~f:(fun (dst, srcs) ->
-             List.map srcs ~f:(fun src -> { File.src; dst }))
+    let files =
+      Path.Source.Set.of_list files |> Path.Source.Set.to_list
+    in
+    let by_targets =
+      List.fold_left files ~init:by_targets ~f:(fun map fn ->
+        match Path.Source.Map.find by_targets fn with
+        | None ->
+          on_missing fn;
+          map
+        | Some srcs ->
+          promote_one fn srcs;
+          Path.Source.Map.remove by_targets fn)
+    in
+    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 }))
 
 let finalize () =
   let db =

src/dune/promotion.mli

@@ -1,15 +1,30 @@
 open! Stdune
 
 module File : sig
-  type t =
-    { src : Path.Build.t
-    ; dst : Path.Source.t
-    }
+  type t
 
   val to_dyn : t -> Dyn.t
 
-  (** Register a file to promote *)
-  val register : t -> unit
+  (** Register an intermediate file to promote.
+      The build path may point to the sandbox and the file will be
+      moved to the staging area.
+  *)
+  val register_intermediate :
+    source_file:Path.Source.t ->
+    correction_file:Path.Build.t ->
+    unit
+
+  (** Register file to promote where the correction
+      file is a dependency of the current action (rather than an
+      intermediate file).
+      [correction_file] 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
+
 end
 
 (** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the

src/stdune/path.ml

@@ -816,7 +816,7 @@ module Build = struct
 end
 
 module T : sig
-  type t = private
+  type t =
     | External of External.t
     | In_source_tree of Local.t
     | In_build_dir of Local.t
@@ -1140,6 +1140,11 @@ let extract_build_context_dir_maybe_sandboxed = function
       Option.map (Build.extract_build_context_dir_maybe_sandboxed t)
         ~f:(fun (base, rest) -> (in_build_dir base, rest))
 
+let drop_optional_sandbox_root = function
+  | (In_source_tree _ | External _) as x -> x
+  | In_build_dir t -> match (Build.split_sandbox_root t) with
+    | _sandbox_root, t -> (In_build_dir t : t)
+
 let extract_build_context_dir_exn t =
   match extract_build_context_dir t with
   | Some t ->