feature: show number of errors when waiting in watch mode

This displays: Had 4 errors, waiting for filesystem changes... When the watch mode 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 17, 2023 · 6f573d2 · 6f573d2
1 parent 265ab8e
commit 6f573d2
Show file tree

Hide file tree

Showing 12 changed files with 117 additions and 24 deletions.
diff --git a/bin/import.ml b/bin/import.ml
@@ -154,7 +154,16 @@ 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
+              Build_system.Error.(
+                Id.Map.cardinal (Set.current (Fiber.Svar.read Build_system.errors)))
+            with
+            | 1 -> Pp.textf "Had 1 error"
+            | n -> Pp.textf "Had %d errors" n
+          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_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml
@@ -303,7 +303,13 @@ 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 ->
+        let number_of_errors =
+          Fiber.Svar.read Build_system.errors
+          |> Build_system.Error.Set.current
+          |> Build_system.Error.Id.Map.cardinal
+        in
+        Failed number_of_errors
       | 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)