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

I've gone too far, but it's too late to go back.

Browse source
This commit is contained in:
Christoph M. Wintersteiger 2024-07-30 21:01:05 +01:00
parent 845371e3a0
commit 7ccdfff203
No known key found for this signature in database
GPG key ID: 50B5FDA31455CFF3
7 changed files with 86 additions and 76 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
example/template-eio/main.ml
View file

@ -51,7 +51,7 @@ class lsp_server =
- return the diagnostics from the new state
*)
method private _on_doc ~(notify_back : Linol_eio.Jsonrpc2.notify_back)
(uri : Lsp.Types.DocumentUri.t) (contents : string) =
(uri : Lsp.Types.DocumentUri.t) (contents : string) : (unit, string) result =
let new_state = process_some_input_file contents in
Hashtbl.replace buffers uri new_state;
let diags = diagnostics new_state in
@ -59,7 +59,7 @@ class lsp_server =
(* We now override the [on_notify_doc_did_open] method that will be called
by the server each time a new document is opened. *)
method on_notif_doc_did_open ~notify_back d ~content : unit Linol_eio.t =
method on_notif_doc_did_open ~notify_back d ~content : (unit, string) result Linol_eio.t =
self#_on_doc ~notify_back d.uri content
(* Similarly, we also override the [on_notify_doc_did_change] method that will be called
@ -70,9 +70,9 @@ class lsp_server =
(* On document closes, we remove the state associated to the file from the global
hashtable state, to avoid leaking memory. *)
method on_notif_doc_did_close ~notify_back:_ d : unit Linol_eio.t =
method on_notif_doc_did_close ~notify_back:_ d : (unit, string) result Linol_eio.t =
Hashtbl.remove buffers d.uri;
()
Ok ()
end
(* Main code

6
example/template-lwt/main.ml
View file

@ -59,7 +59,7 @@ class lsp_server =
(* We now override the [on_notify_doc_did_open] method that will be called
by the server each time a new document is opened. *)
method on_notif_doc_did_open ~notify_back d ~content : unit Linol_lwt.t =
method on_notif_doc_did_open ~notify_back d ~content : (unit, string) result Linol_lwt.t =
self#_on_doc ~notify_back d.uri content
(* Similarly, we also override the [on_notify_doc_did_change] method that will be called
@ -70,9 +70,9 @@ class lsp_server =
(* On document closes, we remove the state associated to the file from the global
hashtable state, to avoid leaking memory. *)
method on_notif_doc_did_close ~notify_back:_ d : unit Linol_lwt.t =
method on_notif_doc_did_close ~notify_back:_ d : (unit, string) result Linol_lwt.t =
Hashtbl.remove buffers d.uri;
Linol_lwt.return ()
Linol_lwt.return (Ok ())
end
(* Main code

9
src/eio/linol_eio.ml
View file

@ -38,12 +38,13 @@ module IO_eio :
end
(** Spawn function. *)
let spawn f =
let spawn (f:unit -> (unit, string) result) : unit =
let promise, resolver = Eio.Promise.create () in
begin
try
f ();
Eio.Promise.resolve_ok resolver ()
match f () with
| Ok _ -> Eio.Promise.resolve_ok resolver ()
| Error _ -> ()
with
exn ->
(Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
@ -51,7 +52,7 @@ let spawn f =
Eio.Promise.resolve_error resolver exn
end;
Eio.Promise.await_exn promise
(Eio.Promise.await_exn promise)
include Lsp.Types
include IO_eio

41
src/jsonrpc2.ml
View file

@ -24,7 +24,7 @@ module type S = sig
val create_stdio :
?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> env:IO.env -> server -> t
val send_server_notification : t -> Lsp.Server_notification.t -> unit IO.t
val send_server_notification : t -> Lsp.Server_notification.t -> (unit, string) result IO.t
val send_server_request :
t ->
@ -56,6 +56,11 @@ module Make (IO : IO) : S with module IO = IO = struct
exception E of ErrorCode.t * string
let[@inline] lift_ok x =
let open IO in
let+ x = x in
Ok x
(* bind on IO+result *)
let ( let*? ) x f =
let* x = x in
@ -110,9 +115,9 @@ module Make (IO : IO) : S with module IO = IO = struct
[register_server_request_response_handler] before calling this method to
ensure that [handle_response] will have a registered handler for this
response. *)
let send_server_req (self : t) (m : Jsonrpc.Request.t) : unit IO.t =
let send_server_req (self : t) (m : Jsonrpc.Request.t) : (unit, string) result IO.t =
let json = Jsonrpc.Request.yojson_of_t m in
send_json_ self json
lift_ok @@ send_json_ self json
(** Returns a new, unused [Req_id.t] to send a server request. *)
let fresh_lsp_id (self : t) : Req_id.t =
@ -140,9 +145,9 @@ module Make (IO : IO) : S with module IO = IO = struct
(** Sends a server notification to the LSP client. *)
let send_server_notification (self : t) (n : Lsp.Server_notification.t) :
unit IO.t =
(unit, string) result IO.t =
let msg = Lsp.Server_notification.to_jsonrpc n in
send_server_notif self msg
lift_ok @@ (send_server_notif self msg)
(** Given a [server_request_handler_pair] consisting of some server request
and its handler, sends this request to the LSP client and adds the handler
@ -156,7 +161,7 @@ module Make (IO : IO) : S with module IO = IO = struct
let msg = Lsp.Server_request.to_jsonrpc_request r ~id in
let has_inserted = register_server_request_response_handler self id req in
if has_inserted then
let* () = send_server_req self msg in
let* _res = send_server_req self msg in
return id
else
IO.failwith "failed to register server request: id was already used"
@ -180,19 +185,19 @@ module Make (IO : IO) : S with module IO = IO = struct
in
send_server_notif self msg)
let handle_notification (self : t) (n : Jsonrpc.Notification.t) : unit IO.t =
let handle_notification (self : t) (n : Jsonrpc.Notification.t) : (unit, string) result IO.t =
let@ _sp =
Trace.with_span ~__FILE__ ~__LINE__ "linol.handle-notification"
in
match Lsp.Client_notification.of_jsonrpc n with
| Ok n ->
let@ () = with_error_handler self in
(* let@ () = with_error_handler self in *)
self.s#on_notification n
~notify_back:(send_server_notification self)
~server_request:(server_request self)
| Error e -> IO.failwith (spf "cannot decode notification: %s" e)
let handle_request (self : t) (r : Jsonrpc.Request.t) : unit IO.t =
let handle_request (self : t) (r : Jsonrpc.Request.t) : (unit, string) result IO.t =
let protect ~id f =
IO.catch f (fun e bt ->
let message =
@ -209,7 +214,7 @@ module Make (IO : IO) : S with module IO = IO = struct
in
(* request, so we need to reply *)
let id = r.id in
IO.catch
lift_ok @@ IO.catch
(fun () ->
match Lsp.Client_request.of_jsonrpc r with
| Ok (Lsp.Client_request.E r) ->
@ -245,7 +250,7 @@ module Make (IO : IO) : S with module IO = IO = struct
in
send_response self r)
let handle_response (self : t) (r : Jsonrpc.Response.t) : unit IO.t =
let handle_response (self : t) (r : Jsonrpc.Response.t) : (unit, string) result IO.t =
match Hashtbl.find_opt self.pending_responses r.id with
| None ->
IO.failwith
@ -253,23 +258,23 @@ module Make (IO : IO) : S with module IO = IO = struct
@@ Req_id.to_string r.id
| Some (Request_and_handler (req, handler)) ->
let () = Hashtbl.remove self.pending_responses r.id in
(match r.result with
lift_ok @@ (match r.result with
| Error err -> with_error_handler self (fun () -> handler @@ Error err)
| Ok json ->
let r = Lsp.Server_request.response_of_json req json in
with_error_handler self (fun () -> handler @@ Ok r))
let handle_batch_response (_self : t) (_rs : Jsonrpc.Response.t list) :
unit IO.t =
IO.failwith "Unhandled: jsonrpc batch response"
(unit, string) result IO.t =
lift_ok @@ IO.failwith "Unhandled: jsonrpc batch response"
let handle_batch_call (_self : t)
(_cs :
[ `Notification of Jsonrpc.Notification.t
| `Request of Jsonrpc.Request.t
]
list) : unit IO.t =
IO.failwith "Unhandled: jsonrpc batch call"
list) : (unit, string) result IO.t =
lift_ok @@ IO.failwith "Unhandled: jsonrpc batch call"
(* As in [https://github.com/c-cube/linol/issues/20],
Jsonrpc expect "params" to be object or array,
@ -367,7 +372,7 @@ module Make (IO : IO) : S with module IO = IO = struct
let run ?(shutdown = fun _ -> false) (self : t) : unit IO.t =
let async f =
self.s#spawn_query_handler f;
IO.return ()
IO.return (Ok ())
in
let process_msg r =
@ -389,7 +394,7 @@ module Make (IO : IO) : S with module IO = IO = struct
let* r = read_msg self in
match r with
| Ok r ->
let* () = process_msg r in
let* _res = process_msg r in
loop ()
| Error (e, bt) -> IO.fail e bt
in

2
src/jsonrpc2.mli
View file

@ -27,7 +27,7 @@ module type S = sig
?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> env:IO.env -> server -> t
(** Create a connection using stdin/stdout *)
val send_server_notification : t -> Lsp.Server_notification.t -> unit IO.t
val send_server_notification : t -> Lsp.Server_notification.t -> (unit, string) result IO.t
(** Send a notification from the server.
@since 0.5 *)

16
src/lwt/linol_lwt.ml
View file

@ -39,12 +39,16 @@ end
(** Spawn function.
@since 0.5 *)
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 ()))
let spawn (f: unit -> (unit, string) result Lwt.t) : unit =
let g = (fun () ->
let _ = Lwt.catch f (fun exn ->
Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
(Printexc.to_string exn);
Lwt.return (Error (Printexc.to_string exn)))
in
Lwt.return ())
in
Lwt.async g
include Lsp.Types
include IO_lwt

80
src/server.ml
View file

@ -32,6 +32,11 @@ module Make (IO : IO) = struct
module DiagnosticSeverity = DiagnosticSeverity
module Req_id = Req_id
let[@inline] lift_ok x =
let open IO in
let+ x = x in
Ok x
(** A variant carrying a [Lsp.Server_request.t] and a handler for its return
value. The request is stored in order to allow us to discriminate its
existential variable. *)
@ -49,14 +54,14 @@ module Make (IO : IO) = struct
class virtual base_server =
object
method virtual on_notification
: notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
: notify_back:(Lsp.Server_notification.t -> (unit, string) result IO.t) ->
server_request:send_request ->
Lsp.Client_notification.t ->
unit IO.t
(unit, string) result IO.t
method virtual on_request
: 'a.
notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
notify_back:(Lsp.Server_notification.t -> (unit, string) result IO.t) ->
server_request:send_request ->
id:Req_id.t ->
'a Lsp.Client_request.t ->
@ -69,30 +74,30 @@ module Make (IO : IO) = struct
method must_quit = false
(** Set to true if the client requested to exit *)
method virtual spawn_query_handler : (unit -> unit IO.t) -> unit
method virtual spawn_query_handler : (unit -> (unit, string) result IO.t) -> unit
(** How to start a new future/task/thread concurrently. This is used
to process incoming user queries.
@since 0.5 *)
end
let async (self : #base_server) f : unit IO.t =
let async (self : #base_server) f : (unit, string) result IO.t =
self#spawn_query_handler f;
IO.return ()
IO.return (Ok ())
(** A wrapper to more easily reply to notifications *)
class notify_back ~notify_back ~server_request ~workDoneToken
class notify_back ~(notify_back: Lsp.Server_notification.t -> (unit, string) result IO.t) ~server_request ~workDoneToken
~partialResultToken:_ ?version ?(uri : DocumentUri.t option) () =
object
val mutable uri = uri
method set_uri u = uri <- Some u
method get_uri = uri
method send_log_msg ~type_ msg : unit IO.t =
method send_log_msg ~type_ msg : (unit, string) result IO.t =
let params = LogMessageParams.create ~type_ ~message:msg in
notify_back (Lsp.Server_notification.LogMessage params)
(** Send a log message to the editor *)
method send_diagnostic (l : Diagnostic.t list) : unit IO.t =
method send_diagnostic (l : Diagnostic.t list) : (unit, string) result IO.t =
match uri with
| None ->
IO.failwith "notify_back: cannot publish diagnostics, no URI given"
@ -103,33 +108,33 @@ module Make (IO : IO) = struct
notify_back (Lsp.Server_notification.PublishDiagnostics params)
(** Send diagnostics for the current document *)
method telemetry json : unit IO.t =
method telemetry json : (unit, string) result IO.t =
notify_back @@ Lsp.Server_notification.TelemetryNotification json
method cancel_request (id : Jsonrpc.Id.t) : unit IO.t =
method cancel_request (id : Jsonrpc.Id.t) : (unit, string) result IO.t =
notify_back @@ CancelRequest id
method work_done_progress_begin (p : Lsp.Types.WorkDoneProgressBegin.t)
: unit IO.t =
: (unit, string) result IO.t =
match workDoneToken with
| Some token ->
notify_back @@ WorkDoneProgress { token; value = Begin p }
| None -> IO.return ()
| None -> lift_ok @@ IO.return ()
method work_done_progress_report (p : Lsp.Types.WorkDoneProgressReport.t)
: unit IO.t =
: (unit, string) result IO.t =
match workDoneToken with
| Some token ->
notify_back @@ WorkDoneProgress { value = Report p; token }
| None -> IO.return ()
| None -> lift_ok @@ IO.return ()
method work_done_progress_end (p : Lsp.Types.WorkDoneProgressEnd.t)
: unit IO.t =
: (unit, string) result IO.t =
match workDoneToken with
| Some token -> notify_back @@ WorkDoneProgress { value = End p; token }
| None -> IO.return ()
| None -> lift_ok @@ IO.return ()
method send_notification (n : Lsp.Server_notification.t) : unit IO.t =
method send_notification (n : Lsp.Server_notification.t) : (unit, string) result IO.t =
notify_back n
(** Send a notification from the server to the client (general purpose method) *)
@ -150,11 +155,6 @@ module Make (IO : IO) = struct
}
(** Current state of a document. *)
let[@inline] lift_ok x =
let open IO in
let+ x = x in
Ok x
(** 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
@ -338,7 +338,7 @@ module Make (IO : IO) = struct
@since 0.7 *)
method on_request : type r.
notify_back:_ ->
notify_back:(Lsp.Server_notification.t -> (unit, string) result IO.t) ->
server_request:_ ->
id:Req_id.t ->
r Lsp.Client_request.t ->
@ -553,11 +553,11 @@ module Make (IO : IO) = struct
: notify_back:notify_back ->
TextDocumentItem.t ->
content:string ->
unit IO.t
(unit, string) result IO.t
(** Called when a document is opened *)
method virtual on_notif_doc_did_close
: notify_back:notify_back -> TextDocumentIdentifier.t -> unit IO.t
: notify_back:notify_back -> TextDocumentIdentifier.t -> (unit, string) result IO.t
method virtual on_notif_doc_did_change
: notify_back:notify_back ->
@ -565,30 +565,30 @@ module Make (IO : IO) = struct
TextDocumentContentChangeEvent.t list ->
old_content:string ->
new_content:string ->
unit IO.t
(unit, string) result IO.t
(** Called when the document changes. *)
method on_notif_doc_did_save ~notify_back:(_ : notify_back)
(_params : DidSaveTextDocumentParams.t ) : unit IO.t =
IO.return ()
(_params : DidSaveTextDocumentParams.t ) : (unit, string) result IO.t =
lift_ok @@ IO.return ()
method on_unknown_notification ~notify_back:(_ : notify_back)
(_n : Jsonrpc.Notification.t) : unit IO.t =
IO.return ()
(_n : Jsonrpc.Notification.t) : (unit, string) result IO.t =
lift_ok @@ IO.return ()
method on_notification_unhandled ~notify_back:(_ : notify_back)
(_n : Lsp.Client_notification.t) : unit IO.t =
IO.return ()
(_n : Lsp.Client_notification.t) : (unit, string) result IO.t =
lift_ok @@ IO.return ()
(** Override to handle unprocessed notifications *)
method on_notification ~notify_back ~server_request
(n : Lsp.Client_notification.t) : unit IO.t =
method on_notification ~(notify_back:Lsp.Server_notification.t -> (unit, string) result IO.t) ~server_request
(n : Lsp.Client_notification.t) : (unit, string) result IO.t =
let@ _sp =
Trace.with_span ~__FILE__ ~__LINE__ "linol.on-notification"
in
(* handler to catch all errors *)
let try_catch : (unit -> unit IO.t) -> unit IO.t =
let try_catch : (unit -> (unit, string) result IO.t) -> (unit, string) result IO.t =
fun f ->
IO.catch f (fun exn bt ->
let msg =
@ -597,7 +597,7 @@ module Make (IO : IO) = struct
(Printexc.raw_backtrace_to_string bt)
in
Log.err (fun k -> k "%s" msg);
IO.return ())
lift_ok @@ IO.return ())
in
try_catch @@ fun () ->
@ -688,11 +688,11 @@ module Make (IO : IO) = struct
Hashtbl.replace docs doc.uri new_st;
async self (fun () ->
self#on_notif_doc_did_change
(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)
~new_content:new_st.content))
| Lsp.Client_notification.DidSaveTextDocument params ->
let notify_back =
new notify_back
@ -706,7 +706,7 @@ module Make (IO : IO) = struct
params)
| Lsp.Client_notification.Exit ->
status <- `ReceivedExit;
IO.return ()
lift_ok @@ IO.return ()
| Lsp.Client_notification.WillSaveTextDocument _
| Lsp.Client_notification.ChangeWorkspaceFolders _
| Lsp.Client_notification.ChangeConfiguration _