Eglot: use eglot-advertise-cancellation in more situations

The async requests frequently issued by ElDoc are a significant
source of request pile-up on the server side (for some servers).

With this change, Eglot will issue additional LSP
$/cancelRequest notifications for in-flight requests of certain
kinds in the pre-command hook.

This required a small change to the 'jsonrpc-async-request'
entrypoint.

This feature is experimental.

* lisp/jsonrpc.el (jsonrpc-async-request): No longer returns nil.

* lisp/progmodes/eglot.el (eglot--inflight-async-requests): New variable.
(eglot--cancel-inflight-async-requests): New function.
(eglot--async-request): New function.
(eglot--pre-command-hook): Call eglot--cancel-inflight-async-requests.
(eglot-signature-eldoc-function, eglot-hover-eldoc-function)
(eglot-highlight-eldoc-function, eglot-code-action-suggestion):
Use eglot--async-request.

2 files changed, 69 insertions, 12 deletions

diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
index be9f4917e80..c5a099af8ec 100644
--- a/lisp/jsonrpc.el
+++ b/lisp/jsonrpc.el
@@ -377,9 +377,9 @@ never be sent at all, in case it is overridden in the meantime by
 a new request with identical DEFERRED and for the same buffer.
 However, in that situation, the original timeout is kept.
 
-Returns nil."
-  (apply #'jsonrpc--async-request-1 connection method params args)
-  nil)
+Returns a list whose first element is an integer identifying the request
+as specified in the JSONRPC 2.0 spec."
+  (apply #'jsonrpc--async-request-1 connection method params args))
 
 (cl-defun jsonrpc-request (connection
                            method params &key
diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el
index df93f899069..f0891e700a8 100644
--- a/lisp/progmodes/eglot.el
+++ b/lisp/progmodes/eglot.el
@@ -1832,6 +1832,62 @@ Unless IMMEDIATE, send pending changes before making request."
                          (cancel-on-input))
                    :cancel-on-input-retval cancel-on-input-retval))
 
+(defvar-local eglot--inflight-async-requests nil
+  "An plist of symbols to lists of JSONRPC ids.
+The ids designate in-flight asynchronous requests that may be cancelled
+according to `eglot-advertise-cancellation'.")
+
+(cl-defun eglot--cancel-inflight-async-requests
+    (&optional (hints '(:textDocument/signatureHelp
+                        :textDocument/hover
+                        :textDocument/documentHighlight
+                        :textDocument/codeAction)))
+  (when-let* ((server (and hints
+                           eglot-advertise-cancellation
+                           (eglot-current-server))))
+    (dolist (hint hints)
+      (dolist (id (plist-get eglot--inflight-async-requests hint))
+        ;; FIXME: in theory, as `jsonrpc-async-request' explains, this
+        ;; request may never have been sent at all.  But that's rare, and
+        ;; it's only a problem if the server borks on cancellation of
+        ;; never-sent requests.
+        (jsonrpc-notify server '$/cancelRequest `(:id ,id)))
+      (cl-remf eglot--inflight-async-requests hint))))
+
+(cl-defun eglot--async-request (server
+                                method
+                                params
+                                &key
+                                (success-fn nil success-fn-supplied-p)
+                                (error-fn nil error-fn-supplied-p)
+                                (timeout-fn nil timeout-fn-supplied-p)
+                                (timeout nil timeout-supplied-p)
+                                hint
+                                &aux moreargs)
+  "Like `jsonrpc-async-request', but for Eglot LSP requests.
+HINT argument is a symbol passed as DEFERRED to `jsonrpc-async-request'
+and also used as a hint of the request cancellation mechanism (see
+`eglot-advertise-cancellation')."
+  (cl-labels ((clearing-fn (fn)
+                (lambda (&rest args)
+                  (when fn (apply fn args))
+                  (cl-remf eglot--inflight-async-requests hint))))
+    (eglot--cancel-inflight-async-requests (list hint))
+    (when timeout-supplied-p
+      (setq moreargs (nconc `(:timeout ,timeout) moreargs)))
+    (when hint
+      (setq moreargs (nconc `(:deferred ,hint) moreargs)))
+    (let ((id
+           (car (apply #'jsonrpc-async-request
+                       server method params
+                       :success-fn (clearing-fn success-fn)
+                       :error-fn (clearing-fn error-fn)
+                       :timeout-fn (clearing-fn timeout-fn)
+                       moreargs))))
+      (when (and hint eglot-advertise-cancellation)
+        (push id
+              (plist-get eglot--inflight-async-requests hint))))))
+
 
 ;;; Encoding fever
 ;;;
@@ -2799,8 +2855,9 @@ buffer."
   "Cache of `workspace/Symbol' results  used by `xref-find-definitions'.")
 
 (defun eglot--pre-command-hook ()
-  "Reset some temporary variables."
+  "Reset some state."
   (clrhash eglot--workspace-symbols-cache)
+  (eglot--cancel-inflight-async-requests)
   (setq eglot--last-inserted-char nil))
 
 (defun eglot--CompletionParams ()
@@ -3644,7 +3701,7 @@ for which LSP on-type-formatting should be requested."
   "A member of `eldoc-documentation-functions', for signatures."
   (when (eglot-server-capable :signatureHelpProvider)
     (let ((buf (current-buffer)))
-      (jsonrpc-async-request
+      (eglot--async-request
        (eglot--current-server-or-lose)
        :textDocument/signatureHelp (eglot--TextDocumentPositionParams)
        :success-fn
@@ -3661,14 +3718,14 @@ for which LSP on-type-formatting should be requested."
                                                  nil))
                               signatures "\n")
                 :echo (eglot--sig-info active-sig activeParameter t))))))
-       :deferred :textDocument/signatureHelp))
+       :hint :textDocument/signatureHelp))
     t))
 
 (defun eglot-hover-eldoc-function (cb &rest _ignored)
   "A member of `eldoc-documentation-functions', for hover."
   (when (eglot-server-capable :hoverProvider)
     (let ((buf (current-buffer)))
-      (jsonrpc-async-request
+      (eglot--async-request
        (eglot--current-server-or-lose)
        :textDocument/hover (eglot--TextDocumentPositionParams)
        :success-fn (eglot--lambda ((Hover) contents range)
@@ -3677,7 +3734,7 @@ for which LSP on-type-formatting should be requested."
                                      (eglot--hover-info contents range))))
                          (funcall cb info
                                   :echo (and info (string-match "\n" info))))))
-       :deferred :textDocument/hover))
+       :hint :textDocument/hover))
     t))
 
 (defun eglot-highlight-eldoc-function (_cb &rest _ignored)
@@ -3687,7 +3744,7 @@ for which LSP on-type-formatting should be requested."
   ;; ignore cb and return nil to say "no doc".
   (when (eglot-server-capable :documentHighlightProvider)
     (let ((buf (current-buffer)))
-      (jsonrpc-async-request
+      (eglot--async-request
        (eglot--current-server-or-lose)
        :textDocument/documentHighlight (eglot--TextDocumentPositionParams)
        :success-fn
@@ -3705,7 +3762,7 @@ for which LSP on-type-formatting should be requested."
                                      `(,(lambda (o &rest _) (delete-overlay o))))
                         ov)))
                   highlights))))
-       :deferred :textDocument/documentHighlight)
+       :hint :textDocument/documentHighlight)
       nil)))
 
 (defun eglot--imenu-SymbolInformation (res)
@@ -4031,7 +4088,7 @@ at point.  With prefix argument, prompt for ACTION-KIND."
           (bounds (eglot--code-action-bounds))
           (use-text-p (memq 'eldoc-hint eglot-code-action-indications))
           tooltip blurb)
-      (jsonrpc-async-request
+      (eglot--async-request
        (eglot--current-server-or-lose)
        :textDocument/codeAction
        (eglot--code-action-params :beg (car bounds) :end (cadr bounds)
@@ -4071,7 +4128,7 @@ at point.  With prefix argument, prompt for ACTION-KIND."
                                        ,tooltip)))))
                  (setq eglot--suggestion-overlay ov)))))
          (when use-text-p (funcall cb blurb)))
-       :deferred :textDocument/codeAction)
+       :hint :textDocument/codeAction)
       (and use-text-p t))))