Implement Eio backend

README.md

@@ -1,7 +1,7 @@
 
 # Linol [![build](https://github.com/c-cube/linol/actions/workflows/main.yml/badge.svg)](https://github.com/c-cube/linol/actions/workflows/main.yml)
 
-This is a wrapper around the `lsp` library, which provides base types for the protocol. Linol ("linol is not ocaml-lsp") provides an object abstraction so that users can override only the methods they provide, and a Lwt implementation of the jsonrpc wire protocol.
+This is a wrapper around the `lsp` library, which provides base types for the protocol. Linol ("linol is not ocaml-lsp") provides an object abstraction so that users can override only the methods they provide, and a Lwt/Eio implementation of the jsonrpc wire protocol.
 
 ## License
 

dune-project

@@ -60,3 +60,27 @@
     (>= "1.17")
     (< "1.18")))
   ("odoc" :with-doc)))
+
+(package
+ (name linol-eio)
+ (authors "Nick Hu")
+ (synopsis "LSP server library (with Eio for concurrency)")
+ (depends
+  ("yojson"
+   (>= "1.6"))
+  ("linol"
+   (= :version))
+  base-unix
+  ("eio"
+   (and
+    (>= "1.0")
+    (< "1.0")))
+  ("lsp"
+   (and
+    (>= "1.17")
+    (< "1.18")))
+  ("jsonrpc"
+   (and
+    (>= "1.17")
+    (< "1.18")))
+  ("odoc" :with-doc)))

example/template-eio/dune

@@ -0,0 +1,14 @@
+(executable
+ (name main)
+ (libraries
+  ; Deps on linol + Eio backend
+  linol
+  linol-eio
+  eio_main
+  ; Types from the lsp library are exposed by the linol libs,
+  ; and thus almost guaranteed to be used by code using linol;
+  ; it is thus better to explicitly list lsp as a dep rather
+  ; than rely on its inclusion as a transitive dep of linol
+  ; since it would for instance generate errors if the
+  ; implicit-transitive-deps option of dune is set to false
+  lsp))

example/template-eio/main.ml

@@ -0,0 +1,97 @@
+(* This file is free software, part of linol. See file "LICENSE" for more information *)
+
+(* Some user code
+
+   The code here is just a placeholder to make this file compile, it is expected
+   that users have an implementation of a processing function for input contents.
+
+   Here we expect a few things:
+   - a type to represent a state/environment that results from processing an
+     input file
+   - a function procdessing an input file (given the file contents as a string),
+     which return a state/environment
+   - a function to extract a list of diagnostics from a state/environment.
+     Diagnostics includes all the warnings, errors and messages that the processing
+     of a document are expected to be able to return.
+*)
+
+type state_after_processing = unit
+
+let process_some_input_file (_file_contents : string) : state_after_processing =
+  ()
+
+let diagnostics (_state : state_after_processing) : Lsp.Types.Diagnostic.t list
+    =
+  []
+
+(* Lsp server class
+
+   This is the main point of interaction beetween the code checking documents
+   (parsing, typing, etc...), and the code of linol.
+
+   The [Linol_eio.Jsonrpc2.server] class defines a method for each of the action
+   that the lsp server receives, such as opening of a document, when a document
+   changes, etc.. By default, the method predefined does nothing (or errors out ?),
+   so that users only need to override methods that they want the server to
+   actually meaningfully interpret and respond to.
+*)
+class lsp_server =
+  object (self)
+    inherit Linol_eio.Jsonrpc2.server
+
+    (* one env per document *)
+    val buffers : (Lsp.Types.DocumentUri.t, state_after_processing) Hashtbl.t =
+      Hashtbl.create 32
+
+    method spawn_query_handler f = Linol_eio.spawn f
+
+    (* We define here a helper method that will:
+       - process a document
+       - store the state resulting from the processing
+       - return the diagnostics from the new state
+    *)
+    method private _on_doc ~(notify_back : Linol_eio.Jsonrpc2.notify_back)
+        (uri : Lsp.Types.DocumentUri.t) (contents : string) =
+      let new_state = process_some_input_file contents in
+      Hashtbl.replace buffers uri new_state;
+      let diags = diagnostics new_state in
+      notify_back#send_diagnostic diags
+
+    (* 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_eio.t =
+      self#_on_doc ~notify_back d.uri content
+
+    (* Similarly, we also override the [on_notify_doc_did_change] method that will be called
+       by the server each time a new document is opened. *)
+    method on_notif_doc_did_change ~notify_back d _c ~old_content:_old
+        ~new_content =
+      self#_on_doc ~notify_back d.uri new_content
+
+    (* 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_eio.t =
+      Hashtbl.remove buffers d.uri;
+      ()
+  end
+
+(* Main code
+   This is the code that creates an instance of the lsp server class
+   and runs it as a task. *)
+let run () =
+  Eio_main.run @@ fun env ->
+  let s = new lsp_server in
+  let server = Linol_eio.Jsonrpc2.create_stdio ~env s in
+  let task =
+    let shutdown () = s#get_status = `ReceivedExit in
+    Linol_eio.Jsonrpc2.run ~shutdown server
+  in
+  match task with
+  | () -> ()
+  | exception e ->
+    let e = Printexc.to_string e in
+    Printf.eprintf "error: %s\n%!" e;
+    exit 1
+
+(* Finally, we actually run the server *)
+let () = run ()

example/template-lwt/main.ml

@@ -80,7 +80,7 @@ class lsp_server =
    and runs it as a task. *)
 let run () =
   let s = new lsp_server in
-  let server = Linol_lwt.Jsonrpc2.create_stdio s in
+  let server = Linol_lwt.Jsonrpc2.create_stdio ~env:() s in
   let task =
     let shutdown () = s#get_status = `ReceivedExit in
     Linol_lwt.Jsonrpc2.run ~shutdown server

linol-eio.opam

@@ -0,0 +1,33 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.5"
+synopsis: "LSP server library (with Eio for concurrency)"
+authors: ["Nick Hu"]
+license: "MIT"
+homepage: "https://github.com/c-cube/linol"
+bug-reports: "https://github.com/c-cube/linol/issues"
+depends: [
+  "dune" {>= "2.0"}
+  "yojson" {>= "1.6"}
+  "linol" {= version}
+  "base-unix"
+  "eio" {>= "1.0" & < "1.0"}
+  "lsp" {>= "1.17" & < "1.18"}
+  "jsonrpc" {>= "1.17" & < "1.18"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {pinned}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/c-cube/linol.git"

src/blocking_IO.ml

@@ -1,6 +1,7 @@
 open Common_
 
 type 'a t = 'a
+type env = unit
 type nonrec in_channel = in_channel
 type nonrec out_channel = out_channel
 
@@ -10,8 +11,8 @@ let ( and+ ) a b = a, b
 let return x = x
 let failwith = failwith
 let fail = raise
-let stdin = stdin
-let stdout = stdout
+let stdin = fun () -> stdin
+let stdout = fun () -> stdout
 
 let default_spawn f =
   let run () =

src/blocking_IO.mli

@@ -3,6 +3,7 @@
 include
   Sigs.IO
     with type 'a t = 'a
+     and type env = unit
      and type in_channel = in_channel
      and type out_channel = out_channel
 

src/eio/dune

@@ -0,0 +1,5 @@
+(library
+ (name linol_eio)
+ (public_name linol-eio)
+ (libraries eio eio.unix linol)
+ (flags :standard -warn-error -a))

src/eio/linol_eio.ml

@@ -0,0 +1,58 @@
+module type IO = Linol.IO
+
+module IO_eio :
+  IO
+    with type 'a t = 'a
+     and type env = Eio_unix.Stdenv.base
+     and type in_channel = Eio.Buf_read.t
+     and type out_channel = Eio_unix.sink_ty Eio.Std.r = struct
+  type 'a t = 'a
+
+  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 catch f handler = try f () with exn -> handler exn
+
+  let stdin env = Eio.Buf_read.of_flow ~max_size:1_000_000 (Eio.Stdenv.stdin env)
+  let stdout = Eio.Stdenv.stdout
+
+  type env = Eio_unix.Stdenv.base
+  type in_channel = Eio.Buf_read.t
+  type out_channel = Eio_unix.sink_ty Eio.Std.r
+
+  let write_string out_ch str = Eio.Flow.copy_string str out_ch
+  let write out_ch bytes off len =
+    Eio.Buf_write.with_flow out_ch @@ fun w ->
+    Eio.Buf_write.bytes w ~off ~len bytes
+  let read in_ch bytes off len =
+    let str = Eio.Buf_read.take len in_ch in
+    Bytes.blit_string str off bytes 0 len
+  let read_line in_ch =
+    Eio.Buf_read.line in_ch
+end
+
+(** Spawn function. *)
+let spawn f =
+  let promise, resolver = Eio.Promise.create () in
+  begin
+    try
+      f ();
+      Eio.Promise.resolve_ok resolver ()
+    with
+      exn ->
+      (Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
+        (Printexc.to_string exn));
+      Eio.Promise.resolve_error resolver exn
+    end;
+
+  Eio.Promise.await_exn promise
+
+include Lsp.Types
+include IO_eio
+
+type doc_state = Linol.Server.doc_state
+
+module Jsonrpc2 = Linol.Jsonrpc2.Make (IO_eio)

src/jsonrpc2.ml

@@ -22,7 +22,7 @@ module type S = sig
     t
 
   val create_stdio :
-    ?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> server -> t
+    ?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> env:IO.env -> server -> t
 
   val send_server_notification : t -> Lsp.Server_notification.t -> unit IO.t
 
@@ -86,8 +86,8 @@ module Make (IO : IO) : S with module IO = IO = struct
       pending_responses = Hashtbl.create 8;
     }
 
-  let create_stdio ?on_received ?on_sent server : t =
-    create ?on_received ?on_sent ~ic:IO.stdin ~oc:IO.stdout server
+  let create_stdio ?on_received ?on_sent ~env server : t =
+    create ?on_received ?on_sent ~ic:(IO.stdin env) ~oc:(IO.stdout env) server
 
   (* send a single message *)
   let send_json_ (self : t) (j : json) : unit IO.t =

src/jsonrpc2.mli

@@ -24,7 +24,7 @@ module type S = sig
   (** Create a connection from the pair of channels *)
 
   val create_stdio :
-    ?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> server -> t
+    ?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> env:IO.env -> server -> t
   (** Create a connection using stdin/stdout *)
 
   val send_server_notification : t -> Lsp.Server_notification.t -> unit IO.t

src/lwt/linol_lwt.ml

@@ -3,6 +3,7 @@ module type IO = Linol.IO
 module IO_lwt :
   IO
     with type 'a t = 'a Lwt.t
+     and type env = unit
      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
@@ -17,9 +18,10 @@ module IO_lwt :
 
   let return = Lwt.return
   let failwith = Lwt.fail_with
-  let stdin = Lwt_io.stdin
-  let stdout = Lwt_io.stdout
+  let stdin = fun () -> Lwt_io.stdin
+  let stdout = fun () -> Lwt_io.stdout
 
+  type env = unit
   type in_channel = Lwt_io.input Lwt_io.channel
   type out_channel = Lwt_io.output Lwt_io.channel
 

src/sigs.ml

@@ -8,11 +8,12 @@ module type IO = sig
   val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
   val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
 
+  type env
   type in_channel
   type out_channel
 
-  val stdin : in_channel
-  val stdout : out_channel
+  val stdin : env -> in_channel
+  val stdout : env -> 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