simon/linol
1
0
Fork 0
mirror of https://github.com/c-cube/linol.git synced 2025-12-06 03:05:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Simon Cruanes 2021-03-25 17:09:03 -04:00
parent e30191cfc1
commit fc17e1e59b
15 changed files with 642 additions and 678 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
example/template/main.ml
View file

@ -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 task =
Linol_lwt.Task.start ~descr:"top task"
(fun _top_task ->
let server = Linol_lwt.Jsonrpc2.create_stdio s in
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 task = Linol_lwt.Jsonrpc2.run server in
match Linol_lwt.run task with
| () -> ()
| exception e ->
let e = Printexc.to_string e in
Printf.eprintf "error: %s\n%!" e;
exit 1

1
linol.opam
View file

@ -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 }

39
src/blocking_IO.ml Normal file
View file

@ -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

6
src/blocking_IO.mli Normal file
View file

@ -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

2
src/dune
View file

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

240
src/jsonrpc2.ml Normal file
View file

@ -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

32
src/jsonrpc2.mli Normal file
View file

@ -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

238
src/linol.ml
View file

@ -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 = 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
end
module type IO = Sigs.IO
module Jsonrpc2 = Jsonrpc2
module Server = Server
module Blocking_IO = Blocking_IO
(** {2 Server interface for some IO substrate} *)
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
module Make = Jsonrpc2.Make

218
src/lwt/jsonrpc2.ml
View file

@ -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()

24
src/lwt/jsonrpc2.mli
View file

@ -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 *)

48
src/lwt/linol_lwt.ml
View file

@ -1,8 +1,48 @@
module type IO = Linol.IO
module Make = Linol.Make
module Jsonrpc2 = Jsonrpc2
module Task = Task
module IO_lwt
: 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

118
src/lwt/task.ml
View file

@ -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)

60
src/lwt/task.mli
View file

@ -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

235
src/server.ml Normal file
View file

@ -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

31
src/sigs.ml Normal file
View file

@ -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