feature(lsp): allow progress notifications from client

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

<!-- ps-id: bd594158-5077-4875-a27e-a0b4f7bedf54 -->

lsp/src/client_notification.ml

@@ -18,6 +18,7 @@ type t =
   | CancelRequest of Jsonrpc.Id.t
   | WorkDoneProgressCancel of WorkDoneProgressCancelParams.t
   | SetTrace of SetTraceParams.t
+  | WorkDoneProgress of Progress.t ProgressParams.t
   | UnknownNotification of Jsonrpc.Notification.t
 
 let method_ = function
@@ -37,6 +38,7 @@ let method_ = function
   | SetTrace _ -> "$/setTrace"
   | CancelRequest _ -> Cancel_request.meth_
   | WorkDoneProgressCancel _ -> "window/workDoneProgress/cancel"
+  | WorkDoneProgress _ -> Progress.method_
   | UnknownNotification n -> n.method_
 
 let yojson_of_t = function
@@ -65,6 +67,8 @@ let yojson_of_t = function
   | WorkDoneProgressCancel params ->
     Some (WorkDoneProgressCancelParams.yojson_of_t params)
   | SetTrace params -> Some (SetTraceParams.yojson_of_t params)
+  | WorkDoneProgress params ->
+    Some ((ProgressParams.yojson_of_t Progress.yojson_of_t) params)
   | UnknownNotification n -> (n.params :> Json.t option)
 
 let of_jsonrpc (r : Jsonrpc.Notification.t) =
@@ -133,6 +137,13 @@ let of_jsonrpc (r : Jsonrpc.Notification.t) =
   | "$/setTrace" ->
     let+ params = Json.message_params params SetTraceParams.t_of_yojson in
     SetTrace params
+  | m when m = Progress.method_ ->
+    let+ params =
+      Json.message_params
+        params
+        (ProgressParams.t_of_yojson Progress.t_of_yojson)
+    in
+    WorkDoneProgress params
   | _ -> Ok (UnknownNotification r)
 
 let to_jsonrpc t =

lsp/src/client_notification.mli

@@ -18,6 +18,7 @@ type t =
   | CancelRequest of Jsonrpc.Id.t
   | WorkDoneProgressCancel of WorkDoneProgressCancelParams.t
   | SetTrace of SetTraceParams.t
+  | WorkDoneProgress of Progress.t ProgressParams.t
   | UnknownNotification of Jsonrpc.Notification.t
 
 val of_jsonrpc : Jsonrpc.Notification.t -> (t, string) result

lsp/src/lsp.ml

@@ -1,3 +1,4 @@
+module Progress = Progress
 module Client_notification = Client_notification
 module Client_request = Client_request
 module Extension = Extension

lsp/src/progress.ml

@@ -0,0 +1,23 @@
+open Import
+open Types
+
+type t =
+  | Begin of WorkDoneProgressBegin.t
+  | Report of WorkDoneProgressReport.t
+  | End of WorkDoneProgressEnd.t
+
+let yojson_of_t = function
+  | Begin b -> WorkDoneProgressBegin.yojson_of_t b
+  | Report r -> WorkDoneProgressReport.yojson_of_t r
+  | End e -> WorkDoneProgressEnd.yojson_of_t e
+
+let t_of_yojson json =
+  Json.Of.untagged_union
+    "Progress"
+    [ (fun j -> Begin (WorkDoneProgressBegin.t_of_yojson j))
+    ; (fun j -> Report (WorkDoneProgressReport.t_of_yojson j))
+    ; (fun j -> End (WorkDoneProgressEnd.t_of_yojson j))
+    ]
+    json
+
+let method_ = "$/progress"

lsp/src/progress.mli

@@ -0,0 +1,13 @@
+open Import
+open Types
+
+type t =
+  | Begin of WorkDoneProgressBegin.t
+  | Report of WorkDoneProgressReport.t
+  | End of WorkDoneProgressEnd.t
+
+val yojson_of_t : t -> Json.t
+
+val t_of_yojson : Json.t -> t
+
+val method_ : string

lsp/src/server_notification.ml

@@ -1,27 +1,6 @@
 open! Import
 open Types
 
-module Progress = struct
-  type t =
-    | Begin of WorkDoneProgressBegin.t
-    | Report of WorkDoneProgressReport.t
-    | End of WorkDoneProgressEnd.t
-
-  let yojson_of_t = function
-    | Begin b -> WorkDoneProgressBegin.yojson_of_t b
-    | Report r -> WorkDoneProgressReport.yojson_of_t r
-    | End e -> WorkDoneProgressEnd.yojson_of_t e
-
-  let t_of_yojson json =
-    Json.Of.untagged_union
-      "Progress"
-      [ (fun j -> Begin (WorkDoneProgressBegin.t_of_yojson j))
-      ; (fun j -> Report (WorkDoneProgressReport.t_of_yojson j))
-      ; (fun j -> End (WorkDoneProgressEnd.t_of_yojson j))
-      ]
-      json
-end
-
 type t =
   | PublishDiagnostics of PublishDiagnosticsParams.t
   | ShowMessage of ShowMessageParams.t
@@ -39,7 +18,7 @@ let method_ = function
   | LogTrace _ -> "$/logTrace"
   | TelemetryNotification _ -> "telemetry/event"
   | CancelRequest _ -> Cancel_request.meth_
-  | WorkDoneProgress _ -> "$/progress"
+  | WorkDoneProgress _ -> Progress.method_
   | UnknownNotification n -> n.method_
 
 let yojson_of_t = function
@@ -81,7 +60,7 @@ let of_jsonrpc (r : Jsonrpc.Notification.t) =
   | "telemetry/event" ->
     let+ params = Json.message_params params (fun x -> x) in
     TelemetryNotification params
-  | "$/progress" ->
+  | m when m = Progress.method_ ->
     let+ params =
       Json.message_params
         params

lsp/src/server_notification.mli

@@ -1,13 +1,6 @@
 open Import
 open Types
 
-module Progress : sig
-  type t =
-    | Begin of WorkDoneProgressBegin.t
-    | Report of WorkDoneProgressReport.t
-    | End of WorkDoneProgressEnd.t
-end
-
 type t =
   | PublishDiagnostics of PublishDiagnosticsParams.t
   | ShowMessage of ShowMessageParams.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -730,6 +730,7 @@ let on_notification server (notification : Client_notification.t) :
   | WillSaveTextDocument _
   | Initialized
   | WorkDoneProgressCancel _
+  | WorkDoneProgress _
   | Exit -> Fiber.return state
   | SetTrace { value } -> Fiber.return { state with trace = value }
   | UnknownNotification req ->

ocaml-lsp-server/src/progress.ml

@@ -1,12 +1,12 @@
 open Import
 open Fiber.O
+module Progress = Lsp.Progress
 
 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
+  ; report_progress : Progress.t ProgressParams.t -> unit Fiber.t
   ; create_task : WorkDoneProgressCreateParams.t -> unit Fiber.t
   }
 
@@ -30,9 +30,7 @@ let end_build (t : enabled) ~message =
         t.report_progress
           (ProgressParams.create
              ~token
-             ~value:
-               (Server_notification.Progress.End
-                  (WorkDoneProgressEnd.create ~message ()))))
+             ~value:(Progress.End (WorkDoneProgressEnd.create ~message ()))))
 
 let end_build_if_running = function
   | Disabled -> Fiber.return ()
@@ -50,7 +48,7 @@ let start_build (t : enabled) =
       (ProgressParams.create
          ~token
          ~value:
-           (Server_notification.Progress.Begin
+           (Progress.Begin
               (WorkDoneProgressBegin.create
                  ~title:"Build"
                  ~message:"started"
@@ -88,7 +86,7 @@ let build_progress t (progress : Drpc.Progress.t) =
             (ProgressParams.create
                ~token
                ~value:
-                 (Server_notification.Progress.Report
+                 (Progress.Report
                     (let message = sprintf "Building [%d/%d]" complete total in
                      WorkDoneProgressReport.create ~percentage ~message ())))))
 

ocaml-lsp-server/src/progress.mli

@@ -4,8 +4,7 @@ type t
 
 val create :
      ClientCapabilities.t
-  -> report_progress:
-       (Server_notification.Progress.t ProgressParams.t -> unit Fiber.t)
+  -> report_progress:(Lsp.Progress.t ProgressParams.t -> unit Fiber.t)
   -> create_task:(WorkDoneProgressCreateParams.t -> unit Fiber.t)
   -> t