Unify and simplify the error handling

bin/build_cmd.ml

@@ -1,12 +1,10 @@
 open Stdune
 open Import
 
-let run_build_system ?report_error ~common ~(request : unit Action_builder.t) ()
-    =
+let run_build_system ~common ~(request : unit Action_builder.t) () =
   let build_started = Unix.gettimeofday () in
   Fiber.finalize
-    (fun () ->
-      Build_system.run ?report_error (fun () -> Build_system.build request))
+    (fun () -> Build_system.run (fun () -> Build_system.build request))
     ~finally:(fun () ->
       (if Common.print_metrics common then
         let gc_stat = Gc.quick_stat () in
@@ -22,30 +20,35 @@ let run_build_system ?report_error ~common ~(request : unit Action_builder.t) ()
 
 let run_build_command_poll ~(common : Common.t) ~config ~request ~setup =
   let open Fiber.O in
-  let every ~report_error () =
-    Cached_digest.invalidate_cached_timestamps ();
-    let* setup = setup () in
-    let* request =
-      match
-        let open Option.O in
-        let* rpc = Common.rpc common in
-        Dune_rpc_impl.Server.pending_build_action rpc
-      with
-      | None -> Fiber.return (request setup)
-      | Some (Build (targets, ivar)) ->
-        let+ () = Fiber.Ivar.fill ivar Accepted in
-        Target.interpret_targets (Common.root common) config setup targets
-    in
-    let+ () = run_build_system ~report_error ~common ~request () in
-    `Continue
+  let every =
+    Fiber.of_thunk (fun () ->
+        Cached_digest.invalidate_cached_timestamps ();
+        let* setup = setup () in
+        let* request =
+          match
+            let open Option.O in
+            let* rpc = Common.rpc common in
+            Dune_rpc_impl.Server.pending_build_action rpc
+          with
+          | None -> Fiber.return (request setup)
+          | Some (Build (targets, ivar)) ->
+            let+ () = Fiber.Ivar.fill ivar Accepted in
+            Target.interpret_targets (Common.root common) config setup targets
+        in
+        run_build_system ~common ~request ())
   in
   Scheduler.poll ~common ~config ~every ~finally:Hooks.End_of_build.run
 
 let run_build_command_once ~(common : Common.t) ~config ~request ~setup =
   let open Fiber.O in
   let once () =
     let* setup = setup () in
-    run_build_system ~common ~request:(request setup) ()
+    let+ res = run_build_system ~common ~request:(request setup) () in
+    match res with
+    | Error `Already_reported ->
+      (* to ensure non-zero exit code *)
+      raise Dune_util.Report_error.Already_reported
+    | Ok () -> ()
   in
   Scheduler.go ~common ~config once
 

bin/exec.ml

@@ -85,7 +85,7 @@ let term =
       in
       let* prog =
         let open Memo.Build.O in
-        Build_system.run (fun () ->
+        Build_system.run_exn (fun () ->
             match Filename.analyze_program_name prog with
             | In_path -> (
               Super_context.resolve_program sctx ~dir ~loc:None prog

bin/import.ml

@@ -99,9 +99,10 @@ module Scheduler = struct
     let file_watcher = Common.file_watcher common in
     let run =
       let run () =
-        Scheduler.Run.poll (fun ~report_error () ->
-            Fiber.finalize (every ~report_error) ~finally:(fun () ->
-                Fiber.return (finally ())))
+        Scheduler.Run.poll
+          (Fiber.finalize
+             (fun () -> every)
+             ~finally:(fun () -> Fiber.return (finally ())))
       in
       match Common.rpc common with
       | None -> run

bin/print_rules.ml

@@ -266,7 +266,7 @@ let term =
   Scheduler.go ~common ~config (fun () ->
       let open Fiber.O in
       let* setup = Import.Main.setup () in
-      Build_system.run (fun () ->
+      Build_system.run_exn (fun () ->
           let open Memo.Build.O in
           let* request =
             match targets with

bin/printenv.ml

@@ -75,7 +75,7 @@ let term =
             User_error.raise
               [ Pp.text "Environment is not defined in install dirs" ])
       in
-      Build_system.run (fun () -> Build_system.build request) >>| function
+      Build_system.run_exn (fun () -> Build_system.build request) >>| function
       | [ (_, env) ] -> Format.printf "%a" (pp ~fields) env
       | l ->
         List.iter l ~f:(fun (name, env) ->

bin/top.ml

@@ -33,7 +33,7 @@ let term =
   Scheduler.go ~common ~config (fun () ->
       let open Fiber.O in
       let* setup = Import.Main.setup () in
-      Build_system.run (fun () ->
+      Build_system.run_exn (fun () ->
           let open Memo.Build.O in
           let sctx =
             Dune_engine.Context_name.Map.find setup.scontexts ctx_name

bin/utop.ml

@@ -29,7 +29,7 @@ let term =
     Scheduler.go ~common ~config (fun () ->
         let open Fiber.O in
         let* setup = Import.Main.setup () in
-        Build_system.run (fun () ->
+        Build_system.run_exn (fun () ->
             let open Memo.Build.O in
             let context = Import.Main.find_context_exn setup ~name:ctx_name in
             let sctx = Import.Main.find_scontext_exn setup ~name:ctx_name in

src/dune_engine/build_system.ml

@@ -2272,25 +2272,40 @@ let prefix_rules (prefix : unit Action_builder.t) ~f =
   in
   res
 
-let report_early_exn ~report_error exn =
+let caused_by_cancellation (exn : Exn_with_backtrace.t) =
+  match exn.exn with
+  | Scheduler.Run.Build_cancelled -> true
+  | Memo.Error.E err -> (
+    match Memo.Error.get err with
+    | Scheduler.Run.Build_cancelled -> true
+    | _ -> false)
+  | _ -> false
+
+let report_early_exn exn =
   let t = t () in
-  let error = { Error.exn; id = Error.Id.gen () } in
-  t.errors <- error :: t.errors;
-  (match !Clflags.report_errors_config with
-  | Early
-  | Twice ->
-    report_error exn
-  | Deterministic -> ());
-  t.handler.error [ Add error ]
-
-let reraise_exn exn =
+  match caused_by_cancellation exn with
+  | true -> Fiber.return ()
+  | false ->
+    let error = { Error.exn; id = Error.Id.gen () } in
+    t.errors <- error :: t.errors;
+    (match !Clflags.report_errors_config with
+    | Early
+    | Twice ->
+      Dune_util.Report_error.report exn
+    | Deterministic -> ());
+    t.handler.error [ Add error ]
+
+let handle_final_exns exns =
   match !Clflags.report_errors_config with
-  | Early -> raise Dune_util.Report_error.Already_reported
+  | Early -> ()
   | Twice
   | Deterministic ->
-    Exn_with_backtrace.reraise exn
+    let report exn =
+      if not (caused_by_cancellation exn) then Dune_util.Report_error.report exn
+    in
+    List.iter exns ~f:report
 
-let run ?(report_error = Dune_util.Report_error.report) f =
+let run f =
   let open Fiber.O in
   Hooks.End_of_build.once Promotion.finalize;
   let t = t () in
@@ -2307,15 +2322,27 @@ let run ?(report_error = Dune_util.Report_error.report) f =
   let f () =
     let* () = t.handler.build_event Start in
     let* res =
-      Fiber.with_error_handler ~on_error:reraise_exn (fun () ->
+      Fiber.collect_errors (fun () ->
           Memo.Build.run_with_error_handler (f ())
-            ~handle_error_no_raise:(report_early_exn ~report_error))
+            ~handle_error_no_raise:report_early_exn)
     in
-    let+ () = t.handler.build_event Finish in
-    res
+    match res with
+    | Ok res ->
+      let+ () = t.handler.build_event Finish in
+      Ok res
+    | Error exns ->
+      handle_final_exns exns;
+      Fiber.return (Error `Already_reported)
   in
   Fiber.Mutex.with_lock t.build_mutex f
 
+let run_exn f =
+  let open Fiber.O in
+  let+ res = run f in
+  match res with
+  | Ok res -> res
+  | Error `Already_reported -> raise Dune_util.Report_error.Already_reported
+
 let build_file = build_file
 
 let build_deps = build_deps

src/dune_engine/build_system.mli

@@ -183,9 +183,10 @@ val files_in_source_tree_to_delete : unit -> Path.Set.t
 (** {2 Running a build} *)
 
 val run :
-     ?report_error:(Exn_with_backtrace.t -> unit)
-  -> (unit -> 'a Memo.Build.t)
-  -> 'a Fiber.t
+  (unit -> 'a Memo.Build.t) -> ('a, [ `Already_reported ]) Result.t Fiber.t
+
+(** A variant of [run] that raises an [Already_reported] exception on error. *)
+val run_exn : (unit -> 'a Memo.Build.t) -> 'a Fiber.t
 
 (** {2 Misc} *)
 

src/dune_engine/scheduler.ml

@@ -611,13 +611,15 @@ let ignore_for_watch p =
   let+ t = t () in
   Event.Queue.ignore_next_file_change_event t.events p
 
+exception Build_cancelled
+
 let with_job_slot f =
   let* t = t () in
   let raise_if_cancelled () =
     match t.status with
     | Restarting_build _
     | Shutting_down ->
-      raise (Memo.Non_reproducible (Failure "Build cancelled"))
+      raise (Memo.Non_reproducible Build_cancelled)
     | Building -> ()
     | Waiting_for_file_changes _ ->
       (* At this stage, we're not running a build, so we shouldn't be running
@@ -825,6 +827,8 @@ module Worker = struct
 end
 
 module Run = struct
+  exception Build_cancelled = Build_cancelled
+
   type file_watcher =
     | Detect_external
     | No_watcher
@@ -836,26 +840,7 @@ module Run = struct
     let* t = t () in
     let rec loop () : unit Fiber.t =
       t.status <- Building;
-      let* res =
-        let report_error exn =
-          match t.status with
-          | Building -> Dune_util.Report_error.report exn
-          | Shutting_down
-          | Restarting_build _ ->
-            ()
-          | Waiting_for_file_changes _ ->
-            (* We are inside a build, so we aren't waiting for a file change
-               event *)
-            assert false
-        in
-        let on_error exn =
-          report_error exn;
-          Fiber.return ()
-        in
-        Fiber.map_reduce_errors
-          (module Monoid.Unit)
-          ~on_error (step ~report_error)
-      in
+      let* res = step in
       match t.status with
       | Waiting_for_file_changes _ ->
         (* We just finished a build, so there's no way this was set *)
@@ -880,10 +865,9 @@ module Run = struct
           Memo.reset invalidations;
           t.handler t.config Source_files_changed;
           match res with
-          | Error _
-          | Ok `Continue ->
-            loop ()
-          | Ok `Stop -> Fiber.return ()))
+          | Error `Already_reported
+          | Ok () ->
+            loop ()))
     in
     loop ()
 

src/dune_engine/scheduler.mli

@@ -57,18 +57,16 @@ module Run : sig
       cases *)
   exception Shutdown_requested
 
+  exception Build_cancelled
+
   (** Runs [once] in a loop, executing [finally] after every iteration, even if
       Fiber.Never was encountered.
 
       If any source files change in the middle of iteration, it gets canceled.
 
       If [shutdown] is called, the current build will be canceled and new builds
       will not start. *)
-  val poll :
-       (   report_error:(Exn_with_backtrace.t -> unit)
-        -> unit
-        -> [ `Continue | `Stop ] Fiber.t)
-    -> unit Fiber.t
+  val poll : (unit, [ `Already_reported ]) Result.t Fiber.t -> unit Fiber.t
 
   val go :
        Config.t