big refactor: jsonrpc2 is now part of linol; provide blocking IO

example/template/main.ml

@@ -58,7 +58,7 @@ class lsp_server =
 
     (* We now override the [on_notify_doc_did_open] method that will be called
        by the server each time a new document is opened. *)
-    method on_notif_doc_did_open ~notify_back d ~content : unit Linol_lwt.Task.m =
+    method on_notif_doc_did_open ~notify_back d ~content : unit Linol_lwt.t =
       self#_on_doc ~notify_back d.uri content
 
     (* Similarly, we also override the [on_notify_doc_did_change] method that will be called
@@ -68,9 +68,9 @@ class lsp_server =
 
     (* On document closes, we remove the state associated to the file from the global
        hashtable state, to avoid leaking memory. *)
-    method on_notif_doc_did_close ~notify_back:_ d : unit Linol_lwt.Task.m =
+    method on_notif_doc_did_close ~notify_back:_ d : unit Linol_lwt.t =
       Hashtbl.remove buffers d.uri;
-      Linol_lwt.Jsonrpc2.IO.return ()
+      Linol_lwt.return ()
 
   end
 
@@ -78,24 +78,12 @@ class lsp_server =
    This is the code that creates an instance of the lsp server class
    and runs it as a task. *)
 let run () =
-  let open Linol_lwt.Task.Infix in
   let s = new lsp_server in
-  (* TODO: the task is the LSP server *)
+  let server = Linol_lwt.Jsonrpc2.create_stdio s in
-  let task =
+  let task = Linol_lwt.Jsonrpc2.run server in
-    Linol_lwt.Task.start ~descr:"top task"
+  match Linol_lwt.run task with
-      (fun _top_task ->
+  | () -> ()
-         let server = Linol_lwt.Jsonrpc2.create_stdio s in
+  | exception e ->
-         let* () =
-           Linol_lwt.Task.run_sub ~descr:"lsp server" ~parent:_top_task
-             (fun _ -> Linol_lwt.Jsonrpc2.run server _top_task)
-           >>= Linol_lwt.Task.unwrap
-         in
-         Linol_lwt.Task.return ()
-      )
-  in
-  match Linol_lwt.Task.run task with
-  | Ok () -> ()
-  | Error e ->
     let e = Printexc.to_string e in
     Printf.eprintf "error: %s\n%!" e;
     exit 1

linol.opam

@@ -12,6 +12,7 @@ build: [
 depends: [
   "dune" { >= "2.0" }
   "containers" { >= "3.0" & < "4.0" }
+  "yojson" { >= "1.6" }
   "lsp" { >= "1.4" & < "1.5" }
   "ocaml" { >= "4.08" }
   "odoc" { with-doc }

src/blocking_IO.ml

@@ -0,0 +1,39 @@
+
+type 'a t = 'a
+type nonrec in_channel = in_channel
+type nonrec out_channel = out_channel
+
+let (let+) x f = f x
+let ( let* ) x f = f x
+let (and+) a b = a,b
+let return x = x
+
+let failwith = failwith
+let fail = raise
+
+let stdin = stdin
+let stdout = stdout
+
+let spawn f =
+  let run () =
+    try f()
+    with e ->
+      Printf.eprintf "linol: uncaught exception in `spawn`:\n%s\n%!"
+        (Printexc.to_string e);
+      raise e
+in
+  ignore (Thread.create run () : Thread.t)
+
+let catch f g =
+  try f()
+  with e -> g e
+
+let rec read ic buf i len =
+  if len>0 then (
+    let n = input ic buf i len in
+    read ic buf (i+n) (len-n)
+  )
+
+let read_line = input_line
+let write oc b i len = output oc b i len; flush oc
+let write_string oc s = output_string oc s; flush oc

src/blocking_IO.mli

@@ -0,0 +1,6 @@
+
+(** {1 Blocking IO with a new thread for each [spawn]} *)
+
+include Sigs.IO with type 'a t = 'a
+     and type in_channel = in_channel
+     and type out_channel = out_channel

src/dune

@@ -3,4 +3,4 @@
   (name linol)
   (public_name linol)
   (flags :standard -warn-error -a+8)
-  (libraries containers lsp))
+  (libraries containers yojson lsp))

src/jsonrpc2.ml

@@ -0,0 +1,240 @@
+
+(** {1 Simple JSON-RPC2 implementation}
+    See {{: https://www.jsonrpc.org/specification} the spec} *)
+
+module Fmt = CCFormat
+module J = Yojson.Safe
+module Err = Jsonrpc.Response.Error
+
+type json = Yojson.Safe.t
+
+module type IO = Sigs.IO
+
+module type S = sig
+  module IO : IO
+
+  type t
+  (** A jsonrpc2 connection. *)
+
+  include module type of Server.Make(IO)
+
+  val create :
+    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 :
+    ?shutdown:(unit -> bool) ->
+    t -> unit IO.t
+  (** Listen for incoming messages and responses *)
+end
+
+module Make(IO : IO)
+    : S with module IO = IO
+= struct
+  module IO = IO
+  include Server.Make(IO)
+  open IO
+
+  type json = J.t
+
+  let spf = Printf.sprintf
+
+  module ErrorCode = Lsp.Types.ErrorCodes
+  (*
+  module Err = struct
+    type code = int
+    let code_parse_error : code = (-32700)
+    let code_invalid_request : code = (-32600)
+    let code_method_not_found : code = (-32601)
+    let code_invalid_param : code = (-32602)
+    let code_internal_error : code = (-32603)
+  end
+                 *)
+
+  exception E of ErrorCode.t * string
+
+  (* bind on IO+result *)
+  let ( let*? ) x f =
+    let* x = x in
+    match x with
+    | Ok x -> f x
+    | Error _ as err -> IO.return err
+
+  type t = {
+    ic: IO.in_channel;
+    oc: IO.out_channel;
+    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
+
+  (* send a single message *)
+  let send_json_ (self:t) (j:json) : unit IO.t =
+    let json = J.to_string j in
+    let full_s =
+      Printf.sprintf "Content-Length: %d\r\n\r\n%s"
+        (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 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 json = Jsonrpc.Message.yojson_of_notification m in
+    send_json_ self json
+
+  let try_ f =
+    IO.catch
+      (fun () -> let+ x = f() in Ok x)
+      (fun e -> IO.return (Error e))
+
+  let log_lsp_ msg =
+    Fmt.kasprintf
+      (fun s ->
+        Lsp.Logger.log ~title:Lsp.Logger.Title.Debug ~section:"jsonrpc2"
+        "%s" s)
+      msg
+
+  (* read a full message *)
+  let read_msg (self:t) : (Jsonrpc.Message.either, exn) result IO.t =
+    let rec read_headers acc =
+      let*? line =
+        try_ @@ fun () -> IO.read_line self.ic
+      in
+      match String.trim line with
+      | "" -> IO.return (Ok acc) (* last separator *)
+      | line ->
+        begin match
+            let i = String.index line ':' in
+            if i<0 || String.get line (i+1) <> ' ' then raise Not_found;
+            let key = String.lowercase_ascii @@ String.sub line 0 i in
+            let v =
+              String.lowercase_ascii @@
+              String.trim (String.sub line (i+1) (String.length line-i-1))
+            in
+            key, v
+          with
+          | pair -> read_headers (pair :: acc)
+          | exception _ ->
+            IO.return (Error (E(ErrorCode.ParseError, spf "invalid header: %S" line)))
+        end
+    in
+    let*? headers = read_headers [] in
+    log_lsp_ "headers: %a" Fmt.Dump.(list @@ pair string string) headers;
+    let ok = match List.assoc "content-type" headers with
+      | "utf8" | "utf-8" -> true
+      | _ -> false
+      | exception Not_found -> true
+    in
+    if ok then (
+      match int_of_string (List.assoc "content-length" headers) with
+      | n ->
+        log_lsp_ "read %d bytes..." n;
+        let buf = Bytes.make n '\000' in
+        let*? () =
+          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
+        begin match Jsonrpc.Message.either_of_yojson j with
+          | m -> IO.return @@ Ok m
+          | exception _ ->
+            IO.return (Error (E(ErrorCode.ParseError, "cannot decode json")))
+        end
+      | exception _ ->
+        IO.return @@
+        Error (E(ErrorCode.ParseError, "missing content-length' header"))
+    ) else (
+      IO.return @@
+      Error (E(ErrorCode.InvalidRequest, "content-type must be 'utf-8'"))
+    )
+
+  let run ?(shutdown=fun _ -> false) (self:t) : unit IO.t =
+    let process_msg r =
+      let module M = Jsonrpc.Message in
+      let protect ~id f =
+        IO.catch f
+          (fun e ->
+             let r = Jsonrpc.Response.error id
+               (Jsonrpc.Response.Error.make
+                 ~code:Jsonrpc.Response.Error.Code.InternalError
+                 ~message:(Printexc.to_string e) ())
+            in
+            send_response self r)
+      in
+      match r.M.id with
+      | None ->
+        (* notification *)
+        begin match Lsp.Client_notification.of_jsonrpc {r with M.id=()} with
+          | Ok n ->
+            IO.catch
+              (fun () ->
+                (self.s)#on_notification n
+                  ~notify_back:(fun n ->
+                      let msg = Lsp.Server_notification.to_jsonrpc n in
+                      send_server_notif self msg))
+              (fun e ->
+                 let msg =
+                   Lsp.Types.ShowMessageParams.create ~type_:Lsp.Types.MessageType.Error
+                     ~message:(Printexc.to_string e)
+                 in
+                 let msg =
+                   Lsp.Server_notification.LogMessage msg
+                   |> Lsp.Server_notification.to_jsonrpc
+                 in
+                 send_server_notif self msg)
+          | Error e ->
+            IO.failwith (spf "cannot decode notification: %s" e)
+        end
+      | Some id ->
+        (* request, so we need to reply *)
+        IO.catch
+          (fun () ->
+            begin match Lsp.Client_request.of_jsonrpc {r with M.id} with
+              | Ok (Lsp.Client_request.E r) ->
+                protect ~id (fun () ->
+                  let* reply = self.s#on_request r 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
+                )
+              | Error e ->
+                IO.failwith (spf "cannot decode request: %s" e)
+            end)
+          (fun e ->
+            let r =
+              Jsonrpc.Response.error id
+              (Jsonrpc.Response.Error.make
+                ~code:Jsonrpc.Response.Error.Code.InternalError
+                ~message:(Printexc.to_string e) ())
+            in
+            send_response self r)
+    in
+    let rec loop () =
+      if shutdown() then IO.return ()
+      else (
+        let* r = read_msg self in
+        match r with
+        | Ok r ->
+          IO.spawn (fun () -> process_msg r);
+          loop()
+        | Error e -> IO.fail e
+      )
+    in
+    loop()
+end
+

src/jsonrpc2.mli

@@ -0,0 +1,32 @@
+
+
+type json = Yojson.Safe.t
+
+module type IO = Sigs.IO
+
+module type S = sig
+  module IO : IO
+
+  type t
+  (** A jsonrpc2 connection. *)
+
+  include module type of Server.Make(IO)
+
+  val create :
+    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 :
+    ?shutdown:(unit -> bool) ->
+    t -> unit IO.t
+    (** Listen for incoming messages and responses.
+    @param shutdown if true, tells the server to shut down *)
+end
+
+module Make(IO : IO) : S with module IO = IO

src/linol.ml

@@ -4,237 +4,9 @@
     Abstraction over The "Lsp" library, to make it easier to develop
     LSP servers in OCaml (but not necessarily {b for} OCaml). *)
 
-(** {2 Parametrized IO Interface} *)
+module type IO = Sigs.IO
-module type IO = sig
+module Jsonrpc2 = Jsonrpc2
-  type 'a t
+module Server = Server
-  val return : 'a -> 'a t
+module Blocking_IO = Blocking_IO
-  val failwith : string -> 'a t
-  val (let+) : 'a t -> ('a -> 'b) -> 'b t
-  val (let*) : 'a t -> ('a -> 'b t) -> 'b t
-  val (and+) : 'a t -> 'b t -> ('a * 'b) t
-  type in_channel
-  type out_channel
-end
 
-(** {2 Server interface for some IO substrate} *)
+module Make = Jsonrpc2.Make
-module Make(IO : IO) = struct
-  open Lsp.Types
-
-  module Position = Position
-  module Range = Range
-
-  (** The server baseclass *)
-  class virtual base_server = object
-    method virtual on_notification :
-      notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
-      Lsp.Client_notification.t ->
-      unit IO.t
-
-    method virtual on_request : 'a.
-      'a Lsp.Client_request.t ->
-      'a IO.t
-
-    (** Set to true if the client requested to exit *)
-    method must_quit = false
-  end
-
-  (** A wrapper to more easily reply to notifications *)
-  class notify_back ~notify_back ?version ~(uri:DocumentUri.t) () = object
-    (** Send a log message to the editor *)
-    method send_log_msg ~type_ msg : unit IO.t =
-      let params = ShowMessageParams.create ~type_ ~message:msg in
-      notify_back (Lsp.Server_notification.LogMessage params)
-
-    (** Send diagnostics for the current document *)
-    method send_diagnostic (l:Diagnostic.t list) : unit IO.t =
-      let params = PublishDiagnosticsParams.create
-          ~uri ?version ~diagnostics:l () in
-      notify_back (Lsp.Server_notification.PublishDiagnostics params)
-
-    (** Send a notification (general purpose method) *)
-    method send_notification (n:Lsp.Server_notification.t) =
-      notify_back n
-  end
-
-  (** Current state of a document. *)
-  type doc_state = {
-    uri: DocumentUri.t;
-    languageId: string;
-    version: int;
-    content: string;
-  }
-
-  (** An easily overloadable class. Pick the methods you want to support.
-      The user must provide at least the callbacks for document lifecycle:
-      open, close, update. The most basic LSP server should check documents
-      when they're updated and report diagnostics back to the editor. *)
-  class virtual server = object(self)
-    inherit base_server
-    val mutable _quit = false
-    val docs : (DocumentUri.t, doc_state) Hashtbl.t = Hashtbl.create 16
-
-    method! must_quit = _quit
-
-    (** Find current state of the given document, if present. *)
-    method find_doc (uri:DocumentUri.t) : doc_state option =
-      try Some (Hashtbl.find docs uri)
-      with Not_found -> None
-
-    (** Override to process other requests *)
-    method on_request_unhandled
-      : type r. r Lsp.Client_request.t -> r IO.t
-      = fun _r ->
-        IO.failwith "TODO: handle this request"
-
-    (** Parameter for how to synchronize content with the editor *)
-    method config_sync_opts : TextDocumentSyncOptions.t =
-      TextDocumentSyncOptions.create
-          ~change:TextDocumentSyncKind.Incremental ~willSave:false ()
-
-    method on_req_initialize (_i:InitializeParams.t) : InitializeResult.t IO.t =
-      let sync_opts = self#config_sync_opts in
-      let capabilities =
-        ServerCapabilities.create
-          ~textDocumentSync:(`TextDocumentSyncOptions sync_opts) () in
-      IO.return @@ InitializeResult.create ~capabilities ()
-
-    (** Called when the user hovers on some identifier in the document *)
-    method on_req_hover ~uri:_ ~pos:_ (_ : doc_state) : Hover.t option IO.t =
-      IO.return None
-
-    (** Called when the user requests completion in the document *)
-    method on_req_completion ~uri:_ ~pos:_ ~ctx:_
-        (_ : doc_state) :
-          [ `CompletionList of CompletionList.t
-          | `List of CompletionItem.t list ] option IO.t =
-      IO.return None
-
-    (** Called when the user wants to jump-to-definition  *)
-    method on_req_definition ~uri:_ ~pos:_ (_ : doc_state) : Locations.t option IO.t =
-      IO.return None
-
-    method on_request
-    : type r. r Lsp.Client_request.t -> r IO.t
-    = fun (r:_ Lsp.Client_request.t) ->
-      begin match r with
-        | Lsp.Client_request.Shutdown -> _quit <- true; IO.return ()
-        | Lsp.Client_request.Initialize i -> self#on_req_initialize i
-        | Lsp.Client_request.TextDocumentHover { textDocument; position } ->
-          let doc_st = Hashtbl.find docs textDocument.uri in
-          self#on_req_hover ~uri:textDocument.uri ~pos:position doc_st
-        | Lsp.Client_request.TextDocumentCompletion { textDocument; position; context } ->
-          let doc_st = Hashtbl.find docs textDocument.uri in
-          self#on_req_completion ~uri:textDocument.uri ~pos:position ~ctx:context doc_st
-        | Lsp.Client_request.TextDocumentDefinition { textDocument; position } ->
-          let doc_st = Hashtbl.find docs textDocument.uri in
-          self#on_req_definition ~uri:textDocument.uri ~pos:position doc_st
-        | Lsp.Client_request.TextDocumentDeclaration _
-        | Lsp.Client_request.TextDocumentTypeDefinition _
-        | Lsp.Client_request.TextDocumentCodeLens _
-        | Lsp.Client_request.TextDocumentCodeLensResolve _
-        | Lsp.Client_request.TextDocumentPrepareRename _
-        | Lsp.Client_request.TextDocumentRename _
-        | Lsp.Client_request.TextDocumentLink _
-        | Lsp.Client_request.TextDocumentLinkResolve _
-        | Lsp.Client_request.DocumentSymbol _
-        | Lsp.Client_request.WorkspaceSymbol _
-        | Lsp.Client_request.DebugEcho _
-        | Lsp.Client_request.DebugTextDocumentGet _
-        | Lsp.Client_request.TextDocumentReferences _
-        | Lsp.Client_request.TextDocumentHighlight _
-        | Lsp.Client_request.TextDocumentFoldingRange _
-        | Lsp.Client_request.SignatureHelp _
-        | Lsp.Client_request.CodeAction _
-        | Lsp.Client_request.CompletionItemResolve _
-        | Lsp.Client_request.WillSaveWaitUntilTextDocument _
-        | Lsp.Client_request.TextDocumentFormatting _
-        | Lsp.Client_request.TextDocumentOnTypeFormatting _
-        | Lsp.Client_request.TextDocumentColorPresentation _
-        | Lsp.Client_request.TextDocumentColor _
-        | Lsp.Client_request.SelectionRange _
-        | Lsp.Client_request.ExecuteCommand _
-        | Lsp.Client_request.UnknownRequest _ -> self#on_request_unhandled r
-      end
-
-    (** Called when a document is opened *)
-    method virtual on_notif_doc_did_open :
-      notify_back:notify_back ->
-      TextDocumentItem.t ->
-      content:string ->
-      unit IO.t
-
-    method virtual on_notif_doc_did_close :
-      notify_back:notify_back ->
-      TextDocumentIdentifier.t ->
-      unit IO.t
-
-    (** Called when the document changes. *)
-    method virtual on_notif_doc_did_change :
-      notify_back:notify_back ->
-      VersionedTextDocumentIdentifier.t ->
-      TextDocumentContentChangeEvent.t list ->
-      old_content:string ->
-      new_content:string ->
-      unit IO.t
-
-    (** Override to handle unprocessed notifications *)
-    method on_notification_unhandled
-        ~notify_back:_ (_n:Lsp.Client_notification.t) : unit IO.t =
-      IO.return ()
-
-    method on_notification
-        ~notify_back (n:Lsp.Client_notification.t) : unit IO.t =
-      let open Lsp.Types in
-      begin match n with
-        | Lsp.Client_notification.TextDocumentDidOpen
-            {DidOpenTextDocumentParams.textDocument=doc} ->
-          let notify_back =
-            new notify_back ~uri:doc.uri ~version:doc.version ~notify_back () in
-          let st = {
-            uri=doc.uri; version=doc.version; content=doc.text;
-            languageId=doc.languageId;
-          } in
-          Hashtbl.replace docs doc.uri st;
-          self#on_notif_doc_did_open ~notify_back doc ~content:st.content
-        | Lsp.Client_notification.TextDocumentDidClose {textDocument=doc} ->
-          let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
-          self#on_notif_doc_did_close ~notify_back doc
-        | Lsp.Client_notification.TextDocumentDidChange {textDocument=doc; contentChanges=c} ->
-          let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
-          begin match Hashtbl.find docs doc.uri with
-            | exception Not_found -> IO.failwith "unknown document"
-            | st ->
-              let old_content = st.content in
-              let new_doc: Lsp.Text_document.t =
-                let doc = Lsp.Text_document.make
-                    (DidOpenTextDocumentParams.create
-                       ~textDocument:(
-                         TextDocumentItem.create ~languageId:st.languageId
-                           ~uri:doc.uri ~version:st.version ~text:st.content))
-                in
-                List.fold_left
-                  (fun d ev -> Lsp.Text_document.apply_content_change d ev)
-                  doc c
-              in
-              let new_st = {
-                st with
-                content=Lsp.Text_document.text new_doc;
-                version=Lsp.Text_document.version new_doc;
-              } in
-              Hashtbl.replace docs doc.uri new_st;
-              self#on_notif_doc_did_change ~notify_back doc c ~old_content
-                ~new_content:new_st.content
-          end
-        | Lsp.Client_notification.Exit -> _quit <- true; IO.return ()
-        | Lsp.Client_notification.DidSaveTextDocument _
-        | Lsp.Client_notification.WillSaveTextDocument _
-        | Lsp.Client_notification.ChangeWorkspaceFolders _
-        | Lsp.Client_notification.ChangeConfiguration _
-        | Lsp.Client_notification.Initialized
-        | Lsp.Client_notification.Unknown_notification _
-        | Lsp.Client_notification.CancelRequest _
-          ->
-          self#on_notification_unhandled ~notify_back n
-      end
-  end
-end

src/lwt/jsonrpc2.ml

@@ -1,218 +0,0 @@
-
-(** {1 Simple JSON-RPC2 implementation}
-    See {{: https://www.jsonrpc.org/specification} the spec} *)
-
-module Fmt = CCFormat
-module J = Yojson.Safe
-module Err = Jsonrpc.Response.Error
-open Task.Infix
-
-module IO = struct
-  type 'a t = 'a Lwt.t
-  let (let+) = Lwt.(>|=)
-  let (let*) = Lwt.(>>=)
-  let (and+) a b =
-    let open Lwt in
-    a >>= fun x -> b >|= fun y -> x,y
-  let return = Lwt.return
-  let failwith = Lwt.fail_with
-  type in_channel = Lwt_io.input Lwt_io.channel
-  type out_channel = Lwt_io.output Lwt_io.channel
-end
-
-include Linol.Make(IO)
-
-type json = J.t
-type 'a m = 'a Task.m
-
-let spf = Printf.sprintf
-
-module ErrorCode = Lsp.Types.ErrorCodes
-(*
-module Err = struct
-  type code = int
-  let code_parse_error : code = (-32700)
-  let code_invalid_request : code = (-32600)
-  let code_method_not_found : code = (-32601)
-  let code_invalid_param : code = (-32602)
-  let code_internal_error : code = (-32603)
-end
-
-               *)
-exception E of ErrorCode.t * string
-
-type t = {
-  ic: Lwt_io.input Lwt_io.channel;
-  oc: Lwt_io.output Lwt_io.channel;
-  s: server;
-}
-
-let create ~ic ~oc server : t = {ic; oc; s=server}
-
-let create_stdio server : t =
-  create ~ic:Lwt_io.stdin ~oc:Lwt_io.stdout server
-
-(* bind on IO+result *)
-let ( let*? ) x f =
-  let open Lwt.Infix in
-  x >>= function
-  | Error _ as err -> Lwt.return err
-  | Ok x -> f x
-
-(* send a single message *)
-let send_json_ (self:t) (j:json) : unit m =
-  let json = J.to_string j in
-  let full_s =
-    Printf.sprintf "Content-Length: %d\r\n\r\n%s"
-      (String.length json) json
-  in
-  Lwt_io.write self.oc full_s
-
-let send_response (self:t) (m:Jsonrpc.Response.t) : unit m =
-  let json = Jsonrpc.Response.yojson_of_t m in
-  send_json_ self json
-
-let send_server_notif (self:t) (m:Jsonrpc.Message.notification) : unit m =
-  let json = Jsonrpc.Message.yojson_of_notification m in
-  send_json_ self json
-
-let try_ f =
-  Lwt.catch
-    (fun () -> let+ x = f() in Ok x)
-    (fun e -> Lwt.return (Error e))
-
-let log_lsp_ msg =
-  Fmt.kasprintf
-    (fun s ->
-      Lsp.Logger.log ~title:Lsp.Logger.Title.Debug ~section:"jsonrpc2"
-      "%s" s)
-    msg
-
-(* read a full message *)
-let read_msg (self:t) : (Jsonrpc.Message.either, exn) result m =
-  let rec read_headers acc =
-    let*? line =
-      try_ @@ fun () -> Lwt_io.read_line self.ic
-    in
-    match String.trim line with
-    | "" -> Lwt.return (Ok acc) (* last separator *)
-    | line ->
-      begin match
-          let i = String.index line ':' in
-          if i<0 || String.get line (i+1) <> ' ' then raise Not_found;
-          let key = String.lowercase_ascii @@ String.sub line 0 i in
-          let v =
-            String.lowercase_ascii @@
-            String.trim (String.sub line (i+1) (String.length line-i-1))
-          in
-          key, v
-        with
-        | pair -> read_headers (pair :: acc)
-        | exception _ ->
-          Lwt.return (Error (E(ErrorCode.ParseError, spf "invalid header: %S" line)))
-      end
-  in
-  let*? headers = read_headers [] in
-  log_lsp_ "headers: %a" Fmt.Dump.(list @@ pair string string) headers;
-  let ok = match List.assoc "content-type" headers with
-    | "utf8" | "utf-8" -> true
-    | _ -> false
-    | exception Not_found -> true
-  in
-  if ok then (
-    match int_of_string (List.assoc "content-length" headers) with
-    | n ->
-      log_lsp_ "read %d bytes..." n;
-      let buf = Bytes.make n '\000' in
-      let*? () =
-        try_ @@ fun () -> Lwt_io.read_into_exactly self.ic buf 0 n
-      in
-      (* log_lsp_ "got bytes %S" (Bytes.unsafe_to_string buf); *)
-      let*? j =
-        try_ @@ fun () ->
-        Lwt.return @@ J.from_string (Bytes.unsafe_to_string buf)
-      in
-      begin match Jsonrpc.Message.either_of_yojson j with
-        | m -> Lwt.return @@ Ok m
-        | exception _ ->
-          Lwt.return (Error (E(ErrorCode.ParseError, "cannot decode json")))
-      end
-    | exception _ ->
-      Lwt.return @@
-      Error (E(ErrorCode.ParseError, "missing content-length' header"))
-  ) else (
-    Lwt.return @@
-    Error (E(ErrorCode.InvalidRequest, "content-type must be 'utf-8'"))
-  )
-
-let run (self:t) (task:_ Task.t) : unit m =
-  let process_msg r =
-    let module M = Jsonrpc.Message in
-    let protect ~id f =
-      Lwt.catch f
-        (fun e ->
-           let r = Jsonrpc.Response.error id
-             (Jsonrpc.Response.Error.make
-               ~code:Jsonrpc.Response.Error.Code.InternalError
-               ~message:(Printexc.to_string e) ())
-          in
-          send_response self r)
-    in
-    match r.M.id with
-    | None ->
-      (* notification *)
-      begin match Lsp.Client_notification.of_jsonrpc {r with M.id=()} with
-        | Ok n ->
-          Lwt.catch
-            (fun () ->
-              (self.s)#on_notification n
-                ~notify_back:(fun n ->
-                    let msg = Lsp.Server_notification.to_jsonrpc n in
-                    send_server_notif self msg))
-            (fun e ->
-               let msg =
-                 Lsp.Types.ShowMessageParams.create ~type_:Lsp.Types.MessageType.Error
-                   ~message:(Printexc.to_string e)
-               in
-               let msg =
-                 Lsp.Server_notification.LogMessage msg
-                 |> Lsp.Server_notification.to_jsonrpc
-               in
-               send_server_notif self msg)
-        | Error e ->
-          Lwt.fail_with (spf "cannot decode notification: %s" e)
-      end
-    | Some id ->
-      (* request, so we need to reply *)
-      Lwt.catch
-        (fun () ->
-          begin match Lsp.Client_request.of_jsonrpc {r with M.id} with
-            | Ok (Lsp.Client_request.E r) ->
-              protect ~id (fun () ->
-                let* reply = self.s#on_request r 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
-              )
-            | Error e ->
-              Lwt.fail_with (spf "cannot decode request: %s" e)
-          end)
-        (fun e ->
-          let r =
-            Jsonrpc.Response.error id
-            (Jsonrpc.Response.Error.make
-              ~code:Jsonrpc.Response.Error.Code.InternalError
-              ~message:(Printexc.to_string e) ())
-          in
-          send_response self r)
-  in
-  let rec loop () =
-    if Task.is_cancelled task then Lwt.return ()
-    else (
-      let* r = read_msg self >>= Task.unwrap in
-      Lwt.async (fun () -> process_msg r);
-      loop()
-    )
-  in
-  loop()
-

src/lwt/jsonrpc2.mli

@@ -1,24 +0,0 @@
-
-module IO : Linol.IO
-  with type 'a t = 'a Task.m
-   and type in_channel = Lwt_io.input Lwt_io.channel
-   and type out_channel = Lwt_io.output Lwt_io.channel
-
-type json = Yojson.Safe.t
-
-type t
-(** A jsonrpc2 connection. *)
-
-include module type of Linol.Make(IO)
-
-val create :
-  ic:IO.in_channel ->
-  oc:IO.out_channel ->
-  server ->
-  t
-(** Create a connection from the pair of channels *)
-
-val create_stdio : server -> t
-
-val run : t -> unit Task.t -> unit Task.m
-(** Listen for incoming messages and responses *)

src/lwt/linol_lwt.ml

@@ -1,8 +1,48 @@
 
 module type IO = Linol.IO
-module Make = Linol.Make
+
-module Jsonrpc2 = Jsonrpc2
+module IO_lwt
-module Task = Task
+  : IO with type 'a t = 'a Lwt.t
+        and type in_channel = Lwt_io.input Lwt_io.channel
+        and type out_channel = Lwt_io.output Lwt_io.channel
+= struct
+  type 'a t = 'a Lwt.t
+  let (let+) = Lwt.(>|=)
+  let (let*) = Lwt.(>>=)
+  let (and+) a b =
+    let open Lwt in
+    a >>= fun x -> b >|= fun y -> x,y
+  let return = Lwt.return
+  let failwith = Lwt.fail_with
+
+  let stdin = Lwt_io.stdin
+  let stdout = Lwt_io.stdout
+
+  type in_channel = Lwt_io.input Lwt_io.channel
+  type out_channel = Lwt_io.output Lwt_io.channel
+
+  let write_string = Lwt_io.write
+  let write = Lwt_io.write_from_exactly
+  let read = Lwt_io.read_into_exactly
+  let read_line = Lwt_io.read_line
+
+  let catch = Lwt.catch
+  let fail = Lwt.fail
+
+  let spawn f =
+    Lwt.async
+      (fun () ->
+         Lwt.catch f
+           (fun exn ->
+              Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
+                (Printexc.to_string exn);
+              Lwt.return ()))
+end
 
 include Lsp.Types
-type doc_state = Jsonrpc2.doc_state
+include IO_lwt
+type doc_state = Linol.Server.doc_state
+
+module Jsonrpc2 = Linol.Jsonrpc2.Make(IO_lwt)
+
+let run = Lwt_main.run

src/lwt/task.ml

@@ -1,118 +0,0 @@
-
-module Fmt = CCFormat
-
-type cancel = Lwt_switch.t
-
-type 'a m = 'a Lwt.t
-type 'a t = {
-  descr: string option;
-  cancel: cancel option;
-  mutable n_child: int;
-  cond: unit Lwt_condition.t;
-  parent: parent;
-  run: 'a t -> 'a m;
-}
-and parent =
-  | NoParent
-  | Parent : 'a t -> parent
-
-let cancel self =
-  let cancel_ s = Lwt.async (fun () -> Lwt_switch.turn_off s) in
-  CCOpt.iter cancel_ self.cancel
-let is_cancelled self = CCOpt.exists Lwt_switch.is_on self.cancel
-
-let return x : _ m = Lwt.return x
-
-let descr self = self.descr
-let pause (self:_ t) =
-  Lwt_switch.check self.cancel;
-  Lwt.pause()
-
-module Infix = struct
-  let (>|=) = Lwt.(>|=)
-  let (>>= ) = Lwt.(>>=)
-  let (let+) = (>|=)
-  let (let* ) = (>>=)
-  let (and+ ) = Lwt.both
-end
-
-include Infix
-
-let wait_all l =
-  let+ l = Lwt.all l in
-  match CCList.find_map (function Error e -> Some e | Ok () -> None) l with
-  | None -> Ok ()
-  | Some e -> Error e
-
-let unwrap = function
-  | Ok x -> return x
-  | Error e -> Lwt.fail e
-
-(** An exception caught and re-launched from a task *)
-module Wrapped_error = struct
-  type 'a task = 'a t
-
-  type t = E : {
-    task: 'a task;
-    e: exn;
-  } -> t
-
-  exception Wrapped of t
-
-  let rec pp out (E {task;e}) =
-    let descr = CCOpt.get_or ~default:"<no descr>" task.descr in
-    let pp_e out e = match e with
-      | Wrapped e -> pp out e
-      | e -> Fmt.string out (Printexc.to_string e)
-    in
-    Fmt.fprintf out "@[<v>error in task '%s':@ %a@]" descr pp_e e
-  let to_string = Fmt.to_string pp
-end
-
-let run_ (self:'a t) : ('a, exn) result m =
-  let rec wait_children() : unit m =
-    if self.n_child = 0 then Lwt.return ()
-    else (
-      let* () = Lwt_condition.wait self.cond in
-      wait_children()
-    )
-  in
-  let res () =
-    Lwt.catch
-      (fun () ->
-        let* x = self.run self in
-        let+ () = wait_children() in
-        Ok x)
-      (fun e ->
-         return @@ Error (Wrapped_error.Wrapped (Wrapped_error.E {task=self; e})))
-  in
-  match self.parent with
-  | NoParent -> res()
-  | Parent p ->
-    p.n_child <- 1 + p.n_child;
-    let+ r = res() in
-    p.n_child <- p.n_child - 1;
-    Lwt_condition.signal p.cond ();
-    r
-
-let run self = Lwt_main.run (run_ self)
-
-let start ?descr ?cancel run : _ t =
-  {descr; cancel; run; parent=NoParent; cond=Lwt_condition.create (); n_child=0; }
-
-let run_sub ~parent ?descr ?cancel run : _ m =
-  let t = {
-    descr; cancel; run; parent=Parent parent;
-    cond=Lwt_condition.create (); n_child=0;
-  } in
-  run_ t
-
-
-let () =
-  Printexc.register_printer
-    (function
-      | Wrapped_error.Wrapped e ->
-        let s = Wrapped_error.to_string e in
-        Some s
-      | _ -> None)
-

src/lwt/task.mli

@@ -1,60 +0,0 @@
-
-(** {1 Tasks}
-
-    Tasks built on top of Lwt, for cooperative multi-threading. *)
-
-type 'a t
-(** A task *)
-
-type 'a m = 'a Lwt.t
-(** Computation within the task *)
-
-type cancel
-
-val return : 'a -> 'a m
-
-val start :
-  ?descr:string ->
-  ?cancel:cancel -> ('a t -> 'a m) -> 'a t
-
-val descr : _ t -> string option
-
-val run : 'a t -> ('a, exn) result
-
-val run_sub :
-  parent:_ t ->
-  ?descr:string ->
-  ?cancel:cancel ->
-  ('a t -> 'a m) -> ('a, exn) result m
-
-module Wrapped_error : sig
-  type 'a task = 'a t
-
-  type t = E : {
-    task: 'a task;
-    e: exn;
-  } -> t
-
-  (** An exception caught and re-launched from a task *)
-  exception Wrapped of t
-
-  val pp : Format.formatter -> t -> unit
-  val to_string : t -> string
-end
-
-val unwrap : ('a, exn) result -> 'a m
-val is_cancelled : _ t -> bool
-val cancel : _ t -> unit
-val pause : _ t -> unit m
-
-val wait_all : (unit, exn) result m list -> (unit, exn) result m
-
-module Infix : sig
-  val (let+) : 'a m -> ('a -> 'b) -> 'b m
-  val (let* ) : 'a m -> ('a -> 'b m) -> 'b m
-  val (>|=) : 'a m -> ('a -> 'b) -> 'b m
-  val (>>= ) : 'a m -> ('a -> 'b m) -> 'b m
-  val (and+ ) : 'a m -> 'b m -> ('a*'b) m
-end
-
-include module type of Infix

src/server.ml

@@ -0,0 +1,235 @@
+
+open Sigs
+
+(** Current state of a document. *)
+type nonrec doc_state = {
+  uri: Lsp.Types.DocumentUri.t;
+  languageId: string;
+  version: int;
+  content: string;
+}
+
+(** {2 Server interface for some IO substrate} *)
+module Make(IO : IO) = struct
+  open Lsp.Types
+
+  module Position = Position
+  module Range = Range
+  module Diagnostic = Diagnostic
+  module DiagnosticSeverity = DiagnosticSeverity
+
+  (** The server baseclass *)
+  class virtual base_server = object
+    method virtual on_notification :
+      notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
+      Lsp.Client_notification.t ->
+      unit IO.t
+
+    method virtual on_request : 'a.
+      'a Lsp.Client_request.t ->
+      'a IO.t
+
+    (** Set to true if the client requested to exit *)
+    method must_quit = false
+  end
+
+  (** A wrapper to more easily reply to notifications *)
+  class notify_back ~notify_back ?version ~(uri:DocumentUri.t) () = object
+    (** Send a log message to the editor *)
+    method send_log_msg ~type_ msg : unit IO.t =
+      let params = ShowMessageParams.create ~type_ ~message:msg in
+      notify_back (Lsp.Server_notification.LogMessage params)
+
+    (** Send diagnostics for the current document *)
+    method send_diagnostic (l:Diagnostic.t list) : unit IO.t =
+      let params = PublishDiagnosticsParams.create
+          ~uri ?version ~diagnostics:l () in
+      notify_back (Lsp.Server_notification.PublishDiagnostics params)
+
+    (** Send a notification (general purpose method) *)
+    method send_notification (n:Lsp.Server_notification.t) =
+      notify_back n
+  end
+
+  (** Current state of a document. *)
+  type nonrec doc_state = doc_state = {
+    uri: DocumentUri.t;
+    languageId: string;
+    version: int;
+    content: string;
+  }
+
+  (** An easily overloadable class. Pick the methods you want to support.
+      The user must provide at least the callbacks for document lifecycle:
+      open, close, update. The most basic LSP server should check documents
+      when they're updated and report diagnostics back to the editor. *)
+  class virtual server = object(self)
+    inherit base_server
+    val mutable _quit = false
+    val docs : (DocumentUri.t, doc_state) Hashtbl.t = Hashtbl.create 16
+
+    method! must_quit = _quit
+
+    (** Find current state of the given document, if present. *)
+    method find_doc (uri:DocumentUri.t) : doc_state option =
+      try Some (Hashtbl.find docs uri)
+      with Not_found -> None
+
+    (** Override to process other requests *)
+    method on_request_unhandled
+      : type r. r Lsp.Client_request.t -> r IO.t
+      = fun _r ->
+        IO.failwith "TODO: handle this request"
+
+    (** Parameter for how to synchronize content with the editor *)
+    method config_sync_opts : TextDocumentSyncOptions.t =
+      TextDocumentSyncOptions.create
+          ~change:TextDocumentSyncKind.Incremental ~willSave:false ()
+
+    method on_req_initialize (_i:InitializeParams.t) : InitializeResult.t IO.t =
+      let sync_opts = self#config_sync_opts in
+      let capabilities =
+        ServerCapabilities.create
+          ~textDocumentSync:(`TextDocumentSyncOptions sync_opts) () in
+      IO.return @@ InitializeResult.create ~capabilities ()
+
+    (** Called when the user hovers on some identifier in the document *)
+    method on_req_hover ~uri:_ ~pos:_ (_ : doc_state) : Hover.t option IO.t =
+      IO.return None
+
+    (** Called when the user requests completion in the document *)
+    method on_req_completion ~uri:_ ~pos:_ ~ctx:_
+        (_ : doc_state) :
+          [ `CompletionList of CompletionList.t
+          | `List of CompletionItem.t list ] option IO.t =
+      IO.return None
+
+    (** Called when the user wants to jump-to-definition  *)
+    method on_req_definition ~uri:_ ~pos:_ (_ : doc_state) : Locations.t option IO.t =
+      IO.return None
+
+    method on_request
+    : type r. r Lsp.Client_request.t -> r IO.t
+    = fun (r:_ Lsp.Client_request.t) ->
+      begin match r with
+        | Lsp.Client_request.Shutdown -> _quit <- true; IO.return ()
+        | Lsp.Client_request.Initialize i -> self#on_req_initialize i
+        | Lsp.Client_request.TextDocumentHover { textDocument; position } ->
+          let doc_st = Hashtbl.find docs textDocument.uri in
+          self#on_req_hover ~uri:textDocument.uri ~pos:position doc_st
+        | Lsp.Client_request.TextDocumentCompletion { textDocument; position; context } ->
+          let doc_st = Hashtbl.find docs textDocument.uri in
+          self#on_req_completion ~uri:textDocument.uri ~pos:position ~ctx:context doc_st
+        | Lsp.Client_request.TextDocumentDefinition { textDocument; position } ->
+          let doc_st = Hashtbl.find docs textDocument.uri in
+          self#on_req_definition ~uri:textDocument.uri ~pos:position doc_st
+        | Lsp.Client_request.TextDocumentDeclaration _
+        | Lsp.Client_request.TextDocumentTypeDefinition _
+        | Lsp.Client_request.TextDocumentCodeLens _
+        | Lsp.Client_request.TextDocumentCodeLensResolve _
+        | Lsp.Client_request.TextDocumentPrepareRename _
+        | Lsp.Client_request.TextDocumentRename _
+        | Lsp.Client_request.TextDocumentLink _
+        | Lsp.Client_request.TextDocumentLinkResolve _
+        | Lsp.Client_request.DocumentSymbol _
+        | Lsp.Client_request.WorkspaceSymbol _
+        | Lsp.Client_request.DebugEcho _
+        | Lsp.Client_request.DebugTextDocumentGet _
+        | Lsp.Client_request.TextDocumentReferences _
+        | Lsp.Client_request.TextDocumentHighlight _
+        | Lsp.Client_request.TextDocumentFoldingRange _
+        | Lsp.Client_request.SignatureHelp _
+        | Lsp.Client_request.CodeAction _
+        | Lsp.Client_request.CompletionItemResolve _
+        | Lsp.Client_request.WillSaveWaitUntilTextDocument _
+        | Lsp.Client_request.TextDocumentFormatting _
+        | Lsp.Client_request.TextDocumentOnTypeFormatting _
+        | Lsp.Client_request.TextDocumentColorPresentation _
+        | Lsp.Client_request.TextDocumentColor _
+        | Lsp.Client_request.SelectionRange _
+        | Lsp.Client_request.ExecuteCommand _
+        | Lsp.Client_request.UnknownRequest _ -> self#on_request_unhandled r
+      end
+
+    (** Called when a document is opened *)
+    method virtual on_notif_doc_did_open :
+      notify_back:notify_back ->
+      TextDocumentItem.t ->
+      content:string ->
+      unit IO.t
+
+    method virtual on_notif_doc_did_close :
+      notify_back:notify_back ->
+      TextDocumentIdentifier.t ->
+      unit IO.t
+
+    (** Called when the document changes. *)
+    method virtual on_notif_doc_did_change :
+      notify_back:notify_back ->
+      VersionedTextDocumentIdentifier.t ->
+      TextDocumentContentChangeEvent.t list ->
+      old_content:string ->
+      new_content:string ->
+      unit IO.t
+
+    (** Override to handle unprocessed notifications *)
+    method on_notification_unhandled
+        ~notify_back:_ (_n:Lsp.Client_notification.t) : unit IO.t =
+      IO.return ()
+
+    method on_notification
+        ~notify_back (n:Lsp.Client_notification.t) : unit IO.t =
+      let open Lsp.Types in
+      begin match n with
+        | Lsp.Client_notification.TextDocumentDidOpen
+            {DidOpenTextDocumentParams.textDocument=doc} ->
+          let notify_back =
+            new notify_back ~uri:doc.uri ~version:doc.version ~notify_back () in
+          let st = {
+            uri=doc.uri; version=doc.version; content=doc.text;
+            languageId=doc.languageId;
+          } in
+          Hashtbl.replace docs doc.uri st;
+          self#on_notif_doc_did_open ~notify_back doc ~content:st.content
+        | Lsp.Client_notification.TextDocumentDidClose {textDocument=doc} ->
+          let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
+          self#on_notif_doc_did_close ~notify_back doc
+        | Lsp.Client_notification.TextDocumentDidChange {textDocument=doc; contentChanges=c} ->
+          let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
+          begin match Hashtbl.find docs doc.uri with
+            | exception Not_found -> IO.failwith "unknown document"
+            | st ->
+              let old_content = st.content in
+              let new_doc: Lsp.Text_document.t =
+                let doc = Lsp.Text_document.make
+                    (DidOpenTextDocumentParams.create
+                       ~textDocument:(
+                         TextDocumentItem.create ~languageId:st.languageId
+                           ~uri:doc.uri ~version:st.version ~text:st.content))
+                in
+                List.fold_left
+                  (fun d ev -> Lsp.Text_document.apply_content_change d ev)
+                  doc c
+              in
+              let new_st = {
+                st with
+                content=Lsp.Text_document.text new_doc;
+                version=Lsp.Text_document.version new_doc;
+              } in
+              Hashtbl.replace docs doc.uri new_st;
+              self#on_notif_doc_did_change ~notify_back doc c ~old_content
+                ~new_content:new_st.content
+          end
+        | Lsp.Client_notification.Exit -> _quit <- true; IO.return ()
+        | Lsp.Client_notification.DidSaveTextDocument _
+        | Lsp.Client_notification.WillSaveTextDocument _
+        | Lsp.Client_notification.ChangeWorkspaceFolders _
+        | Lsp.Client_notification.ChangeConfiguration _
+        | Lsp.Client_notification.Initialized
+        | Lsp.Client_notification.Unknown_notification _
+        | Lsp.Client_notification.CancelRequest _
+          ->
+          self#on_notification_unhandled ~notify_back n
+      end
+  end
+end

src/sigs.ml

@@ -0,0 +1,31 @@
+
+
+(** {2 Parametrized IO Interface} *)
+module type IO = sig
+  type 'a t
+
+  val return : 'a -> 'a t
+  val failwith : string -> 'a t
+
+  val (let+) : 'a t -> ('a -> 'b) -> 'b t
+  val (let*) : 'a t -> ('a -> 'b t) -> 'b t
+  val (and+) : 'a t -> 'b t -> ('a * 'b) t
+
+  type in_channel
+  type out_channel
+
+  val stdin : in_channel
+  val stdout : out_channel
+
+  val read : in_channel -> bytes -> int -> int -> unit t
+  val read_line : in_channel -> string t
+
+  val write : out_channel -> bytes -> int -> int -> unit t
+  val write_string : out_channel -> string -> unit t
+
+  val spawn : (unit -> unit t) -> unit
+  (** Spawn a new task that executes concurrently. *)
+
+  val fail : exn -> unit t
+  val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t
+end