rpc: add failed jobs to progress

Signed-off-by: Ali Caglayan <alizter@gmail.com>

CHANGES.md

@@ -6,6 +6,9 @@ Unreleased
 3.10.0 (2023-07-31)
 -------------------
 
+- The `progress` RPC procedure now has an extra field for the `In_progress`
+  constructor for the number of failed jobs. (#8212, @Alizter)
+
 - Add `dune show rules` as alias of the `dune rules` command. (#8000, @Alizter)
 
 - Fix `%{deps}` to expand properly in `(cat ...)` when containing 2 or more

otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml

@@ -34,9 +34,12 @@ let () =
            | Some Success -> "Success"
            | Some Failed -> "Failed"
            | Some Interrupted -> "Interrupted"
-           | Some (In_progress { complete; remaining }) ->
-             Printf.sprintf "In_progress { complete = %d;  remaining = %d }"
+           | Some (In_progress { complete; remaining; failed }) ->
+             Printf.sprintf "In_progress { complete = %d;  remaining = %d%s }"
                complete remaining
+               (match failed with
+               | 0 -> ""
+               | failed -> Printf.sprintf "; failed = %d" failed)
            | Some Waiting -> "Waiting"
          in
          print_endline (Printf.sprintf "Got progress_event: %s" message);

otherlibs/dune-rpc/dune_rpc.mli

@@ -175,6 +175,7 @@ module V1 : sig
       | In_progress of
           { complete : int
           ; remaining : int
+          ; failed : int
           }
       | Failed
       | Interrupted

otherlibs/dune-rpc/private/exported_types.ml

@@ -325,6 +325,7 @@ module Progress = struct
     | In_progress of
         { complete : int
         ; remaining : int
+        ; failed : int
         }
     | Failed
     | Interrupted
@@ -337,9 +338,11 @@ module Progress = struct
     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 (both complete remaining))
-        (fun (complete, remaining) -> In_progress { complete; remaining })
+        (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
@@ -349,8 +352,8 @@ module Progress = struct
     in
     let serialize = function
       | Waiting -> case () waiting
-      | In_progress { complete; remaining } ->
-        case (complete, remaining) in_progress
+      | In_progress { complete; remaining; failed } ->
+        case (complete, remaining, failed) in_progress
       | Failed -> case () failed
       | Interrupted -> case () interrupted
       | Success -> case () success

otherlibs/dune-rpc/private/exported_types.mli

@@ -132,6 +132,7 @@ module Progress : sig
     | In_progress of
         { complete : int
         ; remaining : int
+        ; failed : int
         }
     | Failed
     | Interrupted

otherlibs/dune-rpc/private/procedures.ml

@@ -118,12 +118,48 @@ module Poll = struct
   let name t = t.name
 
   module Progress = struct
+    module V1 = struct
+      open Progress
+
+      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
+          constr "in_progress"
+            (record (both complete remaining))
+            (fun (complete, remaining) ->
+              In_progress { complete; remaining; failed = 0 })
+        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) in_progress
+          | Failed -> case () failed
+          | Interrupted -> case () interrupted
+          | Success -> case () success
+        in
+        sum constrs serialize
+    end
+
     let name = "progress"
 
     let v1 =
+      Decl.Request.make_current_gen ~req:Id.sexp ~resp:(Conv.option V1.sexp)
+        ~version:1
+
+    let v2 =
       Decl.Request.make_current_gen ~req:Id.sexp
         ~resp:(Conv.option Progress.sexp)
-        ~version:1
+        ~version:2
   end
 
   module Diagnostic = struct
@@ -146,7 +182,7 @@ module Poll = struct
 
   let progress =
     let open Progress in
-    make name [ v1 ]
+    make name [ v1; v2 ]
 
   let diagnostic =
     let open Diagnostic in

src/dune_rpc_impl/server.ml

@@ -303,10 +303,12 @@ let handler (t : _ t Fdecl.t) action_runner_server handle :
       | Build_succeeded__now_waiting_for_changes -> Success
       | Build_failed__now_waiting_for_changes -> Failed
       | Building now ->
-        let remaining =
-          now.number_of_rules_discovered - now.number_of_rules_executed
-        in
-        In_progress { complete = now.number_of_rules_executed; remaining }
+        In_progress
+          { complete = now.number_of_rules_executed
+          ; remaining =
+              now.number_of_rules_discovered - now.number_of_rules_executed
+          ; failed = now.number_of_rules_failed
+          }
     in
     Handler.implement_long_poll rpc Procedures.Poll.progress Build_system.state
       ~equal:Build_system.State.equal ~diff