From 96d30f4e0d4dae9688f82455cdf7ae0e6729aa3e Mon Sep 17 00:00:00 2001
From: Andrey Mokhov <amokhov@janestreet.com>
Date: Fri, 30 Apr 2021 18:53:49 +0100
Subject: [PATCH] Fix testsuite in incremental file-watching mode (#4550)

This PR fixes a couple of tests so that running

  DUNE_WATCHING_MODE_INCREMENTAL=true dune runtest -w

doesn't fall over on the very first build.

There were two problematic tests:

* [vcs_tests.ml] was using functions like [Vcs.describe] that call out to [git]
  or [hg]. Despite using [of_reproducible_fiber], the corresponding fibers are
  actually not reproducible, since the result depends on the current state of
  the file system. I fixed this by adding [Memo.Build.of_non_reproducible_fiber]
  that adds a dependency on the current run, and changed [Vcs] to use it
  instead. This means that we will rerun [Vcs]'s fibers in every build run. We
  might find a way to optimise this in future.

* [memoize_tests.ml] was calling [Memo.reset] relying on it to clear the
  memoization caches, but [Memo.reset] doesn't do that in the incremental mode.
  I fixed this by adding [Memo.clear_memoization_caches] that clears the caches
  unconditionally and changed the test to call it instead.

Signed-off-by: Andrey Mokhov <amokhov@janestreet.com>
---
 src/dune_engine/vcs.ml                  |  2 +-
 src/memo/memo.ml                        | 14 ++++++++++++--
 src/memo/memo.mli                       | 19 ++++++++++++++-----
 test/expect-tests/memo/memoize_tests.ml |  5 +++--
 4 files changed, 30 insertions(+), 10 deletions(-)

diff --git a/src/dune_engine/vcs.ml b/src/dune_engine/vcs.ml
index d0d2544b969..16dddc10617 100644
--- a/src/dune_engine/vcs.ml
+++ b/src/dune_engine/vcs.ml
@@ -52,7 +52,7 @@ let git, hg =
   (get "git", get "hg")
 
 let select git hg t =
-  Memo.Build.of_reproducible_fiber
+  Memo.Build.of_non_reproducible_fiber
     (match t.kind with
     | Git -> git t
     | Hg -> hg t)
diff --git a/src/memo/memo.ml b/src/memo/memo.ml
index 706891c26ab..896d25a11f0 100644
--- a/src/memo/memo.ml
+++ b/src/memo/memo.ml
@@ -15,7 +15,7 @@ module type Build = sig
   val memo_build : 'a build -> 'a t
 end
 
-module Build = struct
+module Build0 = struct
   include Fiber
 
   let if_ x y =
@@ -1061,7 +1061,7 @@ let get_call_stack = Call_stack.get_call_stack_without_state
 let invalidate_dep_node (node : _ Dep_node.t) = node.last_cached_value <- None
 
 module Current_run = struct
-  let f () = Run.current () |> Build.return
+  let f () = Run.current () |> Build0.return
 
   let memo =
     create "current-run" ~input:(module Unit) ~output:(No_cutoff (module Run)) f
@@ -1073,6 +1073,14 @@ end
 
 let current_run () = Current_run.exec ()
 
+module Build = struct
+  include Build0
+
+  let of_non_reproducible_fiber fiber =
+    let* (_ : Run.t) = current_run () in
+    fiber
+end
+
 module With_implicit_output = struct
   type ('i, 'o) t = 'i -> 'o Fiber.t
 
@@ -1206,3 +1214,5 @@ let restart_current_run () =
 let reset () =
   restart_current_run ();
   if not incremental_mode_enabled then Caches.clear ()
+
+let clear_memoization_caches () = Caches.clear ()
diff --git a/src/memo/memo.mli b/src/memo/memo.mli
index 62063c0e751..e3bcc1b383f 100644
--- a/src/memo/memo.mli
+++ b/src/memo/memo.mli
@@ -27,13 +27,18 @@ module Build : sig
 
   val run : 'a t -> 'a Fiber.t
 
-  (** [of_reproducible_fiber fiber] injects a fiber into the build monad. This
-      module assumes that the given fiber is "reproducible", i.e. that executing
-      it multiple times will always yield the same result.
-
-      It is however up to the user to ensure this property. *)
+  (** [of_reproducible_fiber fiber] injects a fiber into the build monad. The
+      given fiber must be "reproducible", i.e. executing it multiple times
+      should always yield the same result. It is up to the caller to ensure that
+      this property holds. If it doesn't, use [of_non_reproducible_fiber]. *)
   val of_reproducible_fiber : 'a Fiber.t -> 'a t
 
+  (** [of_non_reproducible_fiber fiber] injects a fiber into the build monad.
+      The fiber is considered to be "non-reproducible", i.e. it may return
+      different values each time it is executed (for example, the current time),
+      and it will therefore be re-executed on every build run. *)
+  val of_non_reproducible_fiber : 'a Fiber.t -> 'a t
+
   val return : 'a -> 'a t
 
   val both : 'a t -> 'b t -> ('a * 'b) t
@@ -149,6 +154,10 @@ val restart_current_run : unit -> unit
     that the build system tracks all relevant side effects in the [Build] monad. *)
 val incremental_mode_enabled : bool
 
+(** Forget all memoized values, forcing them to be recomputed on the next build
+    run. Intended for use by the testsuite. *)
+val clear_memoization_caches : unit -> unit
+
 module type Output_no_cutoff = sig
   type t
 
diff --git a/test/expect-tests/memo/memoize_tests.ml b/test/expect-tests/memo/memoize_tests.ml
index 74662c3877f..e84d3862297 100644
--- a/test/expect-tests/memo/memoize_tests.ml
+++ b/test/expect-tests/memo/memoize_tests.ml
@@ -473,8 +473,9 @@ let%expect_test "previously_evaluated_cell" =
     previously_evaluated_cell x = [x]
     previously_evaluated_cell y = [y]
   |}];
-  Memo.reset ();
-  (* Both switch back to unevaluated after resetting the Memo. *)
+  Memo.clear_memoization_caches ();
+  Memo.restart_current_run ();
+  (* Both switch back to unevaluated after clearing all memoization caches. *)
   print_previously_evaluated_cell "x";
   print_previously_evaluated_cell "y";
   [%expect