move to lsp 1.14

linol.opam

@@ -14,7 +14,7 @@ depends: [
   "dune" { >= "2.0" }
   "yojson" { >= "1.6" }
   "logs"
-  "lsp" { >= "1.11" & < "1.12" }
+  "lsp" { >= "1.14" & < "1.15" }
   "ocaml" { >= "4.12" }
   "odoc" { with-doc }
 ]

src/jsonrpc2.ml

@@ -1,4 +1,3 @@
-
 (** {1 Simple JSON-RPC2 implementation}
     See {{: https://www.jsonrpc.org/specification} the spec} *)
 
@@ -15,29 +14,21 @@ module type S = sig
   type t
   (** A jsonrpc2 connection. *)
 
-  include module type of Server.Make(IO)
+  include module type of Server.Make (IO)
 
-  val create :
+  val create : ic:IO.in_channel -> oc:IO.out_channel -> server -> t
-    ic:IO.in_channel ->
-    oc:IO.out_channel ->
-    server ->
-    t
   (** Create a connection from the pair of channels *)
 
   val create_stdio : server -> t
   (** Create a connection using stdin/stdout *)
 
-  val run :
+  val run : ?shutdown:(unit -> bool) -> t -> unit IO.t
-    ?shutdown:(unit -> bool) ->
-    t -> unit IO.t
   (** Listen for incoming messages and responses *)
 end
 
-module Make(IO : IO)
+module Make (IO : IO) : S with module IO = IO = struct
-    : S with module IO = IO
-= struct
   module IO = IO
-  include Server.Make(IO)
+  include Server.Make (IO)
   open IO
 
   type json = J.t
@@ -71,63 +62,63 @@ module Make(IO : IO)
     s: server;
   }
 
-  let create ~ic ~oc server : t = {ic; oc; s=server}
+  let create ~ic ~oc server : t = { ic; oc; s = server }
-
+  let create_stdio server : t = create ~ic:IO.stdin ~oc:IO.stdout server
-  let create_stdio server : t =
-    create ~ic:IO.stdin ~oc:IO.stdout server
 
   (* send a single message *)
-  let send_json_ (self:t) (j:json) : unit IO.t =
+  let send_json_ (self : t) (j : json) : unit IO.t =
     let json = J.to_string j in
-    Log.debug (fun k->k "jsonrpc2: send json: %s" json);
+    Log.debug (fun k -> k "jsonrpc2: send json: %s" json);
     let full_s =
-      Printf.sprintf "Content-Length: %d\r\n\r\n%s"
+      Printf.sprintf "Content-Length: %d\r\n\r\n%s" (String.length json) json
-        (String.length json) json
     in
     IO.write_string self.oc full_s
 
-  let send_response (self:t) (m:Jsonrpc.Response.t) : unit IO.t =
+  let send_response (self : t) (m : Jsonrpc.Response.t) : unit IO.t =
     let json = Jsonrpc.Response.yojson_of_t m in
     send_json_ self json
 
-  let send_server_notif (self:t) (m:Jsonrpc.Message.notification) : unit IO.t =
+  let send_server_notif (self : t) (m : Jsonrpc.Notification.t) : unit IO.t =
-    let json = Jsonrpc.Message.yojson_of_notification m in
+    let json = Jsonrpc.Notification.yojson_of_t m in
     send_json_ self json
 
   let try_ f =
     IO.catch
-      (fun () -> let+ x = f() in Ok x)
+      (fun () ->
+        let+ x = f () in
+        Ok x)
       (fun e -> IO.return (Error e))
 
   (* read a full message *)
-  let read_msg (self:t) : (Jsonrpc.Message.either, exn) result IO.t =
+  let read_msg (self : t) : (Jsonrpc.Packet.t, exn) result IO.t =
     let rec read_headers acc =
-      let*? line =
+      let*? line = try_ @@ fun () -> IO.read_line self.ic in
-        try_ @@ fun () -> IO.read_line self.ic
-      in
       match String.trim line with
       | "" -> IO.return (Ok acc) (* last separator *)
       | line ->
-        begin match
+        (match
-            let i = String.index line ':' in
+           let i = String.index line ':' in
-            if i<0 || String.get line (i+1) <> ' ' then raise Not_found;
+           if i < 0 || String.get line (i + 1) <> ' ' then raise Not_found;
-            let key = String.lowercase_ascii @@ String.sub line 0 i in
+           let key = String.lowercase_ascii @@ String.sub line 0 i in
-            let v =
+           let v =
-              String.lowercase_ascii @@
+             String.lowercase_ascii
-              String.trim (String.sub line (i+1) (String.length line-i-1))
+             @@ String.trim
-            in
+                  (String.sub line (i + 1) (String.length line - i - 1))
-            key, v
+           in
-          with
+           key, v
-          | pair -> read_headers (pair :: acc)
+         with
-          | exception _ ->
+        | pair -> read_headers (pair :: acc)
-            IO.return (Error (E(ErrorCode.ParseError, spf "invalid header: %S" line)))
+        | exception _ ->
-        end
+          IO.return
+            (Error (E (ErrorCode.ParseError, spf "invalid header: %S" line))))
     in
     let*? headers = read_headers [] in
-    Log.debug (fun k->k "jsonrpc2: read headers: [%s]"
+    Log.debug (fun k ->
-                  (String.concat ";" @@
+        k "jsonrpc2: read headers: [%s]"
-                   List.map (fun (a,b)->Printf.sprintf "(%S,%S)" a b) headers));
+          (String.concat ";"
-    let ok = match List.assoc "content-type" headers with
+          @@ List.map (fun (a, b) -> Printf.sprintf "(%S,%S)" a b) headers));
+    let ok =
+      match List.assoc "content-type" headers with
       | "utf8" | "utf-8" -> true
       | _ -> false
       | exception Not_found -> true
@@ -135,111 +126,107 @@ module Make(IO : IO)
     if ok then (
       match int_of_string (List.assoc "content-length" headers) with
       | n ->
-        Log.debug (fun k->k "jsonrpc2: read %d bytes..." n);
+        Log.debug (fun k -> k "jsonrpc2: read %d bytes..." n);
         let buf = Bytes.make n '\000' in
-        let*? () =
+        let*? () = try_ @@ fun () -> IO.read self.ic buf 0 n in
-          try_ @@ fun () -> IO.read self.ic buf 0 n
-        in
         (* log_lsp_ "got bytes %S" (Bytes.unsafe_to_string buf); *)
         let*? j =
           try_ @@ fun () ->
           IO.return @@ J.from_string (Bytes.unsafe_to_string buf)
         in
-        Log.debug (fun k->k "got json %s" (J.to_string j));
+        Log.debug (fun k -> k "got json %s" (J.to_string j));
-        begin match Jsonrpc.Message.either_of_yojson j with
+        (match Jsonrpc.Packet.t_of_yojson j with
-          | m -> IO.return @@ Ok m
+        | m -> IO.return @@ Ok m
-          | exception _ ->
+        | exception _ ->
-            Log.err (fun k->k "cannot decode json message");
+          Log.err (fun k -> k "cannot decode json message");
-            IO.return (Error (E(ErrorCode.ParseError, "cannot decode json")))
+          IO.return (Error (E (ErrorCode.ParseError, "cannot decode json"))))
-        end
       | exception _ ->
-        IO.return @@
+        IO.return
-        Error (E(ErrorCode.ParseError, "missing content-length' header"))
+        @@ Error (E (ErrorCode.ParseError, "missing content-length' header"))
-    ) else (
+    ) else
-      IO.return @@
+      IO.return
-      Error (E(ErrorCode.InvalidRequest, "content-type must be 'utf-8'"))
+      @@ Error (E (ErrorCode.InvalidRequest, "content-type must be 'utf-8'"))
-    )
 
-  let run ?(shutdown=fun _ -> false) (self:t) : unit IO.t =
+  let run ?(shutdown = fun _ -> false) (self : t) : unit IO.t =
     let process_msg r =
-      let module M = Jsonrpc.Message in
+      let module M = Jsonrpc.Packet in
       let protect ~id f =
-        IO.catch f
+        IO.catch f (fun e ->
-          (fun e ->
+            let message =
-             let message = spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace()) in
+              spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
-             Log.err (fun k->k "error: %s" message);
+            in
-             let r = Jsonrpc.Response.error id
+            Log.err (fun k -> k "error: %s" message);
-               (Jsonrpc.Response.Error.make
+            let r =
-                 ~code:Jsonrpc.Response.Error.Code.InternalError
+              Jsonrpc.Response.error id
-                 ~message ())
+                (Jsonrpc.Response.Error.make
+                   ~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
             in
             send_response self r)
       in
-      match r.M.id with
+      match r with
-      | None ->
+      | M.Notification n ->
         (* notification *)
-        begin match Lsp.Client_notification.of_jsonrpc {r with M.id=()} with
+        (match Lsp.Client_notification.of_jsonrpc n with
-          | Ok n ->
+        | Ok n ->
-            IO.catch
+          IO.catch
-              (fun () ->
+            (fun () ->
-                (self.s)#on_notification n
+              self.s#on_notification n ~notify_back:(fun n ->
-                  ~notify_back:(fun n ->
+                  let msg = Lsp.Server_notification.to_jsonrpc n in
-                      let msg = Lsp.Server_notification.to_jsonrpc n in
+                  send_server_notif self msg))
-                      send_server_notif self msg))
+            (fun e ->
-              (fun e ->
+              let msg =
-                 let msg =
+                Lsp.Types.LogMessageParams.create
-                   Lsp.Types.LogMessageParams.create ~type_:Lsp.Types.MessageType.Error
+                  ~type_:Lsp.Types.MessageType.Error
-                     ~message:(Printexc.to_string e)
+                  ~message:(Printexc.to_string e)
-                 in
+              in
-                 let msg =
+              let msg =
-                   Lsp.Server_notification.LogMessage msg
+                Lsp.Server_notification.LogMessage msg
-                   |> Lsp.Server_notification.to_jsonrpc
+                |> Lsp.Server_notification.to_jsonrpc
-                 in
+              in
-                 send_server_notif self msg)
+              send_server_notif self msg)
-          | Error e ->
+        | Error e -> IO.failwith (spf "cannot decode notification: %s" e))
-            IO.failwith (spf "cannot decode notification: %s" e)
+      | M.Request r ->
-        end
-      | Some id ->
         (* request, so we need to reply *)
+        let id = r.id in
         IO.catch
           (fun () ->
-            begin match Lsp.Client_request.of_jsonrpc {r with M.id} with
+            match Lsp.Client_request.of_jsonrpc r with
-              | Ok (Lsp.Client_request.E r) ->
+            | Ok (Lsp.Client_request.E r) ->
-                protect ~id (fun () ->
+              protect ~id (fun () ->
-                  let* reply = self.s#on_request r ~id
+                  let* reply =
-                    ~notify_back:(fun n ->
+                    self.s#on_request r ~id ~notify_back:(fun n ->
                         let msg = Lsp.Server_notification.to_jsonrpc n in
                         send_server_notif self msg)
                   in
-                  let reply_json = Lsp.Client_request.yojson_of_result r reply in
+                  let reply_json =
+                    Lsp.Client_request.yojson_of_result r reply
+                  in
                   let response = Jsonrpc.Response.ok id reply_json in
-                  send_response self response
+                  send_response self response)
-                )
+            | Error e -> IO.failwith (spf "cannot decode request: %s" e))
-              | Error e ->
-                IO.failwith (spf "cannot decode request: %s" e)
-            end)
           (fun e ->
-            let message = spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace()) in
+            let message =
-            Log.err (fun k->k "error: %s" message);
+              spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
+            in
+            Log.err (fun k -> k "error: %s" message);
             let r =
               Jsonrpc.Response.error id
-              (Jsonrpc.Response.Error.make
+                (Jsonrpc.Response.Error.make
-                ~code:Jsonrpc.Response.Error.Code.InternalError
+                   ~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
-                ~message ())
             in
             send_response self r)
+      | _p -> IO.failwith "neither notification nor request"
     in
     let rec loop () =
-      if shutdown() then IO.return ()
+      if shutdown () then
-      else (
+        IO.return ()
+      else
         let* r = read_msg self in
         match r with
         | Ok r ->
           IO.spawn (fun () -> process_msg r);
-          loop()
+          loop ()
         | Error e -> IO.fail e
-      )
     in
-    loop()
+    loop ()
 end
-

src/server.ml

@@ -330,6 +330,14 @@ module Make(IO : IO) = struct
         | Lsp.Client_request.SemanticTokensDelta _
         | Lsp.Client_request.SemanticTokensFull _
         | Lsp.Client_request.SemanticTokensRange _
+        | Lsp.Client_request.TextDocumentImplementation _
+        | Lsp.Client_request.TextDocumentPrepareCallHierarchy _
+        | Lsp.Client_request.TextDocumentRangeFormatting _
+        | Lsp.Client_request.CallHierarchyIncomingCalls _
+        | Lsp.Client_request.CallHierarchyOutgoingCalls _
+        | Lsp.Client_request.WillCreateFiles _
+        | Lsp.Client_request.WillDeleteFiles _
+        | Lsp.Client_request.WillRenameFiles _
         | Lsp.Client_request.UnknownRequest _ ->
           let notify_back = new notify_back ~notify_back () in
           self#on_request_unhandled ~notify_back ~id r
@@ -435,6 +443,11 @@ module Make(IO : IO) = struct
         | Lsp.Client_notification.CancelRequest _
         | Lsp.Client_notification.WorkDoneProgressCancel _
         | Lsp.Client_notification.SetTrace _
+        | Lsp.Client_notification.DidChangeWatchedFiles _
+        | Lsp.Client_notification.DidCreateFiles _
+        | Lsp.Client_notification.DidDeleteFiles _
+        | Lsp.Client_notification.DidRenameFiles _
+        | Lsp.Client_notification.LogTrace _
           ->
           let notify_back = new notify_back ~notify_back () in
           self#on_notification_unhandled ~notify_back n