refactor: implement progress with svar

Signed-off-by: Rudi Grinberg <[email protected]>

ps-id: 52DED725-A17B-4910-8B63-4615B1B4C9A1

bin/common.ml

@@ -185,8 +185,7 @@ let init ?log_file c =
     ];
   Dune_rules.Main.init ~stats:c.stats
     ~sandboxing_preference:config.sandboxing_preference ~cache_config
-    ~cache_debug_flags:c.cache_debug_flags
-    ~handler:(Option.map c.rpc ~f:Dune_rpc_impl.Server.build_handler);
+    ~cache_debug_flags:c.cache_debug_flags;
   Only_packages.Clflags.set c.only_packages;
   Dune_util.Report_error.print_memo_stacks := c.debug_dep_path;
   Clflags.report_errors_config := c.report_errors_config;

bin/import.ml

@@ -51,19 +51,24 @@ end = struct
     Console.Status_line.set
       (Live
          (fun () ->
-           let { Build_system.Progress.number_of_rules_executed = done_
+           match Fiber.Svar.read Build_system.state with
+           | Initializing
+           | Restarting_current_build
+           | Build_succeeded__now_waiting_for_changes
+           | Build_failed__now_waiting_for_changes ->
+             Pp.nop
+           | Building
+               { Build_system.Progress.number_of_rules_executed = done_
                ; number_of_rules_discovered = total
-               } =
-             Build_system.get_current_progress ()
-           in
-           Pp.verbatim
-             (sprintf "Done: %u%% (%u/%u, %u left) (jobs: %u)"
-                (if total = 0 then
-                  0
-                else
-                  done_ * 100 / total)
-                done_ total (total - done_)
-                (Scheduler.running_jobs_count scheduler))));
+               } ->
+             Pp.verbatim
+               (sprintf "Done: %u%% (%u/%u, %u left) (jobs: %u)"
+                  (if total = 0 then
+                    0
+                  else
+                    done_ * 100 / total)
+                  done_ total (total - done_)
+                  (Scheduler.running_jobs_count scheduler))));
     Fiber.return (Memo.Build.of_thunk get)
 end
 
@@ -96,7 +101,17 @@ module Scheduler = struct
       Console.Status_line.set
         (Live
            (fun () ->
-             let progression = Build_system.get_current_progress () in
+             let progression =
+               match Fiber.Svar.read Build_system.state with
+               | Initializing
+               | Restarting_current_build
+               | Build_succeeded__now_waiting_for_changes
+               | Build_failed__now_waiting_for_changes ->
+                 { Build_system.Progress.number_of_rules_discovered = 0
+                 ; number_of_rules_executed = 0
+                 }
+               | Building progress -> progress
+             in
              Pp.seq
                (Pp.tag User_message.Style.Error
                   (Pp.verbatim "Source files changed"))

otherlibs/dune-rpc-lwt/test/dune_rpc_lwt_tests.ml

@@ -121,7 +121,6 @@ let%expect_test "run and connect" =
          Lwt.return_unit));
   [%expect
     {|
-    Success, waiting for filesystem changes...
     started session
     received ping. shutting down.
     dune build finished with 0 |}]

src/dune_engine/build_config.ml

@@ -26,94 +26,10 @@ module type Rule_generator = sig
     -> gen_rules_result Memo.Build.t
 end
 
-module Error = struct
-  module Id = Id.Make ()
-
-  type t =
-    { exn : Exn_with_backtrace.t
-    ; id : Id.t
-    }
-
-  let create ~exn = { exn; id = Id.gen () }
-
-  let id t = t.id
-
-  let promotion t =
-    let e =
-      match t.exn.exn with
-      | Memo.Error.E e -> Memo.Error.get e
-      | e -> e
-    in
-    match e with
-    | User_error.E msg ->
-      User_message.Annots.find msg.annots Diff_promotion.Annot.annot
-    | _ -> None
-
-  let info (t : t) =
-    let e =
-      match t.exn.exn with
-      | Memo.Error.E e -> Memo.Error.get e
-      | e -> e
-    in
-    match e with
-    | User_error.E msg -> (
-      let dir =
-        User_message.Annots.find msg.annots Process.with_directory_annot
-      in
-      match User_message.Annots.find msg.annots Compound_user_error.annot with
-      | None -> (msg, [], dir)
-      | Some { main; related } -> (main, related, dir))
-    | e ->
-      (* CR-someday jeremiedimino: Use [Report_error.get_user_message] here. *)
-      (User_message.make [ Pp.text (Printexc.to_string e) ], [], None)
-end
-
-module Handler = struct
-  (* CR-someday amokhov: The name [Interrupt] is not precise, because the build
-     is restarted, not, e.g. interrupted with Ctrl-C. Similarly, we have other
-     imprecise names, like [Cancelled_due_to_file_changes] in [Scheduler] where
-     the build is not just cancelled, it's restarted. We should make the naming
-     more consistent. *)
-  type event =
-    | Start
-    | Finish
-    | Fail
-    | Interrupt
-
-  type error =
-    | Add of Error.t
-    | Remove of Error.t
-
-  type t =
-    { errors : error list -> unit Fiber.t
-    ; build_progress : complete:int -> remaining:int -> unit Fiber.t
-    ; build_event : event -> unit Fiber.t
-    }
-
-  let report_progress t ~rule_done ~rule_total =
-    t.build_progress ~complete:rule_done ~remaining:(rule_total - rule_done)
-
-  let last_event : event option ref = ref None
-
-  let report_build_event t evt =
-    last_event := Some evt;
-    t.build_event evt
-
-  let do_nothing =
-    { errors = (fun _ -> Fiber.return ())
-    ; build_progress = (fun ~complete:_ ~remaining:_ -> Fiber.return ())
-    ; build_event = (fun _ -> Fiber.return ())
-    }
-
-  let create ~errors ~build_progress ~build_event =
-    { errors; build_progress; build_event }
-end
-
 type t =
   { contexts : Build_context.t Context_name.Map.t Memo.Lazy.t
   ; rule_generator : (module Rule_generator)
   ; sandboxing_preference : Sandbox_mode.t list
-  ; handler : Handler.t
   ; promote_source :
          chmod:(int -> int)
       -> delete_dst_if_it_is_a_directory:bool
@@ -131,7 +47,7 @@ type t =
 let t = Fdecl.create Dyn.opaque
 
 let set ~stats ~contexts ~promote_source ~cache_config ~cache_debug_flags
-    ~sandboxing_preference ~rule_generator ~handler ~implicit_default_alias =
+    ~sandboxing_preference ~rule_generator ~implicit_default_alias =
   let contexts =
     Memo.lazy_ ~name:"Build_config.set" (fun () ->
         let open Memo.Build.O in
@@ -149,7 +65,6 @@ let set ~stats ~contexts ~promote_source ~cache_config ~cache_debug_flags
     ; rule_generator
     ; sandboxing_preference =
         sandboxing_preference @ Sandbox_mode.all_except_patch_back_source_tree
-    ; handler = Option.value handler ~default:Handler.do_nothing
     ; promote_source
     ; stats
     ; cache_config

src/dune_engine/build_config.mli

@@ -40,69 +40,10 @@ module type Rule_generator = sig
     -> gen_rules_result Memo.Build.t
 end
 
-(** Errors found when building targets. *)
-module Error : sig
-  type t
-
-  module Id : sig
-    type t
-
-    module Map : Map.S with type key = t
-
-    val compare : t -> t -> Ordering.t
-
-    val to_int : t -> int
-
-    val to_dyn : t -> Dyn.t
-  end
-
-  val create : exn:Exn_with_backtrace.t -> t
-
-  val info : t -> User_message.t * User_message.t list * Path.t option
-
-  val promotion : t -> Diff_promotion.Annot.t option
-
-  val id : t -> Id.t
-end
-
-(** A handler for various build events. *)
-module Handler : sig
-  type event =
-    | Start
-    | Finish
-    | Fail
-    | Interrupt
-
-  type error =
-    | Add of Error.t
-    | Remove of Error.t
-
-  type t =
-    { errors : error list -> unit Fiber.t
-    ; build_progress : complete:int -> remaining:int -> unit Fiber.t
-    ; build_event : event -> unit Fiber.t
-    }
-
-  val report_progress : t -> rule_done:int -> rule_total:int -> unit Fiber.t
-
-  val last_event : event option ref
-
-  val report_build_event : t -> event -> unit Fiber.t
-
-  val do_nothing : t
-
-  val create :
-       errors:(error list -> unit Fiber.t)
-    -> build_progress:(complete:int -> remaining:int -> unit Fiber.t)
-    -> build_event:(event -> unit Fiber.t)
-    -> t
-end
-
 type t = private
   { contexts : Build_context.t Context_name.Map.t Memo.Lazy.t
   ; rule_generator : (module Rule_generator)
   ; sandboxing_preference : Sandbox_mode.t list
-  ; handler : Handler.t
   ; promote_source :
          chmod:(int -> int)
       -> delete_dst_if_it_is_a_directory:bool
@@ -133,7 +74,6 @@ val set :
   -> cache_debug_flags:Cache_debug_flags.t
   -> sandboxing_preference:Sandbox_mode.t list
   -> rule_generator:(module Rule_generator)
-  -> handler:Handler.t option
   -> implicit_default_alias:
        (Path.Build.t -> unit Action_builder.t option Memo.Build.t)
   -> unit