diff --git a/otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml b/otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml index fa6138127565..56c707421d7e 100644 --- a/otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml +++ b/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); diff --git a/otherlibs/dune-rpc/dune_rpc.mli b/otherlibs/dune-rpc/dune_rpc.mli index 00806839ff06..b5fdd67924f9 100644 --- a/otherlibs/dune-rpc/dune_rpc.mli +++ b/otherlibs/dune-rpc/dune_rpc.mli @@ -175,6 +175,7 @@ module V1 : sig | In_progress of { complete : int ; remaining : int + ; failed : int } | Failed | Interrupted diff --git a/otherlibs/dune-rpc/private/exported_types.ml b/otherlibs/dune-rpc/private/exported_types.ml index 7ca6739aec99..56609f87e0b3 100644 --- a/otherlibs/dune-rpc/private/exported_types.ml +++ b/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 diff --git a/otherlibs/dune-rpc/private/exported_types.mli b/otherlibs/dune-rpc/private/exported_types.mli index 0cdc14a6dd2c..b2005542ddfb 100644 --- a/otherlibs/dune-rpc/private/exported_types.mli +++ b/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 diff --git a/otherlibs/dune-rpc/private/procedures.ml b/otherlibs/dune-rpc/private/procedures.ml index 30ac95a8d16a..96b0ab7bbcc0 100644 --- a/otherlibs/dune-rpc/private/procedures.ml +++ b/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 diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index 61adb0aa3003..80ecd901ab3a 100644 --- a/src/dune_rpc_impl/server.ml +++ b/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