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

Merge pull request #17 from c-cube/wip-lsp-1.14

Browse source 
move to lsp 1.14
This commit is contained in:
Simon Cruanes 2023-03-14 14:02:02 -04:00 • committed by GitHub
commit 1a300c0de9
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
16 changed files with 635 additions and 534 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
.ocamlformat Normal file
View file

@ -0,0 +1,15 @@
version = 0.24.1
profile=conventional
margin=80
if-then-else=k-r
parens-ite=true
parens-tuple=multi-line-only
sequence-style=terminator
type-decl=sparse
break-cases=toplevel
cases-exp-indent=2
field-space=tight-decl
leading-nested-match-parens=true
module-item-spacing=compact
quiet=true
ocaml-version=4.08.0

7
example/template/dune
View file

@ -2,13 +2,12 @@
(name main)
(libraries
; Deps on linol + LWT backend
linol linol-lwt
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
)
)
lsp))

16
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
@ -40,16 +40,15 @@ class lsp_server =
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)
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;
@ -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 ()

3
linol-lwt.opam
View file

@ -13,7 +13,8 @@ build: [
depends: [
"dune" { >= "2.0" }
"linol" { = version }
"jsonrpc" { >= "1.11" & < "1.12" }
"jsonrpc" { >= "1.14" & < "1.15" }
"lsp" { >= "1.14" & < "1.15" }
"lwt" { >= "5.1" & < "6.0" }
"base-unix"
"yojson" { >= "1.6" }

2
linol.opam
View file

@ -14,7 +14,7 @@ depends: [
"dune" { >= "2.0" }
"yojson" { >= "1.6" }
"logs"
"lsp" { >= "1.11" & < "1.12" }
"lsp" { >= "1.14" & < "1.15" }
"ocaml" { >= "4.12" }
"odoc" { with-doc }
]

21
src/blocking_IO.ml
View file

@ -1,4 +1,3 @@
type 'a t = 'a
type nonrec in_channel = in_channel
type nonrec out_channel = out_channel
@ -7,10 +6,8 @@ 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
@ -18,21 +15,16 @@ let default_spawn_ f =
let run () =
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 (
@ -43,6 +35,9 @@ let rec read ic buf i len =
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

1
src/dune
View file

@ -1,4 +1,3 @@
(library
(name linol)
(public_name linol)

143
src/jsonrpc2.ml
View file

@ -1,4 +1,3 @@
(** {1 Simple JSON-RPC2 implementation}
See {{: https://www.jsonrpc.org/specification} the spec} *)
@ -17,25 +16,17 @@ module type S = sig
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
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 Make (IO : IO) : S with module IO = IO = struct
module IO = IO
include Server.Make (IO)
open IO
@ -72,17 +63,14 @@ module Make(IO : IO)
}
let create ~ic ~oc server : t = { ic; oc; s = server }
let create_stdio server : t =
create ~ic:IO.stdin ~oc:IO.stdout 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
Log.debug (fun k -> k "jsonrpc2: send json: %s" json);
let full_s =
Printf.sprintf "Content-Length: %d\r\n\r\n%s"
(String.length json) json
Printf.sprintf "Content-Length: %d\r\n\r\n%s" (String.length json) json
in
IO.write_string self.oc full_s
@ -90,44 +78,47 @@ module Make(IO : IO)
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
let send_server_notif (self : t) (m : Jsonrpc.Notification.t) : unit IO.t =
let json = Jsonrpc.Notification.yojson_of_t m in
send_json_ self json
let try_ f =
IO.catch
(fun () -> let+ x = f() in Ok x)
(fun () ->
let+ x = f () in
Ok x)
(fun e -> IO.return (Error e))
(* read a full message *)
let read_msg (self:t) : (Jsonrpc.Message.either, exn) result IO.t =
let read_msg (self : t) : (Jsonrpc.Packet.t, exn) result IO.t =
let rec read_headers acc =
let*? line =
try_ @@ fun () -> IO.read_line self.ic
in
let*? line = try_ @@ fun () -> IO.read_line self.ic in
match String.trim line with
| "" -> IO.return (Ok acc) (* last separator *)
| line ->
begin match
(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))
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
IO.return
(Error (E (ErrorCode.ParseError, spf "invalid header: %S" line))))
in
let*? headers = read_headers [] in
Log.debug (fun k->k "jsonrpc2: read headers: [%s]"
(String.concat ";" @@
List.map (fun (a,b)->Printf.sprintf "(%S,%S)" a b) headers));
let ok = match List.assoc "content-type" headers with
Log.debug (fun k ->
k "jsonrpc2: read headers: [%s]"
(String.concat ";"
@@ List.map (fun (a, b) -> Printf.sprintf "(%S,%S)" a b) headers));
let ok =
match List.assoc "content-type" headers with
| "utf8" | "utf-8" -> true
| _ -> false
| exception Not_found -> true
@ -137,58 +128,55 @@ module Make(IO : IO)
| n ->
Log.debug (fun k -> k "jsonrpc2: read %d bytes..." n);
let buf = Bytes.make n '\000' in
let*? () =
try_ @@ fun () -> IO.read self.ic buf 0 n
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
Log.debug (fun k -> k "got json %s" (J.to_string j));
begin match Jsonrpc.Message.either_of_yojson j with
(match Jsonrpc.Packet.t_of_yojson j with
| m -> IO.return @@ Ok m
| exception _ ->
Log.err (fun k -> k "cannot decode json message");
IO.return (Error (E(ErrorCode.ParseError, "cannot decode json")))
end
IO.return (Error (E (ErrorCode.ParseError, "cannot decode json"))))
| exception _ ->
IO.return @@
Error (E(ErrorCode.ParseError, "missing content-length' header"))
) else (
IO.return @@
Error (E(ErrorCode.InvalidRequest, "content-type must be 'utf-8'"))
)
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 module M = Jsonrpc.Packet in
let protect ~id f =
IO.catch f
(fun e ->
let message = spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace()) in
IO.catch f (fun e ->
let message =
spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
in
Log.err (fun k -> k "error: %s" message);
let r = Jsonrpc.Response.error id
let r =
Jsonrpc.Response.error id
(Jsonrpc.Response.Error.make
~code:Jsonrpc.Response.Error.Code.InternalError
~message ())
~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
in
send_response self r)
in
match r.M.id with
| None ->
match r with
| M.Notification n ->
(* notification *)
begin match Lsp.Client_notification.of_jsonrpc {r with M.id=()} with
(match Lsp.Client_notification.of_jsonrpc n with
| Ok n ->
IO.catch
(fun () ->
(self.s)#on_notification n
~notify_back:(fun n ->
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.LogMessageParams.create ~type_:Lsp.Types.MessageType.Error
Lsp.Types.LogMessageParams.create
~type_:Lsp.Types.MessageType.Error
~message:(Printexc.to_string e)
in
let msg =
@ -196,50 +184,49 @@ module Make(IO : IO)
|> Lsp.Server_notification.to_jsonrpc
in
send_server_notif self msg)
| Error e ->
IO.failwith (spf "cannot decode notification: %s" e)
end
| Some id ->
| Error e -> IO.failwith (spf "cannot decode notification: %s" e))
| M.Request r ->
(* request, so we need to reply *)
let id = r.id in
IO.catch
(fun () ->
begin match Lsp.Client_request.of_jsonrpc {r with M.id} with
match Lsp.Client_request.of_jsonrpc r with
| Ok (Lsp.Client_request.E r) ->
protect ~id (fun () ->
let* reply = self.s#on_request r ~id
~notify_back:(fun n ->
let* reply =
self.s#on_request r ~id ~notify_back:(fun n ->
let msg = Lsp.Server_notification.to_jsonrpc n in
send_server_notif self msg)
in
let reply_json = Lsp.Client_request.yojson_of_result r reply 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)
send_response self response)
| Error e -> IO.failwith (spf "cannot decode request: %s" e))
(fun e ->
let message = spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace()) in
let message =
spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
in
Log.err (fun k -> k "error: %s" message);
let r =
Jsonrpc.Response.error id
(Jsonrpc.Response.Error.make
~code:Jsonrpc.Response.Error.Code.InternalError
~message ())
~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
in
send_response self r)
| _p -> IO.failwith "neither notification nor request"
in
let rec loop () =
if shutdown() then IO.return ()
else (
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

13
src/jsonrpc2.mli
View file

@ -1,5 +1,3 @@
type json = Yojson.Safe.t
module type IO = Sigs.IO
@ -12,22 +10,15 @@ module type S = sig
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
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

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

1
src/lwt/dune
View file

@ -1,4 +1,3 @@
(library
(name linol_lwt)
(public_name linol-lwt)

24
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
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
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
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,15 +27,12 @@ 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 ->
Lwt.async (fun () ->
Lwt.catch f (fun exn ->
Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
(Printexc.to_string exn);
Lwt.return ()))
@ -41,6 +40,7 @@ end
include Lsp.Types
include IO_lwt
type doc_state = Linol.Server.doc_state
module Jsonrpc2 = Linol.Jsonrpc2.Make (IO_lwt)

489
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}
@ -24,7 +23,6 @@ end
(** {2 Server interface for some IO substrate} *)
module Make (IO : IO) = struct
open Lsp.Types
module Position = Position
module Range = Range
module Diagnostic = Diagnostic
@ -32,13 +30,15 @@ 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) ->
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.
method virtual on_request
: 'a.
notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
id:Req_id.t ->
'a Lsp.Client_request.t ->
@ -48,72 +48,109 @@ module Make(IO : IO) = struct
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
(** 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
class notify_back ~notify_back ~workDoneToken ~partialResultToken:_ ?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)
(** 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"
| None ->
IO.failwith "notify_back: cannot publish diagnostics, no URI given"
| Some uri ->
let params = PublishDiagnosticsParams.create
~uri ?version ~diagnostics:l () in
let params =
PublishDiagnosticsParams.create ~uri ?version ~diagnostics:l ()
in
notify_back (Lsp.Server_notification.PublishDiagnostics params)
(** Send diagnostics for the current document *)
method telemetry json : unit IO.t =
notify_back @@ Lsp.Server_notification.TelemetryNotification json
method cancel_request (id : Jsonrpc.Id.t) : unit IO.t =
notify_back @@ CancelRequest id
method work_done_progress_begin (p : Lsp.Types.WorkDoneProgressBegin.t)
: unit IO.t =
match workDoneToken with
| Some token ->
notify_back
@@ WorkDoneProgress
{ value = Lsp.Server_notification.Progress.Begin p; token }
| None -> IO.return ()
method work_done_progress_report (p : Lsp.Types.WorkDoneProgressReport.t)
: unit IO.t =
match workDoneToken with
| Some token ->
notify_back
@@ WorkDoneProgress
{ value = Lsp.Server_notification.Progress.Report p; token }
| None -> IO.return ()
method work_done_progress_end (p : Lsp.Types.WorkDoneProgressEnd.t)
: unit IO.t =
match workDoneToken with
| Some token ->
notify_back
@@ WorkDoneProgress
{ value = Lsp.Server_notification.Progress.End p; token }
| None -> IO.return ()
method send_notification (n : Lsp.Server_notification.t) = notify_back n
(** 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;
}
(** 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)
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
try Some (Hashtbl.find docs uri) with Not_found -> None
(** Find current state of the given document, if present. *)
(** 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 ->
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:(_ : notify_back) ~id:_ _r ->
Log.debug (fun k -> k "req: unhandled request");
IO.failwith "TODO: handle this request"
(** Override to process other requests *)
(** Parameter for how to synchronize content with the editor *)
method config_sync_opts : TextDocumentSyncOptions.t =
TextDocumentSyncOptions.create
~change:TextDocumentSyncKind.Incremental ~openClose:true
TextDocumentSyncOptions.create ~change:TextDocumentSyncKind.Incremental
~openClose:true
~save:(`SaveOptions (SaveOptions.create ~includeText:false ()))
~willSave:false ()
(** Parameter for how to synchronize content with the editor *)
method config_completion : CompletionOptions.t option = None
(** Configuration for the completion API.
@ -122,39 +159,50 @@ module Make(IO : IO) = struct
method config_code_lens_options : CodeLensOptions.t option = None
(** @since 0.3 *)
method config_definition :
[`Bool of bool | `DefinitionOptions of DefinitionOptions.t ] option = None
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
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
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
method config_code_action_provider
: [ `CodeActionOptions of CodeActionOptions.t | `Bool of bool ] =
`Bool false
(** @since 0.3 *)
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 = []
(** List of commands available *)
method on_req_initialize ~notify_back:_
method on_req_initialize ~notify_back:(_ : 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 ())
~executeCommandProvider:
(ExecuteCommandOptions.create ~commands:self#config_list_commands
())
?completionProvider:self#config_completion
?definitionProvider:self#config_definition
?hoverProvider:self#config_hover
@ -164,145 +212,176 @@ module Make(IO : IO) = struct
in
IO.return @@ InitializeResult.create ~capabilities ()
method on_req_hover ~notify_back:(_ : 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 *)
method on_req_hover ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~workDoneToken:_
(_ : doc_state) : Hover.t option IO.t =
IO.return None
method on_req_completion ~notify_back:(_ : 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 *)
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_definition ~notify_back:(_ : 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 *)
method on_req_definition ~notify_back:_ ~id:_ ~uri:_ ~pos:_
~workDoneToken:_ ~partialResultToken:_
(_ : doc_state) : Locations.t option IO.t =
IO.return None
method on_req_code_lens ~notify_back:(_ : 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"
@since 0.3 *)
method on_req_code_lens_resolve
~notify_back:(_:notify_back) ~id:_
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_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
method on_req_execute_command ~notify_back:(_ : 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
method on_req_symbol ~notify_back:(_ : 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
match r with
| Lsp.Client_request.Shutdown ->
Log.info (fun k -> k "shutdown");
_quit <- true; IO.return ()
_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
let notify_back =
new notify_back
~partialResultToken:None ~workDoneToken:i.workDoneToken
~notify_back ()
in
self#on_req_initialize ~notify_back i
| Lsp.Client_request.TextDocumentHover { textDocument; position; workDoneToken } ->
| 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 notify_back =
new notify_back
~workDoneToken ~partialResultToken:None ~uri ~notify_back ()
in
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));
begin match Hashtbl.find_opt docs uri with
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 notify_back =
new notify_back
~partialResultToken ~workDoneToken ~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
Log.debug (fun k ->
k "req: definition '%s'" (DocumentUri.to_path uri));
let notify_back =
new notify_back
~workDoneToken ~partialResultToken ~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
| Lsp.Client_request.TextDocumentCodeLens {
textDocument; workDoneToken; partialResultToken;
} ->
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
Log.debug (fun k ->
k "req: codelens '%s'" (DocumentUri.to_path uri));
let notify_back =
new notify_back
~workDoneToken ~partialResultToken ~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
let notify_back =
new notify_back
~workDoneToken:None ~partialResultToken:None ~notify_back ()
in
self#on_req_code_lens_resolve ~notify_back ~id cl
| Lsp.Client_request.ExecuteCommand { command; arguments; workDoneToken } ->
| 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 ()
let notify_back =
new notify_back
~workDoneToken ~partialResultToken:None ~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 ~workDoneToken ~partialResultToken ~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
let notify_back =
new notify_back
~workDoneToken:a.workDoneToken
~partialResultToken:a.partialResultToken ~notify_back ()
in
self#on_req_code_action ~notify_back ~id a
| Lsp.Client_request.CodeActionResolve _
| Lsp.Client_request.LinkedEditingRange _
@ -330,81 +409,111 @@ module Make(IO : IO) = struct
| 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
let notify_back =
new notify_back
~workDoneToken:None ~partialResultToken:None ~notify_back ()
in
self#on_request_unhandled ~notify_back ~id r
end
(** Called when a document is opened *)
method virtual on_notif_doc_did_open :
notify_back:notify_back ->
method virtual on_notif_doc_did_open
: notify_back:notify_back ->
TextDocumentItem.t ->
content:string ->
unit IO.t
(** Called when a document is opened *)
method virtual on_notif_doc_did_close :
notify_back:notify_back ->
TextDocumentIdentifier.t ->
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 ->
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. *)
(** Override to handle unprocessed notifications *)
method on_notification_unhandled
~notify_back:_ (_n:Lsp.Client_notification.t) : unit IO.t =
method on_notification_unhandled ~notify_back:(_ : notify_back)
(_n : Lsp.Client_notification.t) : unit IO.t =
IO.return ()
(** Override to handle unprocessed notifications *)
method on_notification
~notify_back (n:Lsp.Client_notification.t) : unit IO.t =
method on_notification ~notify_back (n : Lsp.Client_notification.t)
: unit IO.t =
let open Lsp.Types in
begin match n with
match n with
| Lsp.Client_notification.TextDocumentDidOpen
{ DidOpenTextDocumentParams.textDocument = doc } ->
Log.debug (fun k->k "notif: did open '%s'" (DocumentUri.to_path doc.uri));
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;
new notify_back
~uri:doc.uri ~workDoneToken:None ~partialResultToken:None
~version:doc.version ~notify_back ()
in
let st =
{
uri = doc.uri;
version = doc.version;
content = doc.text;
languageId = doc.languageId;
} in
}
in
Hashtbl.replace docs doc.uri st;
self#on_notif_doc_did_open ~notify_back doc ~content:st.content
self#on_notif_doc_did_open
~notify_back:(notify_back : 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));
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));
let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
Log.debug (fun k ->
k "notif: did close '%s'" (DocumentUri.to_path doc.uri));
let notify_back =
new notify_back
~workDoneToken:None ~partialResultToken:None ~uri:doc.uri
~notify_back ()
in
self#on_notif_doc_did_close
~notify_back:(notify_back : 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));
let notify_back =
new notify_back
~workDoneToken:None ~partialResultToken:None ~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));
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
~textDocument:
(TextDocumentItem.create ~languageId:st.languageId
~uri:doc.uri ~version:st.version ~text:st.content))
in
@ -414,18 +523,24 @@ module Make(IO : IO) = struct
old_doc c
in
let new_st : doc_state = {
uri=doc.uri; languageId=Lsp.Text_document.languageId new_doc;
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
}
in
Hashtbl.replace docs doc.uri new_st;
self#on_notif_doc_did_change ~notify_back doc c
self#on_notif_doc_did_change
~notify_back:(notify_back : 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 _
@ -435,9 +550,17 @@ module Make(IO : IO) = struct
| Lsp.Client_notification.CancelRequest _
| Lsp.Client_notification.WorkDoneProgressCancel _
| Lsp.Client_notification.SetTrace _
->
let notify_back = new notify_back ~notify_back () in
self#on_notification_unhandled ~notify_back n
end
| Lsp.Client_notification.DidChangeWatchedFiles _
| Lsp.Client_notification.DidCreateFiles _
| Lsp.Client_notification.DidDeleteFiles _
| Lsp.Client_notification.DidRenameFiles _
| Lsp.Client_notification.LogTrace _ ->
let notify_back =
new notify_back
~workDoneToken:None ~partialResultToken:None ~notify_back ()
in
self#on_notification_unhandled
~notify_back:(notify_back : notify_back)
n
end
end

5
src/sigs.ml
View file

@ -1,12 +1,9 @@
(** {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
@ -16,10 +13,8 @@ module type IO = sig
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