feature: show number of errors when waiting in watch mode

This is a feature that I added to Dune monitor by keeping track of the cardinality of the diagnostics sent. We can do better in general by threading the correct information through the build system. This displays: Had 4 errors When the watchmode build has been finished with 4 errors. For a single error it say "Had 1 error". Signed-off-by: Ali Caglayan <[email protected]>
ocaml · Aug 16, 2023 · 0b93ecc · 0b93ecc
1 parent 5f57c3d
commit 0b93ecc
Show file tree

Hide file tree

Showing 14 changed files with 119 additions and 31 deletions.
diff --git a/bin/import.ml b/bin/import.ml
@@ -88,7 +88,7 @@ end = struct
            | Initializing
            | Restarting_current_build
            | Build_succeeded__now_waiting_for_changes
-           | Build_failed__now_waiting_for_changes -> Pp.nop
+           | Build_failed__now_waiting_for_changes _ -> Pp.nop
            | Building
                { Build_system.Progress.number_of_rules_executed = done_
                ; number_of_rules_discovered = total
@@ -140,7 +140,7 @@ module Scheduler = struct
                | Initializing
                | Restarting_current_build
                | Build_succeeded__now_waiting_for_changes
-               | Build_failed__now_waiting_for_changes -> Build_system.Progress.init
+               | Build_failed__now_waiting_for_changes _ -> Build_system.Progress.init
                | Building progress -> progress
              in
              Pp.seq
@@ -154,7 +154,14 @@ module Scheduler = struct
       let message =
         match build_result with
         | Success -> Pp.tag User_message.Style.Success (Pp.verbatim "Success")
-        | Failure -> Pp.tag User_message.Style.Error (Pp.verbatim "Had errors")
+        | Failure ->
+          let failure_message =
+            match Fiber.Svar.read Build_system.state with
+            | Build_failed__now_waiting_for_changes 1 -> Pp.textf "Had 1 error"
+            | Build_failed__now_waiting_for_changes n -> Pp.textf "Had %d errors" n
+            | _ -> Pp.verbatim "Had errors"
+          in
+          Pp.tag User_message.Style.Error failure_message
       in
       Console.Status_line.set
         (Constant (Pp.seq message (Pp.verbatim ", waiting for filesystem changes...")))

diff --git a/doc/changes/8408.md b/doc/changes/8408.md
@@ -0,0 +1,2 @@
+- Dune now displays the number of errors when waiting for changes in watch mode. (#8408,
+  @Alizter)
diff --git a/otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml b/otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml
@@ -30,7 +30,7 @@ let () =
          match progress_event with
          | None -> "(none)"
          | Some Success -> "Success"
-         | Some Failed -> "Failed"
+         | Some (Failed number) -> Printf.sprintf "Failed with %d errors" number
          | Some Interrupted -> "Interrupted"
          | Some (In_progress { complete; remaining; failed }) ->
            Printf.sprintf

diff --git a/otherlibs/dune-rpc/dune_rpc.mli b/otherlibs/dune-rpc/dune_rpc.mli
@@ -160,7 +160,7 @@ module V1 : sig
           ; remaining : int
           ; failed : int
           }
-      | Failed
+      | Failed of int
       | Interrupted
       | Success
   end

diff --git a/otherlibs/dune-rpc/private/exported_types.ml b/otherlibs/dune-rpc/private/exported_types.ml
@@ -316,14 +316,14 @@ module Progress = struct
         ; remaining : int
         ; failed : int
         }
-    | Failed
+    | Failed of int
     | Interrupted
     | Success
 
   let sexp =
     let open Conv in
     let waiting = constr "waiting" unit (fun () -> Waiting) in
-    let failed = constr "failed" unit (fun () -> Failed) in
+    let failed = constr "failed" int (fun failed -> Failed failed) in
     let in_progress =
       let complete = field "complete" (required int) in
       let remaining = field "remaining" (required int) in
@@ -336,14 +336,14 @@ module Progress = struct
     let interrupted = constr "interrupted" unit (fun () -> Interrupted) in
     let success = constr "success" unit (fun () -> Success) in
     let constrs =
-      List.map ~f:econstr [ waiting; failed; interrupted; success ]
-      @ [ econstr in_progress ]
+      List.map ~f:econstr [ waiting; interrupted; success ]
+      @ [ econstr failed; econstr in_progress ]
     in
     let serialize = function
       | Waiting -> case () waiting
       | In_progress { complete; remaining; failed } ->
         case (complete, remaining, failed) in_progress
-      | Failed -> case () failed
+      | Failed n -> case n failed
       | Interrupted -> case () interrupted
       | Success -> case () success
     in

diff --git a/otherlibs/dune-rpc/private/exported_types.mli b/otherlibs/dune-rpc/private/exported_types.mli
@@ -111,7 +111,7 @@ module Progress : sig
         ; remaining : int
         ; failed : int
         }
-    | Failed
+    | Failed of int
     | Interrupted
     | Success
 

diff --git a/otherlibs/dune-rpc/private/procedures.ml b/otherlibs/dune-rpc/private/procedures.ml
@@ -144,7 +144,7 @@ module Poll = struct
         | Waiting -> Waiting
         | In_progress { complete; remaining } ->
           In_progress { complete; remaining; failed = 0 }
-        | Failed -> Failed
+        | Failed -> Failed 0
         | Interrupted -> Interrupted
         | Success -> Success
       ;;
@@ -153,7 +153,69 @@ module Poll = struct
         | Waiting -> Waiting
         | In_progress { complete; remaining; failed = _ } ->
           In_progress { complete; remaining }
-        | Failed -> Failed
+        | Failed _ -> Failed
+        | Interrupted -> Interrupted
+        | Success -> Success
+      ;;
+    end
+
+    module V2 = struct
+      type t =
+        | Waiting
+        | In_progress of
+            { complete : int
+            ; remaining : int
+            ; failed : int
+            }
+        | Failed
+        | Interrupted
+        | Success
+
+      let sexp =
+        let open Conv in
+        let waiting = constr "waiting" unit (fun () -> Waiting) in
+        let failed = constr "failed" unit (fun () -> Failed) in
+        let in_progress =
+          let complete = field "complete" (required int) in
+          let remaining = field "remaining" (required int) in
+          let failed = field "failed" (required int) in
+          constr
+            "in_progress"
+            (record (three complete remaining failed))
+            (fun (complete, remaining, failed) ->
+              In_progress { complete; remaining; failed })
+        in
+        let interrupted = constr "interrupted" unit (fun () -> Interrupted) in
+        let success = constr "success" unit (fun () -> Success) in
+        let constrs =
+          List.map ~f:econstr [ waiting; failed; interrupted; success ]
+          @ [ econstr in_progress ]
+        in
+        let serialize = function
+          | Waiting -> case () waiting
+          | In_progress { complete; remaining; failed } ->
+            case (complete, remaining, failed) in_progress
+          | Failed -> case () failed
+          | Interrupted -> case () interrupted
+          | Success -> case () success
+        in
+        sum constrs serialize
+      ;;
+
+      let to_progress : t -> Progress.t = function
+        | Waiting -> Waiting
+        | In_progress { complete; remaining; failed } ->
+          In_progress { complete; remaining; failed }
+        | Failed -> Failed 0
+        | Interrupted -> Interrupted
+        | Success -> Success
+      ;;
+
+      let of_progress : Progress.t -> t = function
+        | Waiting -> Waiting
+        | In_progress { complete; remaining; failed } ->
+          In_progress { complete; remaining; failed }
+        | Failed _ -> Failed
         | Interrupted -> Interrupted
         | Success -> Success
       ;;
@@ -173,9 +235,20 @@ module Poll = struct
     ;;
 
     let v2 =
-      Decl.Request.make_current_gen
+      Decl.Request.make_gen
         ~version:2
         ~req:Id.sexp
+        ~resp:(Conv.option V2.sexp)
+        ~upgrade_req:Fun.id
+        ~downgrade_req:Fun.id
+        ~upgrade_resp:(Option.map ~f:V2.to_progress)
+        ~downgrade_resp:(Option.map ~f:V2.of_progress)
+    ;;
+
+    let v3 =
+      Decl.Request.make_current_gen
+        ~version:3
+        ~req:Id.sexp
         ~resp:(Conv.option Progress.sexp)
     ;;
   end
@@ -204,7 +277,7 @@ module Poll = struct
 
   let progress =
     let open Progress in
-    make name [ v1; v2 ]
+    make name [ v1; v2; v3 ]
   ;;
 
   let diagnostic =

diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml
@@ -151,20 +151,22 @@ module State = struct
     | Building of Progress.t
     | Restarting_current_build
     | Build_succeeded__now_waiting_for_changes
-    | Build_failed__now_waiting_for_changes
+    | Build_failed__now_waiting_for_changes of int
 
   let equal x y =
     match x, y with
     | Building x, Building y -> Progress.equal x y
     | Initializing, Initializing
     | Restarting_current_build, Restarting_current_build
     | Build_succeeded__now_waiting_for_changes, Build_succeeded__now_waiting_for_changes
-    | Build_failed__now_waiting_for_changes, Build_failed__now_waiting_for_changes -> true
+      -> true
+    | Build_failed__now_waiting_for_changes x, Build_failed__now_waiting_for_changes y ->
+      Int.equal x y
     | Building _, _
     | Initializing, _
     | Restarting_current_build, _
     | Build_succeeded__now_waiting_for_changes, _
-    | Build_failed__now_waiting_for_changes, _ -> false
+    | Build_failed__now_waiting_for_changes _, _ -> false
   ;;
 
   let t = Fiber.Svar.create Initializing
@@ -1279,7 +1281,7 @@ let run f =
       let final_status =
         if List.exists exns ~f:caused_by_cancellation
         then State.Restarting_current_build
-        else Build_failed__now_waiting_for_changes
+        else Build_failed__now_waiting_for_changes (List.length exns)
       in
       let+ () = State.set final_status in
       Error `Already_reported

diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli
@@ -74,7 +74,7 @@ module State : sig
     | Building of Progress.t
     | Restarting_current_build
     | Build_succeeded__now_waiting_for_changes
-    | Build_failed__now_waiting_for_changes
+    | Build_failed__now_waiting_for_changes of int
 
   val equal : t -> t -> bool
 end

diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml
@@ -303,7 +303,8 @@ let handler (t : _ t Fdecl.t) action_runner_server handle : 'a Dune_rpc_server.H
       | Initializing -> Progress.Waiting
       | Restarting_current_build -> Interrupted
       | Build_succeeded__now_waiting_for_changes -> Success
-      | Build_failed__now_waiting_for_changes -> Failed
+      | Build_failed__now_waiting_for_changes number_of_rules_failed ->
+        Failed number_of_rules_failed
       | Building now ->
         In_progress
           { complete = now.number_of_rules_executed

diff --git a/test/blackbox-tests/test-cases/watching/basic.t b/test/blackbox-tests/test-cases/watching/basic.t
@@ -68,12 +68,12 @@ Basic tests for the file-watching mode.
   3 |  (deps x)
   4 |  (action (system "cat x > y")))
   Error: No rule found for x
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   File "dune", line 1, characters 0-59:
   1 | (rule
   2 |  (target y)
   3 |  (deps x)
   4 |  (action (system "cat x > y")))
   Error: No rule found for x
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   Success, waiting for filesystem changes...
diff --git a/test/blackbox-tests/test-cases/watching/fs-memo.t b/test/blackbox-tests/test-cases/watching/fs-memo.t
@@ -240,9 +240,9 @@ If we repeat the test, we finally see the failure.
   How about now?
   Failure
   Error: inotify_add_watch(subdir): Permission denied
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   Error: inotify_add_watch(subdir): Permission denied
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   ------------------------------------------
   result = '13' -> '13' -> '13'
   ------------------------------------------
@@ -254,9 +254,9 @@ Same problem in the other direction.
   Failure
   Failure
   Error: inotify_add_watch(subdir): Permission denied
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   Error: inotify_add_watch(subdir): Permission denied
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   ------------------------------------------
   result = '13' -> '13' -> '13'
   ------------------------------------------
@@ -288,12 +288,12 @@ Same problem for files.
   -> required by _build/default/file-1
   -> required by _build/default/result
   -> required by alias default
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   Error: file-1: Permission denied
   -> required by _build/default/file-1
   -> required by _build/default/result
   -> required by alias default
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   ------------------------------------------
   result = '13' -> '13' -> '13'
   ------------------------------------------

diff --git a/test/blackbox-tests/test-cases/watching/target-promotion.t b/test/blackbox-tests/test-cases/watching/target-promotion.t
@@ -142,7 +142,7 @@ We're done.
   - file present in source tree
   - dune:1
   Hint: rm -f promoted
-  Had errors, waiting for filesystem changes...
+  Had 1 error, waiting for filesystem changes...
   Success, waiting for filesystem changes...
   Success, waiting for filesystem changes...
   Success, waiting for filesystem changes...

diff --git a/test/expect-tests/dune_rpc/dune_rpc_tests.ml b/test/expect-tests/dune_rpc/dune_rpc_tests.ml
@@ -911,7 +911,10 @@ let%expect_test "print digests for all public RPCs" =
       Response: 889aa68f4ad3fc68ef5dfffbb7282c18
     Version 2:
       Request: Sexp
-      Response: 929074caab98360dc7116b6f27c2b9ad |}];
+      Response: 929074caab98360dc7116b6f27c2b9ad
+    Version 3:
+      Request: Sexp
+      Response: c62f32534a04d0788a44ca29e05c069b |}];
   Decl.Request.print_generations (Procedures.Poll.poll Procedures.Poll.diagnostic);
   [%expect
     {|
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,2 @@
		- Dune now displays the number of errors when waiting for changes in watch mode. (#8408,
		@Alizter)