diff --git a/README.md b/README.md index 18005461..8851df9a 100644 --- a/README.md +++ b/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 diff --git a/dune-project b/dune-project index 268ca51b..10dbea73 100644 --- a/dune-project +++ b/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))) diff --git a/example/template-eio/dune b/example/template-eio/dune new file mode 100644 index 00000000..99fe0df1 --- /dev/null +++ b/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)) diff --git a/example/template-eio/main.ml b/example/template-eio/main.ml new file mode 100644 index 00000000..a44010e0 --- /dev/null +++ b/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 () diff --git a/example/template/dune b/example/template-lwt/dune similarity index 100% rename from example/template/dune rename to example/template-lwt/dune diff --git a/example/template/main.ml b/example/template-lwt/main.ml similarity index 98% rename from example/template/main.ml rename to example/template-lwt/main.ml index 3e085ccb..42e0ea26 100644 --- a/example/template/main.ml +++ b/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 diff --git a/linol-eio.opam b/linol-eio.opam new file mode 100644 index 00000000..be6c986a --- /dev/null +++ b/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" diff --git a/src/blocking_IO.ml b/src/blocking_IO.ml index 1abfc836..60560e44 100644 --- a/src/blocking_IO.ml +++ b/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 () = diff --git a/src/blocking_IO.mli b/src/blocking_IO.mli index f43882f6..12beb86f 100644 --- a/src/blocking_IO.mli +++ b/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 diff --git a/src/eio/dune b/src/eio/dune new file mode 100644 index 00000000..101c0a3f --- /dev/null +++ b/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)) diff --git a/src/eio/linol_eio.ml b/src/eio/linol_eio.ml new file mode 100644 index 00000000..8ecc2b1d --- /dev/null +++ b/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) diff --git a/src/jsonrpc2.ml b/src/jsonrpc2.ml index 70fbbab0..6fa1ca11 100644 --- a/src/jsonrpc2.ml +++ b/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 = diff --git a/src/jsonrpc2.mli b/src/jsonrpc2.mli index ae8d9225..2ed46b04 100644 --- a/src/jsonrpc2.mli +++ b/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 diff --git a/src/lwt/linol_lwt.ml b/src/lwt/linol_lwt.ml index c8dedd5c..dbfa814b 100644 --- a/src/lwt/linol_lwt.ml +++ b/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 diff --git a/src/sigs.ml b/src/sigs.ml index 24f03dc9..125be840 100644 --- a/src/sigs.ml +++ b/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