diff --git a/example/template/main.ml b/example/template/main.ml index 21019462..c9f9c266 100644 --- a/example/template/main.ml +++ b/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 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 server = Linol_lwt.Jsonrpc2.create_stdio s in + 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 diff --git a/linol.opam b/linol.opam index e772c77a..ee533e2d 100644 --- a/linol.opam +++ b/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 } diff --git a/src/blocking_IO.ml b/src/blocking_IO.ml new file mode 100644 index 00000000..58b1ceb4 --- /dev/null +++ b/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 diff --git a/src/blocking_IO.mli b/src/blocking_IO.mli new file mode 100644 index 00000000..0ffde6ef --- /dev/null +++ b/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 diff --git a/src/dune b/src/dune index 525ea797..2a23d29c 100644 --- a/src/dune +++ b/src/dune @@ -3,4 +3,4 @@ (name linol) (public_name linol) (flags :standard -warn-error -a+8) - (libraries containers lsp)) + (libraries containers yojson lsp)) diff --git a/src/jsonrpc2.ml b/src/jsonrpc2.ml new file mode 100644 index 00000000..8d387d4f --- /dev/null +++ b/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 + diff --git a/src/jsonrpc2.mli b/src/jsonrpc2.mli new file mode 100644 index 00000000..72c12f41 --- /dev/null +++ b/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 diff --git a/src/linol.ml b/src/linol.ml index d2e386da..649e1613 100644 --- a/src/linol.ml +++ b/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 = 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 diff --git a/src/lwt/jsonrpc2.ml b/src/lwt/jsonrpc2.ml deleted file mode 100644 index fdad4d1b..00000000 --- a/src/lwt/jsonrpc2.ml +++ /dev/null @@ -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() - diff --git a/src/lwt/jsonrpc2.mli b/src/lwt/jsonrpc2.mli deleted file mode 100644 index 2d4df74b..00000000 --- a/src/lwt/jsonrpc2.mli +++ /dev/null @@ -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 *) diff --git a/src/lwt/linol_lwt.ml b/src/lwt/linol_lwt.ml index 0247ac07..ef1ae3d6 100644 --- a/src/lwt/linol_lwt.ml +++ b/src/lwt/linol_lwt.ml @@ -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 diff --git a/src/lwt/task.ml b/src/lwt/task.ml deleted file mode 100644 index bb6712a5..00000000 --- a/src/lwt/task.ml +++ /dev/null @@ -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:"" 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 "@[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) - diff --git a/src/lwt/task.mli b/src/lwt/task.mli deleted file mode 100644 index 8a835af4..00000000 --- a/src/lwt/task.mli +++ /dev/null @@ -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 diff --git a/src/server.ml b/src/server.ml new file mode 100644 index 00000000..623f660c --- /dev/null +++ b/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 diff --git a/src/sigs.ml b/src/sigs.ml new file mode 100644 index 00000000..47db2bf7 --- /dev/null +++ b/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