diff --git a/example/template-eio/main.ml b/example/template-eio/main.ml index 932e0cfa..c89697c8 100644 --- a/example/template-eio/main.ml +++ b/example/template-eio/main.ml @@ -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 diff --git a/example/template-lwt/main.ml b/example/template-lwt/main.ml index 42e0ea26..78083a1c 100644 --- a/example/template-lwt/main.ml +++ b/example/template-lwt/main.ml @@ -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 diff --git a/src/eio/linol_eio.ml b/src/eio/linol_eio.ml index a3cb606c..1aa8fd01 100644 --- a/src/eio/linol_eio.ml +++ b/src/eio/linol_eio.ml @@ -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 diff --git a/src/jsonrpc2.ml b/src/jsonrpc2.ml index 75237afd..33261c5b 100644 --- a/src/jsonrpc2.ml +++ b/src/jsonrpc2.ml @@ -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 diff --git a/src/jsonrpc2.mli b/src/jsonrpc2.mli index 2ed46b04..68efa11c 100644 --- a/src/jsonrpc2.mli +++ b/src/jsonrpc2.mli @@ -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 *) diff --git a/src/lwt/linol_lwt.ml b/src/lwt/linol_lwt.ml index 432527bf..60963389 100644 --- a/src/lwt/linol_lwt.ml +++ b/src/lwt/linol_lwt.ml @@ -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 diff --git a/src/server.ml b/src/server.ml index 97700568..f581ba32 100644 --- a/src/server.ml +++ b/src/server.ml @@ -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 _