Report progress for dune builds

When a dune build is running, the server will display this as a running
task.

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

Author: rgrinberg

ocaml-lsp-server/src/dune.ml

@@ -111,9 +111,13 @@ type run =
   | Out_of_date
 
 type state =
-  | Waiting_for_init of { diagnostics : Diagnostics.t }
+  | Waiting_for_init of
+      { diagnostics : Diagnostics.t
+      ; progress : Progress.t
+      }
   | Active of
       { diagnostics : Diagnostics.t
+      ; progress : Progress.t
       ; finish : unit Fiber.Ivar.t
       ; chan : Chan.t
       }
@@ -127,13 +131,14 @@ let stop (t : t) =
   | Waiting_for_init _ ->
     t := Closed;
     Fiber.return ()
-  | Active { finish; chan; diagnostics = _ } ->
+  | Active { finish; chan; progress = _; diagnostics = _ } ->
     t := Closed;
     let pid = Chan.pid chan in
     Unix.kill (Pid.to_int pid) Sys.sigstop;
     Fiber.Ivar.fill finish ()
 
-let create diagnostics = ref (Waiting_for_init { diagnostics })
+let create diagnostics progress =
+  ref (Waiting_for_init { diagnostics; progress })
 
 let lsp_of_dune uri dune =
   let module D = Drpc.Diagnostic in
@@ -178,13 +183,13 @@ let run_rpc (t : t) bin =
   match !t with
   | Closed -> Code_error.raise "dune already closed" []
   | Active _ -> Code_error.raise "dune alrady running" []
-  | Waiting_for_init { diagnostics } ->
+  | Waiting_for_init { diagnostics; progress } ->
     Diagnostics.update_dune_status diagnostics Disconnected;
     let open Fiber.O in
     let finish = Fiber.Ivar.create () in
     let* chan = Chan.create bin in
-    t := Active { diagnostics; finish; chan };
-    let+ () =
+    t := Active { diagnostics; finish; chan; progress };
+    let* () =
       Fiber.parallel_iter
         ~f:(fun f -> f ())
         [ (fun () -> Diagnostics.send diagnostics)
@@ -198,6 +203,13 @@ let run_rpc (t : t) bin =
               Drpc.Initialize.create ~id:(Drpc.Id.make (Atom "ocamllsp"))
             in
             let handler =
+              let build_event, build_progress =
+                if Progress.should_report_build_progress progress then
+                  Progress.
+                    (Some (build_event progress), Some (build_progress progress))
+                else
+                  (None, None)
+              in
               let diagnostic evs =
                 List.iter evs ~f:(fun (ev : Drpc.Diagnostic.Event.t) ->
                     let id =
@@ -220,19 +232,26 @@ let run_rpc (t : t) bin =
                         (`Dune (id, uri, lsp_of_dune uri d)));
                 Diagnostics.send diagnostics
               in
-              Client.Handler.create ~diagnostic ()
+              Client.Handler.create ?build_event ?build_progress ~diagnostic ()
             in
             Client.connect ~handler chan init ~f:(fun client ->
                 Diagnostics.update_dune_status diagnostics Connected;
-                let* () = Diagnostics.send diagnostics in
-                let sub = Drpc.Subscribe.Diagnostics in
                 let* () =
-                  Client.notification client Drpc.Notification.subscribe sub
+                  let sub what =
+                    Client.notification client Drpc.Notification.subscribe what
+                  in
+                  if Progress.should_report_build_progress progress then
+                    Fiber.fork_and_join_unit
+                      (fun () -> sub Diagnostics)
+                      (fun () -> sub Build_progress)
+                  else
+                    sub Diagnostics
                 in
                 Fiber.Ivar.read finish))
         ]
     in
-    t := Waiting_for_init { diagnostics }
+    t := Waiting_for_init { diagnostics; progress };
+    Progress.end_build_if_running progress
 
 let run t : (unit, run) result Fiber.t =
   match !t with

ocaml-lsp-server/src/dune.mli

@@ -8,6 +8,6 @@ type t
 
 val run : t -> (unit, run) result Fiber.t
 
-val create : Diagnostics.t -> t
+val create : Diagnostics.t -> Progress.t -> t
 
 val stop : t -> unit Fiber.t

ocaml-lsp-server/src/import.ml

@@ -19,6 +19,7 @@ module Loc = Location
 module Scheduler = Fiber_unix.Scheduler
 module Server = Lsp_fiber.Server
 module Client_request = Lsp.Client_request
+module Server_request = Lsp.Server_request
 module Client_notification = Lsp.Client_notification
 module Text_document = Lsp.Text_document
 open Lsp.Types
@@ -38,6 +39,13 @@ module DiagnosticRelatedInformation = DiagnosticRelatedInformation
 module PublishDiagnosticsParams = PublishDiagnosticsParams
 module MessageType = MessageType
 module WorkspaceEdit = WorkspaceEdit
+module ProgressToken = ProgressToken
+module WorkDoneProgressCreateParams = WorkDoneProgressCreateParams
+module WorkDoneProgressBegin = WorkDoneProgressBegin
+module WorkDoneProgressReport = WorkDoneProgressReport
+module WorkDoneProgressEnd = WorkDoneProgressEnd
+module ProgressParams = ProgressParams
+module ExecuteCommandOptions = ExecuteCommandOptions
 module TextEdit = TextEdit
 module CodeActionKind = CodeActionKind
 module ShowMessageParams = ShowMessageParams

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -974,7 +974,18 @@ let start () =
         Fiber.fork_and_join_unit
           (fun () -> Server.start server)
           (fun () ->
-            let* (_ : InitializeParams.t) = Server.initialized server in
+            let* (init_params : InitializeParams.t) =
+              Server.initialized server
+            in
+            let progress =
+              Progress.create init_params.capabilities
+                ~report_progress:(fun progress ->
+                  Server.notification server
+                    (Server_notification.WorkDoneProgress progress))
+                ~create_task:(fun task ->
+                  Server.request server
+                    (Server_request.WorkDoneProgressCreate task))
+            in
             let dune =
               let dune' = Dune.create diagnostics progress in
               dune := Some dune';

ocaml-lsp-server/src/progress.ml

@@ -0,0 +1,95 @@
+open Import
+
+type enabled =
+  (* TODO this needs to be mutexed *)
+  { mutable token : ProgressToken.t option
+  ; mutable build_counter : int
+  ; report_progress :
+      Server_notification.Progress.t ProgressParams.t -> unit Fiber.t
+  ; create_task : WorkDoneProgressCreateParams.t -> unit Fiber.t
+  }
+
+type t =
+  | Disabled
+  | Enabled of enabled
+
+let create (client_capabilities : ClientCapabilities.t) ~report_progress
+    ~create_task =
+  match client_capabilities.window with
+  | Some { workDoneProgress = Some true; _ } ->
+    Enabled { token = None; build_counter = 0; create_task; report_progress }
+  | _ -> Disabled
+
+let end_build (t : enabled) ~message =
+  match t.token with
+  | None -> Fiber.return ()
+  | Some token ->
+    t.token <- None;
+    t.report_progress
+      (ProgressParams.create ~token
+         ~value:
+           (Server_notification.Progress.End
+              (WorkDoneProgressEnd.create ~message ())))
+
+let end_build_if_running = function
+  | Disabled -> Fiber.return ()
+  | Enabled e -> end_build e ~message:"Build interrupted"
+
+let start_build (t : enabled) =
+  let open Fiber.O in
+  let* () = end_build t ~message:"Starting new build" in
+  let token = `String ("dune-build-" ^ Int.to_string t.build_counter) in
+  t.token <- Some token;
+  t.build_counter <- t.build_counter + 1;
+  let* () = t.create_task (WorkDoneProgressCreateParams.create ~token) in
+  t.token <- Some token;
+  let+ () =
+    t.report_progress
+      (ProgressParams.create ~token
+         ~value:
+           (Server_notification.Progress.Begin
+              (WorkDoneProgressBegin.create ~title:"Build" ~message:"started" ())))
+  in
+  token
+
+let build_event t (event : Drpc.Build.Event.t) =
+  match t with
+  | Disabled -> Code_error.raise "progress reporting is not supported" []
+  | Enabled t -> (
+    match event with
+    | Finish -> end_build t ~message:"Build finished"
+    | Fail -> end_build t ~message:"Build failed"
+    | Interrupt -> end_build t ~message:"Build interrupted"
+    | Start ->
+      let open Fiber.O in
+      let+ (_ : ProgressToken.t) = start_build t in
+      ())
+
+let build_progress t (progress : Drpc.Progress.t) =
+  match t with
+  | Disabled -> Code_error.raise "progress reporting is not supported" []
+  | Enabled ({ token; report_progress; _ } as t) ->
+    let open Fiber.O in
+    let* token =
+      match token with
+      | Some token -> Fiber.return token
+      | None ->
+        (* This can happen when we connect to dune in the middle of a build. *)
+        start_build t
+    in
+    let percentage =
+      let fraction =
+        float_of_int progress.complete
+        /. float_of_int (progress.complete + progress.remaining)
+      in
+      int_of_float (fraction *. 100.)
+    in
+    report_progress
+      (ProgressParams.create ~token
+         ~value:
+           (Server_notification.Progress.Report
+              (WorkDoneProgressReport.create ~percentage ~message:"Building" ())))
+
+let should_report_build_progress = function
+  | Disabled -> false
+  | Enabled _ -> true

ocaml-lsp-server/src/progress.mli

@@ -0,0 +1,18 @@
+open Import
+
+type t
+
+val create :
+     ClientCapabilities.t
+  -> report_progress:
+       (Server_notification.Progress.t ProgressParams.t -> unit Fiber.t)
+  -> create_task:(WorkDoneProgressCreateParams.t -> unit Fiber.t)
+  -> t
+
+val end_build_if_running : t -> unit Fiber.t
+
+val build_event : t -> Drpc.Build.Event.t -> unit Fiber.t
+
+val build_progress : t -> Drpc.Progress.t -> unit Fiber.t
+
+val should_report_build_progress : t -> bool