From e9cc94dc1420a904878f5d5b06b0b1216ced9525 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 10 Mar 2023 23:12:41 -0500 Subject: [PATCH] autoformat --- example/template/dune | 25 +- example/template/main.ml | 20 +- src/blocking_IO.ml | 31 +- src/blocking_IO.mli | 5 +- src/dune | 9 +- src/jsonrpc2.mli | 19 +- src/linol.ml | 3 +- src/log.ml | 1 - src/lwt/dune | 9 +- src/lwt/linol_lwt.ml | 40 +-- src/server.ml | 647 ++++++++++++++++++++------------------- src/sigs.ml | 11 +- 12 files changed, 409 insertions(+), 411 deletions(-) diff --git a/example/template/dune b/example/template/dune index bf7c6cb1..7d297713 100644 --- a/example/template/dune +++ b/example/template/dune @@ -1,14 +1,13 @@ (executable - (name main) - (libraries - ; Deps on linol + LWT backend - linol linol-lwt - ; 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 - ) - ) + (name main) + (libraries + ; Deps on linol + LWT backend + linol + linol-lwt + ; 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/main.ml b/example/template/main.ml index c9f9c266..3ba7ec58 100644 --- a/example/template/main.ml +++ b/example/template/main.ml @@ -20,10 +20,10 @@ 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 = +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 @@ -36,21 +36,20 @@ let diagnostics (_state : state_after_processing) : Lsp.Types.Diagnostic.t list actually meaningfully interpret and respond to. *) class lsp_server = - object(self) + object (self) inherit Linol_lwt.Jsonrpc2.server (* one env per document *) - val buffers: (Lsp.Types.DocumentUri.t, state_after_processing) Hashtbl.t - = Hashtbl.create 32 + val buffers : (Lsp.Types.DocumentUri.t, state_after_processing) Hashtbl.t = + Hashtbl.create 32 (* 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_lwt.Jsonrpc2.notify_back) - (uri:Lsp.Types.DocumentUri.t) (contents:string) = + method private _on_doc ~(notify_back : Linol_lwt.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 @@ -63,7 +62,8 @@ class lsp_server = (* 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 = + 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 @@ -71,7 +71,6 @@ class lsp_server = method on_notif_doc_did_close ~notify_back:_ d : unit Linol_lwt.t = Hashtbl.remove buffers d.uri; Linol_lwt.return () - end (* Main code @@ -90,4 +89,3 @@ let run () = (* Finally, we actually run the server *) let () = run () - diff --git a/src/blocking_IO.ml b/src/blocking_IO.ml index 4bfad1fd..2c4c9d00 100644 --- a/src/blocking_IO.ml +++ b/src/blocking_IO.ml @@ -1,48 +1,43 @@ - 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 ( let* ) x f = f x -let (and+) a b = a,b +let ( and+ ) a b = a, b let return x = x - let failwith = failwith let fail = raise - let stdin = stdin let stdout = stdout let default_spawn_ f = let run () = - try f() + try f () with e -> - Log.err (fun k->k - "uncaught exception in `spawn`:\n%s\n%!" - (Printexc.to_string e)); + Log.err (fun k -> + k "uncaught exception in `spawn`:\n%s\n%!" (Printexc.to_string e)); raise e in ignore (Thread.create run ()) let spawn_ref_ = ref default_spawn_ - let set_spawn_function f = spawn_ref_ := f let spawn f = !spawn_ref_ f - -let catch f g = - try f() - with e -> g e +let catch f g = try f () with e -> g e let rec read ic buf i len = - if len>0 then ( + if len > 0 then ( let n = input ic buf i len in - read ic buf (i+n) (len-n) + 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 + output oc b i len; + flush oc + let write_string oc s = - output_string oc s; flush oc + output_string oc s; + flush oc diff --git a/src/blocking_IO.mli b/src/blocking_IO.mli index bdec4dbe..5bd51dd4 100644 --- a/src/blocking_IO.mli +++ b/src/blocking_IO.mli @@ -1,7 +1,8 @@ - (** {1 Blocking IO with a new thread for each [spawn]} *) -include Sigs.IO with type 'a t = 'a +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 6a70053f..8cb8c2a1 100644 --- a/src/dune +++ b/src/dune @@ -1,6 +1,5 @@ - (library - (name linol) - (public_name linol) - (flags :standard -warn-error -a+8) - (libraries yojson lsp logs threads)) + (name linol) + (public_name linol) + (flags :standard -warn-error -a+8) + (libraries yojson lsp logs threads)) diff --git a/src/jsonrpc2.mli b/src/jsonrpc2.mli index 5df03616..0ed2fe1f 100644 --- a/src/jsonrpc2.mli +++ b/src/jsonrpc2.mli @@ -1,5 +1,3 @@ - - type json = Yojson.Safe.t module type IO = Sigs.IO @@ -10,24 +8,17 @@ module type S = sig type t (** A jsonrpc2 connection. *) - include module type of Server.Make(IO) + include module type of Server.Make (IO) - val create : - ic:IO.in_channel -> - oc:IO.out_channel -> - server -> - t + 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. + 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 - +module Make (IO : IO) : S with module IO = IO diff --git a/src/linol.ml b/src/linol.ml index 64f3080f..549c9569 100644 --- a/src/linol.ml +++ b/src/linol.ml @@ -1,13 +1,12 @@ - (** {1 Linol} Abstraction over The "Lsp" library, to make it easier to develop LSP servers in OCaml (but not necessarily {b for} OCaml). *) module type IO = Sigs.IO + module Jsonrpc2 = Jsonrpc2 module Server = Server module Blocking_IO = Blocking_IO module Log = Log - module Make = Jsonrpc2.Make diff --git a/src/log.ml b/src/log.ml index dbef00c7..f562ad6c 100644 --- a/src/log.ml +++ b/src/log.ml @@ -1,2 +1 @@ - include (val Logs.src_log (Logs.Src.create ~doc:"linol (LSP library)" "linol")) diff --git a/src/lwt/dune b/src/lwt/dune index 183e0863..109364d6 100644 --- a/src/lwt/dune +++ b/src/lwt/dune @@ -1,6 +1,5 @@ - (library - (name linol_lwt) - (public_name linol-lwt) - (libraries yojson lwt lwt.unix linol lsp jsonrpc) - (flags :standard -warn-error -a)) + (name linol_lwt) + (public_name linol-lwt) + (libraries yojson lwt lwt.unix linol lsp jsonrpc) + (flags :standard -warn-error -a)) diff --git a/src/lwt/linol_lwt.ml b/src/lwt/linol_lwt.ml index ef1ae3d6..e3b65fac 100644 --- a/src/lwt/linol_lwt.ml +++ b/src/lwt/linol_lwt.ml @@ -1,20 +1,22 @@ - module type IO = Linol.IO -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 +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 ( let+ ) = Lwt.( >|= ) + let ( let* ) = Lwt.( >>= ) + + let ( and+ ) a b = let open Lwt in - a >>= fun x -> b >|= fun y -> x,y + 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 @@ -25,24 +27,22 @@ module IO_lwt 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 ())) + 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 include IO_lwt + type doc_state = Linol.Server.doc_state -module Jsonrpc2 = Linol.Jsonrpc2.Make(IO_lwt) +module Jsonrpc2 = Linol.Jsonrpc2.Make (IO_lwt) let run = Lwt_main.run diff --git a/src/server.ml b/src/server.ml index 3a300f3c..66454484 100644 --- a/src/server.ml +++ b/src/server.ml @@ -1,13 +1,12 @@ - open Sigs -(** Current state of a document. *) type nonrec doc_state = { uri: Lsp.Types.DocumentUri.t; languageId: string; version: int; content: string; } +(** Current state of a document. *) (** {2 Request ID} @@ -22,9 +21,8 @@ module Req_id = struct end (** {2 Server interface for some IO substrate} *) -module Make(IO : IO) = struct +module Make (IO : IO) = struct open Lsp.Types - module Position = Position module Range = Range module Diagnostic = Diagnostic @@ -32,408 +30,435 @@ module Make(IO : IO) = struct module Req_id = Req_id (** 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 + 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. - notify_back:(Lsp.Server_notification.t -> unit IO.t) -> - id:Req_id.t -> - 'a Lsp.Client_request.t -> - 'a IO.t - (** Method called to handle client requests. + method virtual on_request + : 'a. + notify_back:(Lsp.Server_notification.t -> unit IO.t) -> + id:Req_id.t -> + 'a Lsp.Client_request.t -> + 'a IO.t + (** Method called to handle client requests. @param notify_back an object used to reply to the client, send progress messages, diagnostics, etc. @param id the query RPC ID, can be used for tracing, cancellation, etc. *) - (** Set to true if the client requested to exit *) - method must_quit = false - end + method must_quit = false + (** Set to true if the client requested to exit *) + end (** A wrapper to more easily reply to notifications *) - class notify_back ~notify_back ?version ?(uri:DocumentUri.t option) () = object - val mutable uri = uri - method set_uri u = uri <- Some u + class notify_back ~notify_back ?version ?(uri : DocumentUri.t option) () = + object + val mutable uri = uri + method set_uri u = uri <- Some u - (** Send a log message to the editor *) - method send_log_msg ~type_ msg : unit IO.t = - let params = LogMessageParams.create ~type_ ~message:msg in - notify_back (Lsp.Server_notification.LogMessage params) + method send_log_msg ~type_ msg : unit IO.t = + let params = LogMessageParams.create ~type_ ~message:msg in + notify_back (Lsp.Server_notification.LogMessage params) + (** Send a log message to the editor *) - (** Send diagnostics for the current document *) - method send_diagnostic (l:Diagnostic.t list) : unit IO.t = - match uri with - | None -> IO.failwith "notify_back: cannot publish diagnostics, no URI given" - | Some uri -> - let params = PublishDiagnosticsParams.create - ~uri ?version ~diagnostics:l () in - notify_back (Lsp.Server_notification.PublishDiagnostics params) + method send_diagnostic (l : Diagnostic.t list) : unit IO.t = + match uri with + | None -> + IO.failwith "notify_back: cannot publish diagnostics, no URI given" + | Some uri -> + let params = + PublishDiagnosticsParams.create ~uri ?version ~diagnostics:l () + in + notify_back (Lsp.Server_notification.PublishDiagnostics params) + (** Send diagnostics for the current document *) - (** Send a notification (general purpose method) *) - method send_notification (n:Lsp.Server_notification.t) = - notify_back n - end + method send_notification (n : Lsp.Server_notification.t) = notify_back n + (** Send a notification (general purpose method) *) + end - (** Current state of a document. *) type nonrec doc_state = doc_state = { uri: DocumentUri.t; languageId: string; version: int; content: string; } + (** Current state of a document. *) (** 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 + 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 - method! must_quit = _quit + method find_doc (uri : DocumentUri.t) : doc_state option = + try Some (Hashtbl.find docs uri) with Not_found -> None + (** Find current state of the given document, if present. *) - (** 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 + method on_request_unhandled : type r. + notify_back:notify_back -> + id:Req_id.t -> + r Lsp.Client_request.t -> + r IO.t = + fun ~notify_back:_ ~id:_ _r -> + Log.debug (fun k -> k "req: unhandled request"); + IO.failwith "TODO: handle this request" + (** Override to process other requests *) - (** Override to process other requests *) - method on_request_unhandled - : type r. notify_back:notify_back -> - id:Req_id.t -> r Lsp.Client_request.t -> r IO.t - = fun ~notify_back:_ ~id:_ _r -> - Log.debug (fun k->k "req: unhandled request"); - IO.failwith "TODO: handle this request" + method config_sync_opts : TextDocumentSyncOptions.t = + TextDocumentSyncOptions.create ~change:TextDocumentSyncKind.Incremental + ~openClose:true + ~save:(`SaveOptions (SaveOptions.create ~includeText:false ())) + ~willSave:false () + (** Parameter for how to synchronize content with the editor *) - (** Parameter for how to synchronize content with the editor *) - method config_sync_opts : TextDocumentSyncOptions.t = - TextDocumentSyncOptions.create - ~change:TextDocumentSyncKind.Incremental ~openClose:true - ~save:(`SaveOptions (SaveOptions.create ~includeText:false ())) - ~willSave:false () - - method config_completion : CompletionOptions.t option = None - (** Configuration for the completion API. + method config_completion : CompletionOptions.t option = None + (** Configuration for the completion API. @since 0.4 *) - method config_code_lens_options : CodeLensOptions.t option = None - (** @since 0.3 *) + method config_code_lens_options : CodeLensOptions.t option = None + (** @since 0.3 *) - method config_definition : - [`Bool of bool | `DefinitionOptions of DefinitionOptions.t ] option = None - (** @since 0.3 *) + method config_definition + : [ `Bool of bool | `DefinitionOptions of DefinitionOptions.t ] option + = + None + (** @since 0.3 *) - method config_hover : - [`Bool of bool | `HoverOptions of HoverOptions.t ] option = None - (** @since 0.3 *) + method config_hover + : [ `Bool of bool | `HoverOptions of HoverOptions.t ] option = + None + (** @since 0.3 *) - method config_symbol : - [`Bool of bool | `DocumentSymbolOptions of DocumentSymbolOptions.t ] option = None - (** @since 0.3 *) + method config_symbol + : [ `Bool of bool + | `DocumentSymbolOptions of DocumentSymbolOptions.t + ] + option = + None + (** @since 0.3 *) - method config_code_action_provider : - [`CodeActionOptions of CodeActionOptions.t | `Bool of bool] = `Bool false - (** @since 0.3 *) + method config_code_action_provider + : [ `CodeActionOptions of CodeActionOptions.t | `Bool of bool ] = + `Bool false + (** @since 0.3 *) - (** Modify capabilities before sending them back to the client. + method config_modify_capabilities (c : ServerCapabilities.t) + : ServerCapabilities.t = + c + (** Modify capabilities before sending them back to the client. By default we just return them unmodified. @since 0.3 *) - method config_modify_capabilities (c:ServerCapabilities.t) : ServerCapabilities.t = c - (** List of commands available *) - method config_list_commands : string list = [] + method config_list_commands : string list = [] + (** List of commands available *) - method on_req_initialize ~notify_back:_ - (_i:InitializeParams.t) : InitializeResult.t IO.t = - let sync_opts = self#config_sync_opts in - let capabilities = - ServerCapabilities.create - ?codeLensProvider:self#config_code_lens_options - ~codeActionProvider:self#config_code_action_provider - ~executeCommandProvider:(ExecuteCommandOptions.create - ~commands:self#config_list_commands ()) - ?completionProvider:self#config_completion - ?definitionProvider:self#config_definition - ?hoverProvider:self#config_hover - ?documentSymbolProvider:self#config_symbol - ~textDocumentSync:(`TextDocumentSyncOptions sync_opts) () - |> self#config_modify_capabilities - in - IO.return @@ InitializeResult.create ~capabilities () + method on_req_initialize ~notify_back:_ (_i : InitializeParams.t) + : InitializeResult.t IO.t = + let sync_opts = self#config_sync_opts in + let capabilities = + ServerCapabilities.create + ?codeLensProvider:self#config_code_lens_options + ~codeActionProvider:self#config_code_action_provider + ~executeCommandProvider: + (ExecuteCommandOptions.create ~commands:self#config_list_commands + ()) + ?completionProvider:self#config_completion + ?definitionProvider:self#config_definition + ?hoverProvider:self#config_hover + ?documentSymbolProvider:self#config_symbol + ~textDocumentSync:(`TextDocumentSyncOptions sync_opts) () + |> self#config_modify_capabilities + in + IO.return @@ InitializeResult.create ~capabilities () - (** Called when the user hovers on some identifier in the document *) - method on_req_hover ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~workDoneToken:_ - (_ : doc_state) : Hover.t option IO.t = - IO.return None + method on_req_hover ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~workDoneToken:_ + (_ : doc_state) : Hover.t option IO.t = + IO.return None + (** Called when the user hovers on some identifier in the document *) - (** Called when the user requests completion in the document *) - method on_req_completion ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~ctx:_ - ~workDoneToken:_ ~partialResultToken:_ - (_ : doc_state) : - [ `CompletionList of CompletionList.t - | `List of CompletionItem.t list ] option IO.t = - IO.return None + method on_req_completion ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~ctx:_ + ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state) + : [ `CompletionList of CompletionList.t + | `List of CompletionItem.t list + ] + option + IO.t = + IO.return None + (** Called when the user requests completion in the document *) - (** Called when the user wants to jump-to-definition *) - method on_req_definition ~notify_back:_ ~id:_ ~uri:_ ~pos:_ - ~workDoneToken:_ ~partialResultToken:_ - (_ : doc_state) : Locations.t option IO.t = - IO.return None + method on_req_definition ~notify_back:_ ~id:_ ~uri:_ ~pos:_ + ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state) + : Locations.t option IO.t = + IO.return None + (** Called when the user wants to jump-to-definition *) - (** List code lenses for the given document + method on_req_code_lens ~notify_back:_ ~id:_ ~uri:_ ~workDoneToken:_ + ~partialResultToken:_ (_ : doc_state) : CodeLens.t list IO.t = + IO.return [] + (** List code lenses for the given document @since 0.3 *) - method on_req_code_lens ~notify_back:_ ~id:_ ~uri:_ - ~workDoneToken:_ ~partialResultToken:_ - (_ : doc_state) : CodeLens.t list IO.t = - IO.return [] - (** Code lens resolution, must return a code lens with non null "command" + method on_req_code_lens_resolve ~notify_back:(_ : notify_back) ~id:_ + (cl : CodeLens.t) : CodeLens.t IO.t = + IO.return cl + (** Code lens resolution, must return a code lens with non null "command" @since 0.3 *) - method on_req_code_lens_resolve - ~notify_back:(_:notify_back) ~id:_ - (cl:CodeLens.t) : CodeLens.t IO.t = - IO.return cl - (** Code action. + method on_req_code_action ~notify_back:(_ : notify_back) ~id:_ + (_c : CodeActionParams.t) : CodeActionResult.t IO.t = + IO.return None + (** Code action. @since 0.3 *) - method on_req_code_action ~notify_back:(_:notify_back) ~id:_ - (_c:CodeActionParams.t) - : CodeActionResult.t IO.t = - IO.return None - (** Execute a command with given arguments. + method on_req_execute_command ~notify_back:_ ~id:_ ~workDoneToken:_ + (_c : string) (_args : Yojson.Safe.t list option) : Yojson.Safe.t IO.t + = + IO.return `Null + (** Execute a command with given arguments. @since 0.3 *) - method on_req_execute_command ~notify_back:_ ~id:_ ~workDoneToken:_ - (_c:string) (_args:Yojson.Safe.t list option) : Yojson.Safe.t IO.t = - IO.return `Null - (** List symbols in this document. + method on_req_symbol ~notify_back:_ ~id:_ ~uri:_ ~workDoneToken:_ + ~partialResultToken:_ () + : [ `DocumentSymbol of DocumentSymbol.t list + | `SymbolInformation of SymbolInformation.t list + ] + option + IO.t = + IO.return None + (** List symbols in this document. @since 0.3 *) - method on_req_symbol ~notify_back:_ ~id:_ ~uri:_ - ~workDoneToken:_ ~partialResultToken:_ - () : [ `DocumentSymbol of DocumentSymbol.t list - | `SymbolInformation of SymbolInformation.t list ] option IO.t = - IO.return None - method on_request - : type r. notify_back:_ -> id:Req_id.t -> r Lsp.Client_request.t -> r IO.t - = fun ~notify_back ~id (r:_ Lsp.Client_request.t) -> - Log.debug (fun k->k "handle request[id=%s] " (Req_id.to_string id)); + method on_request : type r. + notify_back:_ -> id:Req_id.t -> r Lsp.Client_request.t -> r IO.t = + fun ~notify_back ~id (r : _ Lsp.Client_request.t) -> + Log.debug (fun k -> + k "handle request[id=%s] " (Req_id.to_string id)); - begin match r with - | Lsp.Client_request.Shutdown -> - Log.info (fun k->k "shutdown"); - _quit <- true; IO.return () + match r with + | Lsp.Client_request.Shutdown -> + Log.info (fun k -> k "shutdown"); + _quit <- true; + IO.return () + | Lsp.Client_request.Initialize i -> + Log.debug (fun k -> k "req: initialize"); + let notify_back = new notify_back ~notify_back () in + self#on_req_initialize ~notify_back i + | Lsp.Client_request.TextDocumentHover + { textDocument; position; workDoneToken } -> + let uri = textDocument.uri in + Log.debug (fun k -> k "req: hover '%s'" (DocumentUri.to_path uri)); - | Lsp.Client_request.Initialize i -> - Log.debug (fun k->k "req: initialize"); - let notify_back = new notify_back ~notify_back () in - self#on_req_initialize ~notify_back i - - | Lsp.Client_request.TextDocumentHover { textDocument; position; workDoneToken } -> - let uri = textDocument.uri in - Log.debug (fun k->k "req: hover '%s'" (DocumentUri.to_path uri)); - - begin match Hashtbl.find_opt docs uri with + (match Hashtbl.find_opt docs uri with | None -> IO.return None | Some doc_st -> let notify_back = new notify_back ~uri ~notify_back () in - self#on_req_hover ~notify_back ~id ~uri ~pos:position ~workDoneToken doc_st - end - - | Lsp.Client_request.TextDocumentCompletion { - textDocument; position; context; workDoneToken; partialResultToken; - } -> - let uri = textDocument.uri in - Log.debug (fun k->k "req: complete '%s'" (DocumentUri.to_path uri)); - begin match Hashtbl.find_opt docs uri with + self#on_req_hover ~notify_back ~id ~uri ~pos:position + ~workDoneToken doc_st) + | Lsp.Client_request.TextDocumentCompletion + { + textDocument; + position; + context; + workDoneToken; + partialResultToken; + } -> + let uri = textDocument.uri in + Log.debug (fun k -> + k "req: complete '%s'" (DocumentUri.to_path uri)); + (match Hashtbl.find_opt docs uri with | None -> IO.return None | Some doc_st -> let notify_back = new notify_back ~uri ~notify_back () in - self#on_req_completion ~notify_back ~id ~uri - ~workDoneToken ~partialResultToken - ~pos:position ~ctx:context doc_st - end - | Lsp.Client_request.TextDocumentDefinition { - textDocument; position; workDoneToken; partialResultToken; - } -> - let uri = textDocument.uri in - Log.debug (fun k->k "req: definition '%s'" (DocumentUri.to_path uri)); - let notify_back = new notify_back ~uri ~notify_back () in + self#on_req_completion ~notify_back ~id ~uri ~workDoneToken + ~partialResultToken ~pos:position ~ctx:context doc_st) + | Lsp.Client_request.TextDocumentDefinition + { textDocument; position; workDoneToken; partialResultToken } -> + let uri = textDocument.uri in + Log.debug (fun k -> + k "req: definition '%s'" (DocumentUri.to_path uri)); + let notify_back = new notify_back ~uri ~notify_back () in - begin match Hashtbl.find_opt docs uri with + (match Hashtbl.find_opt docs uri with | None -> IO.return None | Some doc_st -> - self#on_req_definition ~notify_back ~id - ~workDoneToken ~partialResultToken - ~uri ~pos:position doc_st - end + self#on_req_definition ~notify_back ~id ~workDoneToken + ~partialResultToken ~uri ~pos:position doc_st) + | Lsp.Client_request.TextDocumentCodeLens + { textDocument; workDoneToken; partialResultToken } -> + let uri = textDocument.uri in + Log.debug (fun k -> + k "req: codelens '%s'" (DocumentUri.to_path uri)); + let notify_back = new notify_back ~uri ~notify_back () in - | Lsp.Client_request.TextDocumentCodeLens { - textDocument; workDoneToken; partialResultToken; - } -> - let uri = textDocument.uri in - Log.debug (fun k->k "req: codelens '%s'" (DocumentUri.to_path uri)); - let notify_back = new notify_back ~uri ~notify_back () in - - begin match Hashtbl.find_opt docs uri with + (match Hashtbl.find_opt docs uri with | None -> IO.return [] | Some doc_st -> - self#on_req_code_lens ~notify_back ~id ~uri - ~workDoneToken ~partialResultToken doc_st - end + self#on_req_code_lens ~notify_back ~id ~uri ~workDoneToken + ~partialResultToken doc_st) + | Lsp.Client_request.TextDocumentCodeLensResolve cl -> + Log.debug (fun k -> k "req: codelens resolve"); + let notify_back = new notify_back ~notify_back () in + self#on_req_code_lens_resolve ~notify_back ~id cl + | Lsp.Client_request.ExecuteCommand + { command; arguments; workDoneToken } -> + Log.debug (fun k -> k "req: execute command '%s'" command); + let notify_back = new notify_back ~notify_back () in + self#on_req_execute_command ~notify_back ~id ~workDoneToken command + arguments + | Lsp.Client_request.DocumentSymbol + { textDocument = d; workDoneToken; partialResultToken } -> + let notify_back = new notify_back ~notify_back () in + self#on_req_symbol ~notify_back ~id ~uri:d.uri ~workDoneToken + ~partialResultToken () + | Lsp.Client_request.CodeAction a -> + let notify_back = new notify_back ~notify_back () in + self#on_req_code_action ~notify_back ~id a + | Lsp.Client_request.CodeActionResolve _ + | Lsp.Client_request.LinkedEditingRange _ + | Lsp.Client_request.TextDocumentDeclaration _ + | Lsp.Client_request.TextDocumentTypeDefinition _ + | Lsp.Client_request.TextDocumentPrepareRename _ + | Lsp.Client_request.TextDocumentRename _ + | Lsp.Client_request.TextDocumentLink _ + | Lsp.Client_request.TextDocumentLinkResolve _ + | 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.CompletionItemResolve _ + | Lsp.Client_request.WillSaveWaitUntilTextDocument _ + | Lsp.Client_request.TextDocumentFormatting _ + | Lsp.Client_request.TextDocumentMoniker _ + | Lsp.Client_request.TextDocumentOnTypeFormatting _ + | Lsp.Client_request.TextDocumentColorPresentation _ + | Lsp.Client_request.TextDocumentColor _ + | Lsp.Client_request.SelectionRange _ + | Lsp.Client_request.SemanticTokensDelta _ + | Lsp.Client_request.SemanticTokensFull _ + | Lsp.Client_request.SemanticTokensRange _ + | Lsp.Client_request.TextDocumentImplementation _ + | Lsp.Client_request.TextDocumentPrepareCallHierarchy _ + | Lsp.Client_request.TextDocumentRangeFormatting _ + | Lsp.Client_request.CallHierarchyIncomingCalls _ + | Lsp.Client_request.CallHierarchyOutgoingCalls _ + | Lsp.Client_request.WillCreateFiles _ + | Lsp.Client_request.WillDeleteFiles _ + | Lsp.Client_request.WillRenameFiles _ + | Lsp.Client_request.UnknownRequest _ -> + let notify_back = new notify_back ~notify_back () in + self#on_request_unhandled ~notify_back ~id r - | Lsp.Client_request.TextDocumentCodeLensResolve cl -> - Log.debug (fun k->k "req: codelens resolve"); - let notify_back = new notify_back ~notify_back () in - self#on_req_code_lens_resolve ~notify_back ~id cl + method virtual on_notif_doc_did_open + : notify_back:notify_back -> + TextDocumentItem.t -> + content:string -> + unit IO.t + (** Called when a document is opened *) - | Lsp.Client_request.ExecuteCommand { command; arguments; workDoneToken } -> - Log.debug (fun k->k "req: execute command '%s'" command); - let notify_back = new notify_back ~notify_back () in - self#on_req_execute_command ~notify_back ~id ~workDoneToken command arguments + method virtual on_notif_doc_did_close + : notify_back:notify_back -> TextDocumentIdentifier.t -> unit IO.t - | Lsp.Client_request.DocumentSymbol { textDocument=d; workDoneToken; partialResultToken } -> - let notify_back = new notify_back ~notify_back () in - self#on_req_symbol ~notify_back ~id ~uri:d.uri - ~workDoneToken ~partialResultToken () + 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 + (** Called when the document changes. *) - | Lsp.Client_request.CodeAction a -> - let notify_back = new notify_back ~notify_back () in - self#on_req_code_action ~notify_back ~id a - | Lsp.Client_request.CodeActionResolve _ - | Lsp.Client_request.LinkedEditingRange _ - | Lsp.Client_request.TextDocumentDeclaration _ - | Lsp.Client_request.TextDocumentTypeDefinition _ - | Lsp.Client_request.TextDocumentPrepareRename _ - | Lsp.Client_request.TextDocumentRename _ - | Lsp.Client_request.TextDocumentLink _ - | Lsp.Client_request.TextDocumentLinkResolve _ - | 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.CompletionItemResolve _ - | Lsp.Client_request.WillSaveWaitUntilTextDocument _ - | Lsp.Client_request.TextDocumentFormatting _ - | Lsp.Client_request.TextDocumentMoniker _ - | Lsp.Client_request.TextDocumentOnTypeFormatting _ - | Lsp.Client_request.TextDocumentColorPresentation _ - | Lsp.Client_request.TextDocumentColor _ - | Lsp.Client_request.SelectionRange _ - | Lsp.Client_request.SemanticTokensDelta _ - | Lsp.Client_request.SemanticTokensFull _ - | Lsp.Client_request.SemanticTokensRange _ - | Lsp.Client_request.TextDocumentImplementation _ - | Lsp.Client_request.TextDocumentPrepareCallHierarchy _ - | Lsp.Client_request.TextDocumentRangeFormatting _ - | Lsp.Client_request.CallHierarchyIncomingCalls _ - | Lsp.Client_request.CallHierarchyOutgoingCalls _ - | Lsp.Client_request.WillCreateFiles _ - | Lsp.Client_request.WillDeleteFiles _ - | Lsp.Client_request.WillRenameFiles _ - | Lsp.Client_request.UnknownRequest _ -> - let notify_back = new notify_back ~notify_back () in - self#on_request_unhandled ~notify_back ~id r - end + method on_notification_unhandled ~notify_back:_ + (_n : Lsp.Client_notification.t) : unit IO.t = + IO.return () + (** Override to handle unprocessed notifications *) - (** 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 + method on_notification ~notify_back (n : Lsp.Client_notification.t) + : unit IO.t = + let open Lsp.Types in + match n with | Lsp.Client_notification.TextDocumentDidOpen - {DidOpenTextDocumentParams.textDocument=doc} -> - Log.debug (fun k->k "notif: did open '%s'" (DocumentUri.to_path doc.uri)); + { DidOpenTextDocumentParams.textDocument = doc } -> + Log.debug (fun k -> + k "notif: did open '%s'" (DocumentUri.to_path doc.uri)); 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 + 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} -> - Log.debug (fun k->k "notif: did close '%s'" (DocumentUri.to_path doc.uri)); + | Lsp.Client_notification.TextDocumentDidClose { textDocument = doc } -> + Log.debug (fun k -> + k "notif: did close '%s'" (DocumentUri.to_path doc.uri)); 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} -> - Log.debug (fun k->k "notif: did change '%s'" (DocumentUri.to_path doc.uri)); + | Lsp.Client_notification.TextDocumentDidChange + { textDocument = doc; contentChanges = c } -> + Log.debug (fun k -> + k "notif: did change '%s'" (DocumentUri.to_path doc.uri)); let notify_back = new notify_back ~uri:doc.uri ~notify_back () in let old_doc = match Hashtbl.find_opt docs doc.uri with | None -> (* WTF vscode. Well let's try and deal with it. *) - Log.err (fun k->k "unknown document: '%s'" (DocumentUri.to_path doc.uri)); - let version = doc.version in + Log.err (fun k -> + k "unknown document: '%s'" (DocumentUri.to_path doc.uri)); + let version = doc.version in - let languageId = "" in (* FIXME*) + let languageId = "" in + (* FIXME*) Lsp.Text_document.make (DidOpenTextDocumentParams.create - ~textDocument:( - TextDocumentItem.create ~languageId - ~uri:doc.uri ~version ~text:"")) + ~textDocument: + (TextDocumentItem.create ~languageId ~uri:doc.uri ~version + ~text:"")) | Some st -> - Lsp.Text_document.make - (DidOpenTextDocumentParams.create - ~textDocument:( - TextDocumentItem.create ~languageId:st.languageId - ~uri:doc.uri ~version:st.version ~text:st.content)) + Lsp.Text_document.make + (DidOpenTextDocumentParams.create + ~textDocument: + (TextDocumentItem.create ~languageId:st.languageId + ~uri:doc.uri ~version:st.version ~text:st.content)) in - let new_doc: Lsp.Text_document.t = + let new_doc : Lsp.Text_document.t = List.fold_left (fun d ev -> Lsp.Text_document.apply_content_change d ev) old_doc c in - let new_st : doc_state = { - uri=doc.uri; languageId=Lsp.Text_document.languageId new_doc; - content=Lsp.Text_document.text new_doc; - version=Lsp.Text_document.version new_doc; - } in + let new_st : doc_state = + { + uri = doc.uri; + languageId = Lsp.Text_document.languageId new_doc; + 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:(Lsp.Text_document.text old_doc) ~new_content:new_st.content - - | Lsp.Client_notification.Exit -> _quit <- true; IO.return () + | Lsp.Client_notification.Exit -> + _quit <- true; + IO.return () | Lsp.Client_notification.DidSaveTextDocument _ | Lsp.Client_notification.WillSaveTextDocument _ | Lsp.Client_notification.ChangeWorkspaceFolders _ @@ -447,10 +472,8 @@ module Make(IO : IO) = struct | Lsp.Client_notification.DidCreateFiles _ | Lsp.Client_notification.DidDeleteFiles _ | Lsp.Client_notification.DidRenameFiles _ - | Lsp.Client_notification.LogTrace _ - -> + | Lsp.Client_notification.LogTrace _ -> let notify_back = new notify_back ~notify_back () in self#on_notification_unhandled ~notify_back n - end - end + end end diff --git a/src/sigs.ml b/src/sigs.ml index 47db2bf7..c4fe0a34 100644 --- a/src/sigs.ml +++ b/src/sigs.ml @@ -1,25 +1,20 @@ - - (** {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 + 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