fix(promote): exit 0 for auto-promote-only failures

src/dune_engine/build_system.ml

@@ -1144,6 +1144,21 @@ let handle_final_exns exns =
        List.iter exns ~f:Dune_util.Report_error.report)
 ;;
 
+let auto_promote_enabled () =
+  match !Clflags.promote with
+  | Some Automatically -> true
+  | Some Never | None -> false
+;;
+
+let error_has_promotion error = Option.is_some (Error.promotion error)
+let exn_has_promotion exn = Error.of_exn exn |> List.for_all ~f:error_has_promotion
+
+let all_errors_are_promotions exns =
+  match exns with
+  | [] -> false
+  | _ :: _ -> List.for_all exns ~f:exn_has_promotion
+;;
+
 let run_with_error_collection ?restart_started_at ~build_started_at ~build collect_errors =
   let build =
     match build with
@@ -1190,15 +1205,26 @@ let run_with_error_collection ?restart_started_at ~build_started_at ~build colle
         State.set Build_succeeded__now_waiting_for_changes;
         Fiber.return (Ok res)
       | Error exns ->
+        let auto_promoted_errors =
+          auto_promote_enabled ()
+          && Diff_promotion.has_pending ()
+          && all_errors_are_promotions exns
+        in
         handle_final_exns exns;
         finalize_diff_promotion ();
-        let final_status =
-          if List.exists exns ~f:caused_by_cancellation
-          then State.Restarting_current_build
-          else Build_failed__now_waiting_for_changes
-        in
-        State.set final_status;
-        Fiber.return (Error `Already_reported)
+        if auto_promoted_errors
+        then (
+          let+ () = State.reset_errors () in
+          State.set Build_succeeded__now_waiting_for_changes;
+          Ok ())
+        else (
+          let final_status =
+            if List.exists exns ~f:caused_by_cancellation
+            then State.Restarting_current_build
+            else Build_failed__now_waiting_for_changes
+          in
+          State.set final_status;
+          Fiber.return (Error `Already_reported))
     in
     Metrics.reset ();
     let+ () = Scheduler.flush_file_watcher () in
@@ -1340,7 +1366,9 @@ let run ?restart_started_at ?build f =
   | Ok () ->
     (match !result with
      | Some result -> Ok result
-     | None -> Code_error.raise "build request did not produce a result" [])
+     (* Promotion-only failures can make [run_build_requests] return success
+        even though this result-producing memo did not complete. *)
+     | None -> Error `Already_reported)
 ;;
 
 let run_exn f =

src/dune_engine/diff_action.ml

@@ -17,9 +17,14 @@ type file_diff =
   ; file2 : Path.t
   }
 
+type message =
+  { source_file : Path.Source.t
+  ; messages : User_message.Style.t Pp.t list
+  }
+
 type change =
   | File_diff of file_diff
-  | Message of User_message.Style.t Pp.t list
+  | Message of message
 
 type promotion =
   | Promote_file of
@@ -73,20 +78,20 @@ let promotion source_file =
   }
 ;;
 
-let run_change loc ~patch_back (mode : Diff.Mode.t) = function
-  | Message messages -> User_error.raise ~loc messages
+let run_change loc ~patch_back ~will_promote (mode : Diff.Mode.t) = function
+  | Message { source_file; messages } ->
+    User_error.raise
+      ?promotion:(Option.some_if will_promote (promotion source_file))
+      ~loc
+      messages
   | File_diff { source_file; file1; file2 } ->
+    let promotion = Option.some_if will_promote (promotion source_file) in
     (match mode with
      | Text ->
-       Print_diff.print
-         ~patch_back
-         (promotion source_file)
-         file1
-         file2
-         ~skip_trailing_cr:Sys.win32
+       Print_diff.print ~patch_back promotion file1 file2 ~skip_trailing_cr:Sys.win32
      | Binary ->
        User_error.raise
-         ~promotion:(promotion source_file)
+         ?promotion
          ~loc
          [ Pp.textf
              "Files %s and %s differ."
@@ -153,7 +158,9 @@ let plan_tree_diff ({ mode; source_root; _ } as t) =
   let kind_of_target rel = kind_of_path ~loc:t.loc (target_path rel) in
   let list_target_directory rel = list_directory ~loc:t.loc (target_path rel) in
   let path_name rel = Path.Source.to_string_maybe_quoted (source_file rel) in
-  let add_message plan message = add_change plan (Message [ message ]) in
+  let add_message plan rel message =
+    add_change plan (Message { source_file = source_file rel; messages = [ message ] })
+  in
   let add_promote_file plan rel =
     add_promotion
       plan
@@ -177,12 +184,12 @@ let plan_tree_diff ({ mode; source_root; _ } as t) =
       | `File -> "File"
       | `Directory -> "Directory"
     in
-    add_message plan (Pp.textf "%s %s should be deleted" what_text (path_name rel))
+    add_message plan rel (Pp.textf "%s %s should be deleted" what_text (path_name rel))
   in
   let add_create_directory ~announce plan rel =
     let plan = add_promotion plan (Create_directory (source_file rel)) in
     if announce
-    then add_message plan (Pp.textf "Directory %s should be created" (path_name rel))
+    then add_message plan rel (Pp.textf "Directory %s should be created" (path_name rel))
     else plan
   in
   let rec collect_target_only rel target_kind plan =
@@ -208,6 +215,7 @@ let plan_tree_diff ({ mode; source_root; _ } as t) =
       let plan = add_promote_file plan rel in
       add_message
         plan
+        rel
         (Pp.textf "Directory %s should be replaced with a file" (path_name rel))
     | File, Missing -> add_delete plan `File rel
     | Directory, Missing -> add_delete plan `Directory rel
@@ -227,6 +235,7 @@ let plan_tree_diff ({ mode; source_root; _ } as t) =
              (let plan = add_create_directory ~announce:false plan rel in
               add_message
                 plan
+                rel
                 (Pp.textf "File %s should be replaced with a directory" (path_name rel)))
            ~f:(fun plan name ->
              let rel = Path.Local.relative_fname rel name in
@@ -307,15 +316,19 @@ let exec_plan
     let target_is_copied_from_source_tree =
       is_copied_from_source_tree (Path.build file2)
     in
+    let will_promote =
+      match optional with
+      | false -> in_source_or_target && not target_is_copied_from_source_tree
+      | true -> in_source_or_target
+    in
     Fiber.finalize
-      (fun () -> Fiber.parallel_iter changes ~f:(run_change loc ~patch_back mode))
+      (fun () ->
+         Fiber.parallel_iter changes ~f:(run_change loc ~patch_back ~will_promote mode))
       ~finally:(fun () ->
         (match optional with
-         | false ->
-           if in_source_or_target && not target_is_copied_from_source_tree
-           then register_promotions `Copy promotions
+         | false -> if will_promote then register_promotions `Copy promotions
          | true ->
-           if in_source_or_target
+           if will_promote
            then register_promotions `Move promotions
            else remove_intermediate_target file2);
         Fiber.return ())

src/dune_engine/print_diff.ml

@@ -255,7 +255,7 @@ let prepare ~skip_trailing_cr promotion path1 path2 =
 let print ~skip_trailing_cr ~patch_back promotion path1 path2 =
   let p =
     match patch_back with
-    | None -> prepare ~skip_trailing_cr (Some promotion) path1 path2
+    | None -> prepare ~skip_trailing_cr promotion path1 path2
     | Some dir ->
       let path1 = Path.source (Path.drop_optional_build_context_src_exn path1) in
       let loc = Loc.in_file path1 in
@@ -265,7 +265,7 @@ let print ~skip_trailing_cr ~patch_back promotion path1 path2 =
         ~skip_trailing_cr
         ~dir
         loc
-        (Some promotion)
+        promotion
         (label1, path1)
         (label2, path2)
   in

src/dune_engine/print_diff.mli

@@ -4,7 +4,7 @@ open Import
 val print
   :  skip_trailing_cr:bool
   -> patch_back:Path.t option
-  -> User_message.Diff_annot.t
+  -> User_message.Diff_annot.t option
   -> Path.t
   -> Path.t
   -> _ Fiber.t

test/blackbox-tests/test-cases/cinaps/runtime-deps.t

@@ -26,6 +26,5 @@ Runtime dependencies for running cinaps
   -(*)
   +(*$ let f = open_in "foo" in print_endline (input_line f); close_in f *)hello world
   Promoting _build/default/test.ml.cinaps-corrected to test.ml.
-  [1]
   $ cat test.ml
   (*$ let f = open_in "foo" in print_endline (input_line f); close_in f *)hello world

test/blackbox-tests/test-cases/cinaps/simple.t

@@ -40,7 +40,6 @@ The cinaps stanza offers a promotion workflow:
    (*$*)
    let x = 1
   Promoting _build/default/test.ml.cinaps-corrected to test.ml.
-  [1]
 
   $ cat test.ml
   (*$ print_endline "\nhello" *)

test/blackbox-tests/test-cases/cram/cram-command-syntax-error-gh4230.t

@@ -10,7 +10,6 @@ Syntax error inside a cram command
   File "t1.t", line 1, characters 0-0:
   Error: Files _build/default/t1.t and _build/default/t1.t.corrected differ.
   Promoting _build/default/t1.t.corrected to t1.t.
-  [1]
 
   $ cat >t1.t <<EOF
   >   $ exit 1
@@ -26,7 +25,6 @@ Syntax error inside a cram command
      $ echo foobar
   +  ***** UNREACHABLE *****
   Promoting _build/default/t1.t.corrected to t1.t.
-  [1]
   $ cat t1.t
     $ exit 1
     ***** UNREACHABLE *****

test/blackbox-tests/test-cases/cram/custom-build-dir.t

@@ -35,7 +35,6 @@ path
   Promoting
     $TESTCASE_ROOT/tmp/default/foo.t.corrected
     to foo.t.
-  [1]
   $ cat foo.t
     $ echo "  $ echo bar" >bar.t
     $ if [ -e "$DUNE_BUILD_DIR/.rpc" ]; then

test/blackbox-tests/test-cases/cram/git-access.t

@@ -17,7 +17,6 @@ Check that actions don't have access to the outer git repository.
   +  fatal: invalid gitfile format: $TESTCASE_ROOT/git/_build/.sandbox/.git
   +  [128]
   Promoting _build/default/test.t.corrected to test.t.
-  [1]
 
 The inner call to git shouldn't be able to access the outer git repo:
 

test/blackbox-tests/test-cases/cram/hg-access.t

@@ -25,7 +25,6 @@ enough for a few hg commands such as "hg root" to succeed:
   +  abort: repository requires features unknown to this Mercurial: Escaping the Dune sandbox
   +  (see https://mercurial-scm.org/wiki/MissingRequirement for more information)
   Promoting _build/default/test.t.corrected to test.t.
-  [1]
 
 The inner call to hg shouldn't be able to access the outer hg repo:
 

test/blackbox-tests/test-cases/formatting/dune-fmt-fail.t

@@ -0,0 +1,27 @@
+`dune fmt` should still fail when the formatter action itself fails. This
+must not be classified as a promotion-only failure.
+
+  $ make_dune_project 3.25
+  $ cat > dune <<EOF
+  > (library
+  >  (name foo))
+  > EOF
+  $ touch .ocamlformat
+  $ cat > foo.ml <<EOF
+  > let =
+  > EOF
+
+Create a formatter that behaves like ocamlformat failing to parse the source.
+
+  $ mkdir bin
+  $ cat > bin/ocamlformat <<EOF
+  > #!/bin/sh
+  > echo "ocamlformat: failed to parse foo.ml" >&2
+  > exit 1
+  > EOF
+  $ chmod +x bin/ocamlformat
+
+  $ PATH="$PWD/bin:$PATH" dune fmt
+  File "foo.ml", line 1, characters 0-0:
+  ocamlformat: failed to parse foo.ml
+  [1]

test/blackbox-tests/test-cases/formatting/fmt-after-revert.t

@@ -23,7 +23,6 @@ formatted version.
   +(rule
   + (write-file a b))
   Promoting _build/default/dune.corrected to dune.
-  [1]
 
   $ cat dune
   (rule
@@ -37,8 +36,6 @@ reported and the file is reformatted.
   > (rule (write-file a b))
   > EOF
 
-CR-soon Alizter: dune fmt is not re-running and this is a bug.
-
   $ dune fmt
   File "dune", line 1, characters 0-0:
   --- dune
@@ -48,7 +45,6 @@ CR-soon Alizter: dune fmt is not re-running and this is a bug.
   +(rule
   + (write-file a b))
   Promoting _build/default/dune.corrected to dune.
-  [1]
   $ cat dune
   (rule
    (write-file a b))

test/blackbox-tests/test-cases/formatting/fmt-no-promote.t

@@ -39,7 +39,6 @@ Actually format the file
   +(rule
   + (write-file a b))
   Promoting _build/default/dune.corrected to dune.
-  [1]
 
 Now the output of `dune fmt --preview is empty`.
   $ dune fmt --preview

test/blackbox-tests/test-cases/formatting/format-alternative.t

@@ -21,7 +21,6 @@ Dune files names dune-file should be formatted
   +  foo
   +  (echo bar)))
   Promoting _build/default/dune-file.corrected to dune-file.
-  [1]
 
   $ cat dune-file
   (rule

test/blackbox-tests/test-cases/inline-tests/clicolor-force-inline-tests-github6607.t

@@ -42,7 +42,6 @@ file.
   -  [%expect]
   +  [%expect {| Error: |}]
   Promoting _build/default/l.ml.corrected to l.ml.
-  [1]
   $ < l.ml tr '\033' '?'
   open[@ocaml.alert "-unstable"] Stdune
 
@@ -61,7 +60,6 @@ file.
   -  [%expect {| Error: |}]
   +  [%expect {| Error: |}]
   Promoting _build/default/l.ml.corrected to l.ml.
-  [1]
   $ < l.ml tr '\033' '?'
   open[@ocaml.alert "-unstable"] Stdune
 

test/blackbox-tests/test-cases/menhir/opam-menhir-dep.t

@@ -15,7 +15,6 @@ Case 0: package does not declare menhir. Dune does not add it.
   > EOF
 
   $ dune build @opam --auto-promote > /dev/null 2>&1
-  [1]
   $ grep menhir foo.opam
   [1]
 
@@ -32,7 +31,6 @@ Case 1: bare [(depends menhir)]. Dune fills in the lower bound.
   > EOF
 
   $ dune build @opam --auto-promote > /dev/null 2>&1
-  [1]
   $ grep menhir foo.opam
     "menhir" {>= "20180523"}
 
@@ -49,7 +47,6 @@ Case 2: user-written version bound is preserved verbatim.
   > EOF
 
   $ dune build @opam --auto-promote > /dev/null 2>&1
-  [1]
   $ grep menhir foo.opam
     "menhir" {>= "20211128"}
 
@@ -68,7 +65,6 @@ for an unrelated reason (e.g. runtime).
   > EOF
 
   $ dune build @opam --auto-promote > /dev/null 2>&1
-  [1]
   $ grep menhir foo.opam
     "menhir"
 
@@ -89,7 +85,6 @@ bound; [bar.opam] has no [menhir] line at all.
   > EOF
 
   $ dune build @opam --auto-promote > /dev/null 2>&1
-  [1]
   $ grep menhir foo.opam
     "menhir" {>= "20180523"}
   $ test -f bar.opam && grep -c '^opam-version' bar.opam
@@ -117,6 +112,5 @@ stanza for the existing opam file.
   > EOF
 
   $ dune build @opam --auto-promote > /dev/null 2>&1
-  [1]
   $ grep menhir foo.opam
     "menhir" {with-test}