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

autoformat

Browse source
This commit is contained in:
Simon Cruanes 2023-03-10 23:12:41 -05:00
parent 341b9919dc
commit e9cc94dc14
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
12 changed files with 409 additions and 411 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
example/template/dune
View file

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

20
example/template/main.ml
View file

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

31
src/blocking_IO.ml
View file

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

5
src/blocking_IO.mli
View file

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

9
src/dune
View file

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

19
src/jsonrpc2.mli
View file

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

3
src/linol.ml
View file

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

1
src/log.ml
View file

@ -1,2 +1 @@
include (val Logs.src_log (Logs.Src.create ~doc:"linol (LSP library)" "linol"))

9
src/lwt/dune
View file

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

40
src/lwt/linol_lwt.ml
View file

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

647
src/server.ml
View file

@ -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] <opaque>" (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] <opaque>" (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

11
src/sigs.ml
View file

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