fix(cram): honor --force for cached test output

doc/changes/fixed/16237.md

@@ -0,0 +1,2 @@
+- Make `dune runtest --force` rerun cram tests whose output is cached.
+  (#16237, @rgrinberg)

src/dune_engine/build_system.ml

@@ -337,6 +337,7 @@ module Internal = struct
     type t =
       { action : Rule.Anonymous_action.t
       ; deps : Dep.Set.t
+      ; anonymous_action_facts : Dep.Facts.t
       ; capture_stdout : bool
       ; digest : Digest.t
       }
@@ -742,9 +743,13 @@ module Internal = struct
        the presence of dynamic actions. *)
     >>| fun produced_targets -> { facts; targets = produced_targets }
 
-  (* Returns the action's stdout or the empty string if [capture_stdout = false]. *)
   and execute_action_generic_stage2_impl
-        { Anonymous_action.action = { dir; loc; action }; deps; capture_stdout; digest }
+        { Anonymous_action.action = { dir; loc; action }
+        ; deps
+        ; anonymous_action_facts
+        ; capture_stdout
+        ; digest
+        }
     =
     let target =
       let dir =
@@ -753,18 +758,23 @@ module Internal = struct
       Path.Build.relative dir (Digest.to_string digest)
     in
     let rule =
+      let build_dep dep =
+        match Dep.Map.find anonymous_action_facts dep with
+        | Some fact -> Memo.return fact
+        | None -> build_dep dep
+      in
       Rule.make
         ~info:(if Loc.is_none loc then Internal else From_dune_file loc)
         ~targets:(Targets.File.create target)
         ~mode:Standard
         (Action_builder.record action deps ~f:build_dep)
     in
-    let+ { facts = _; targets = _ } =
+    let+ { targets; _ } =
       execute_rule_impl
         rule
         ~rule_kind:(Anonymous_action { capture_stdout; stamp_file = target })
     in
-    if capture_stdout then Io.read_file (Path.build target) else ""
+    targets
 
   and execute_action_generic
         ~observing_facts
@@ -786,13 +796,24 @@ module Internal = struct
        only depend on the action. If the two execution could run concurrently,
        then they would both try to create the same file. So in this regard, we
        use [Memo] mostly for synchronisation purposes. *)
-    (* Here we "forget" the facts about the world. We do that to make the input
-       of the memoized function smaller. If we passed the whole [original_facts]
-       as input, then we would end up memoizing one entry per set of facts. This
-       could use a lot of memory. For instance, if we used [action_stdout] for
-       the calls to [ocamldep], then Dune would remember the whole history of
-       calls to [ocamldep] for each OCaml source file. *)
+    (* Keep only the dependency labels to make the input of the memoized function
+       smaller. If we passed all the facts, Dune would remember the whole history
+       of calls to [ocamldep] for each OCaml source file. Facts for anonymous action
+       targets are the exception because these targets cannot be rebuilt through
+       [Load_rules]. *)
     let deps = Dep.Map.map observing_facts ~f:ignore in
+    let anonymous_action_facts =
+      Dep.Map.foldi observing_facts ~init:Dep.Facts.empty ~f:(fun dep fact facts ->
+        match dep with
+        | File path ->
+          (match Path.as_in_build_dir path with
+           | Some path ->
+             (match Dpath.analyse_target path with
+              | Anonymous_action _ -> Dep.Map.set facts dep fact
+              | Alias _ | Regular _ | Other _ -> facts)
+           | None -> facts)
+        | Alias _ | File_selector _ | Universe | Env _ -> facts)
+    in
     (* Shadow [observing_facts] to make sure we don't use it again. *)
     let observing_facts = () in
     ignore observing_facts;
@@ -842,18 +863,38 @@ module Internal = struct
        the execution and avoid such a race condition. *)
     Memo.exec
       (Lazy.force execute_action_generic_stage2_memo)
-      { Anonymous_action.action = act; deps; capture_stdout; digest }
+      { Anonymous_action.action = act
+      ; deps
+      ; anonymous_action_facts
+      ; capture_stdout
+      ; digest
+      }
 
   and execute_action ~observing_facts act =
-    let+ (_empty_string : string) =
+    let+ (_ : Digest.t Targets.Produced.t) =
       execute_action_generic ~observing_facts act ~capture_stdout:false
     in
     ()
 
-  and execute_action_stdout action =
+  and execute_action_stdout_targets action =
     let* action, observing_facts = Action_builder.evaluate_and_collect_facts action in
     execute_action_generic ~observing_facts action ~capture_stdout:true
 
+  and execute_action_stdout action =
+    let+ targets = execute_action_stdout_targets action in
+    Targets.Produced.head targets |> Path.build |> Io.read_file
+
+  and execute_action_stdout_target action =
+    Action_builder.of_memo (execute_action_stdout_targets action)
+    |> Action_builder.bind ~f:(fun targets ->
+      let target = Targets.Produced.head targets in
+      let digest = Targets.Produced.find targets target |> Option.value_exn in
+      let target = Path.build target in
+      Action_builder.record
+        target
+        (Dep.Set.singleton (Dep.file target))
+        ~f:(fun _ -> Memo.return (Dep.Fact.file target digest)))
+
   (* A rule can have multiple targets but calls to [execute_rule] are memoized,
      so the rule will be executed only once. *)
   and build_file_impl path =
@@ -1004,7 +1045,7 @@ module Internal = struct
          "execute-action"
          ~input:(module Anonymous_action)
          ~initial_store_size:2048
-         ~cutoff:String.equal
+         ~cutoff:(fun x y -> Targets.Produced.equal x y ~equal:Digest.equal)
          ~on_event:State.on_rule_event
          execute_action_generic_stage2_impl)
 

src/dune_engine/build_system.mli

@@ -41,6 +41,13 @@ val execute_action : observing_facts:Dep.Facts.t -> Rule.Anonymous_action.t -> u
 (** Execute an action and capture its stdout. The execution is cached. *)
 val execute_action_stdout : Rule.Anonymous_action.t Action_builder.t -> string Memo.t
 
+(** Execute an action and expose its captured stdout as a build target. The execution is
+    cached, and the returned action builder records the target and its digest as a
+    dependency. *)
+val execute_action_stdout_target
+  :  Rule.Anonymous_action.t Action_builder.t
+  -> Path.t Action_builder.t
+
 type rule_execution_result =
   { facts : Dep.Fact.t Dep.Map.t
   ; targets : Digest.t Targets.Produced.t

src/dune_rules/cram/cram_exec.ml

@@ -813,7 +813,6 @@ let run_and_produce_output
       ~env
       ~dir:cwd
       ~script
-      ~dst
       ~timeout
       ~setup_scripts
       ~sandbox
@@ -853,11 +852,7 @@ let run_and_produce_output
       | { metadata = Timed_out _; _ } -> true
       | _ -> false)
   then print_timeout_correction_and_fail ~src ~conflict_markers ~timeout ~sandbox commands
-  else (
-    let dst = Path.build dst in
-    Path.mkdir_p (Path.parent_exn dst);
-    Script.dump dst commands;
-    Fiber.return ())
+  else Fiber.return commands
 ;;
 
 module Run = struct
@@ -866,40 +861,31 @@ module Run = struct
       { src : Path.t
       ; dir : 'path
       ; script : 'path
-      ; output : 'target
       ; timeout : (Loc.t * Time.Span.t) option
       ; setup_scripts : 'path list
       ; shell : Cram_stanza.Shell.t
       }
 
     let name = "cram-run"
-    let version = 7
+    let version = 8
     let runs_process = true
     let can_run_in_action_runner = true
 
-    let bimap
-          ({ src = _; dir; script; output; timeout; setup_scripts; shell = _ } as t)
-          f
-          g
-      =
+    let bimap ({ src = _; dir; script; timeout; setup_scripts; shell = _ } as t) f _ =
       { t with
         dir = f dir
       ; script = f script
-      ; output = g output
       ; timeout
       ; setup_scripts = List.map ~f setup_scripts
       }
     ;;
 
     let is_useful_to ~memoize:_ = true
 
-    let encode { src = _; dir; script; output; timeout; shell; setup_scripts } path target
-      : Sexp.t
-      =
+    let encode { src = _; dir; script; timeout; shell; setup_scripts } path _ : Sexp.t =
       List
         [ path dir
         ; path script
-        ; target output
         ; Dune_sexp.Encoder.(
             option float (Option.map ~f:(fun (_, time) -> Time.Span.to_secs time) timeout))
           |> Dune_sexp.to_sexp
@@ -909,29 +895,32 @@ module Run = struct
     ;;
 
     let action
-          { src; dir; script; output; timeout; setup_scripts; shell }
+          { src; dir; script; timeout; setup_scripts; shell }
           ~(ectx : Action.context)
           ~(eenv : Action.env)
       =
-      run_and_produce_output
-        ~conflict_markers:Ignore
-        ~src
-        ~env:eenv.env
-        ~dir
-        ~script
-        ~dst:output
-        ~timeout
-        ~setup_scripts
-        ~sandbox:ectx.sandbox
-        shell
+      let open Fiber.O in
+      let+ commands =
+        run_and_produce_output
+          ~conflict_markers:Ignore
+          ~src
+          ~env:eenv.env
+          ~dir
+          ~script
+          ~timeout
+          ~setup_scripts
+          ~sandbox:ectx.sandbox
+          shell
+      in
+      Script.to_string commands |> output_string (Process.Io.out_channel eenv.stdout_to)
     ;;
   end
 
   include Action_ext.Make (Spec)
 end
 
-let run ~src ~dir ~script ~output ~timeout ~setup_scripts shell =
-  Run.action { src; dir; script; output; timeout; setup_scripts; shell }
+let run ~src ~dir ~script ~timeout ~setup_scripts shell =
+  Run.action { src; dir; script; timeout; setup_scripts; shell }
 ;;
 
 module Make_script = struct

src/dune_rules/cram/cram_exec.mli

@@ -12,7 +12,6 @@ val run
   :  src:Path.t
   -> dir:Path.t
   -> script:Path.t
-  -> output:Path.Build.t
   -> timeout:(Loc.t * Time.Span.t) option
   -> setup_scripts:Path.t list
   -> Cram_stanza.Shell.t

src/dune_rules/cram/cram_rules.ml

@@ -113,7 +113,6 @@ let test_rule
          Path.Source.relative dir (".cram." ^ basename))
     in
     let script_sh = Path.Build.relative base_path "cram.sh" in
-    let output = Path.Build.relative base_path "cram.out" in
     let* () =
       (let open Action_builder.O in
        let+ () = Action_builder.path (Path.build script) in
@@ -122,50 +121,52 @@ let test_rule
       |> Action_builder.with_file_targets ~file_targets:[ script_sh ]
       |> Super_context.add_rule sctx ~dir ~loc
     in
-    let* () =
-      (let open Action_builder.O in
-       let+ () = Action_builder.all_unit deps
-       and+ () = Action_builder.path (Path.build script_sh)
-       and+ () =
-         match test with
-         | File _ -> Action_builder.return ()
-         | Dir { dir; file } ->
-           let file = Path.Build.append_source prefix_with file |> Path.build in
-           let deps =
-             Path.Build.append_source prefix_with dir
-             |> Path.build
-             |> Source_deps.files_with_filter ~filter:(fun file' ->
-               not (Path.equal file file'))
-           in
-           let+ (_ : Path.Set.t) = Action_builder.dyn_memo_deps deps in
-           ()
-       and+ () = Action_builder.paths setup_scripts
-       and+ sandbox
-       and+ env
-       and+ locks = locks >>| Path.Set.to_list in
-       Cram_exec.run
-         ~src:(Path.build script)
-         ~dir:
-           (Path.build
-              (match test with
-               | File _ -> Path.Build.parent_exn script
-               | Dir d -> Path.Build.append_source prefix_with d.dir))
-         ~script:(Path.build script_sh)
-         ~output
-         ~timeout
-         ~setup_scripts
-         shell
-       |> Action.Full.make ~locks ~sandbox
-       |> Action.Full.add_env env)
-      |> Action_builder.with_file_targets ~file_targets:[ output ]
-      |> Super_context.add_rule sctx ~dir ~loc
+    let output =
+      let open Action_builder.O in
+      let action =
+        let+ () = Action_builder.all_unit deps
+        and+ () = Action_builder.path (Path.build script_sh)
+        and+ () =
+          match test with
+          | File _ -> Action_builder.return ()
+          | Dir { dir; file } ->
+            let file = Path.Build.append_source prefix_with file |> Path.build in
+            let deps =
+              Path.Build.append_source prefix_with dir
+              |> Path.build
+              |> Source_deps.files_with_filter ~filter:(fun file' ->
+                not (Path.equal file file'))
+            in
+            let+ (_ : Path.Set.t) = Action_builder.dyn_memo_deps deps in
+            ()
+        and+ () = Action_builder.paths setup_scripts
+        and+ sandbox
+        and+ env
+        and+ locks = locks >>| Path.Set.to_list in
+        Cram_exec.run
+          ~src:(Path.build script)
+          ~dir:
+            (Path.build
+               (match test with
+                | File _ -> Path.Build.parent_exn script
+                | Dir d -> Path.Build.append_source prefix_with d.dir))
+          ~script:(Path.build script_sh)
+          ~timeout
+          ~setup_scripts
+          shell
+        |> Action.Full.make ~locks ~sandbox
+        |> Action.Full.add_env env
+      in
+      Super_context.execute_action_stdout_target sctx ~loc ~dir action
+      |> Action_builder.memoize "cram-output"
     in
     Alias_rules.add sctx ~aliases:[ alias ] ~loc
     @@
     let open Action_builder.O in
-    let+ () = List.map ~f:Path.build [ script; output ] |> Action_builder.paths in
+    let+ output
+    and+ () = Action_builder.path (Path.build script) in
     Action.progn
-      [ Cram_exec.diff ~src:(Path.build script) ~output:(Path.build output)
+      [ Cram_exec.diff ~src:(Path.build script) ~output
       ; Action.diff
           ~optional:true
           ~mode:Text

src/dune_rules/super_context.ml

@@ -170,11 +170,18 @@ let extend_action_env t ~dir action =
   Action.Full.add_env env action
 ;;
 
-let execute_action_stdout t ~loc ~dir action =
+let anonymous_action t ~loc ~dir action =
   let open Action_builder.O in
-  (let+ action = extend_action_env t ~dir action in
-   { Rule.Anonymous_action.action; loc; dir })
-  |> Build_system.execute_action_stdout
+  let+ action = extend_action_env t ~dir action in
+  { Rule.Anonymous_action.action; loc; dir }
+;;
+
+let execute_action_stdout t ~loc ~dir action =
+  anonymous_action t ~loc ~dir action |> Build_system.execute_action_stdout
+;;
+
+let execute_action_stdout_target t ~loc ~dir action =
+  anonymous_action t ~loc ~dir action |> Build_system.execute_action_stdout_target
 ;;
 
 let extend_action t ~dir action =