[elpa] externals/eglot d371f05 49/69: Request dispatcher's return value determines response

[João Távora]

branch: externals/eglot
commit d371f058e2b0634f2593d372f45253ec9c9bf700
Author: João Távora <address@hidden>
Commit: João Távora <address@hidden>

    Request dispatcher's return value determines response
    
    No more jsonrpc-reply.
    
    * eglot.el (eglot-handle-request window/showMessageRequest):
    Simplify.
    (eglot--register-unregister): Simplify.
    (eglot-handle-request workspace/applyEdit): Simplify.
    (eglot--apply-text-edits): Signal a jsonrpc-error.
    (eglot--apply-workspace-edit): Simplify.
    
    * jsonrpc-tests.el (jsonrpc--with-emacsrpc-fixture): Don't
    jsonrpc--reply.
    
    * jsonrpc.el (jsonrpc-error, jsonrpc-connection, jsonrpc-request):
    Improve docstring.
    (jsonrpc-error): Polymorphic args.
    (jsonrpc--unanswered-request-id): Remove.
    (jsonrpc--connection-receive): Rework and simplify.
    (jsonrpc-reply): Simplify.
---
 eglot.el         |  87 +++++++++++++++++----------------------
 jsonrpc-tests.el |   5 +--
 jsonrpc.el       | 122 ++++++++++++++++++++++++++++++-------------------------
 3 files changed, 107 insertions(+), 107 deletions(-)

diff --git a/eglot.el b/eglot.el
index 60a0322..13413ab 100644
--- a/eglot.el
+++ b/eglot.el
@@ -707,24 +707,18 @@ Uses THING, FACE, DEFS and PREPEND."
                   type message))
 
 (cl-defmethod eglot-handle-request
-  (server (_method (eql window/showMessageRequest)) &key type message actions)
+  (_server (_method (eql window/showMessageRequest)) &key type message actions)
   "Handle server request window/showMessageRequest"
-  (let (reply)
-    (unwind-protect
-        (setq reply
-              (completing-read
-               (concat
-                (format (propertize "[eglot] Server reports (type=%s): %s"
-                                    'face (if (<= type 1) 'error))
-                        type message)
-                "\nChoose an option: ")
-               (or (mapcar (lambda (obj) (plist-get obj :title)) actions)
-                   '("OK"))
-               nil t (plist-get (elt actions 0) :title)))
-      (if reply
-          (jsonrpc-reply server :result `(:title ,reply))
-        (jsonrpc-reply server
-                       :error `(:code -32800 :message "User cancelled"))))))
+  (or (completing-read
+       (concat
+        (format (propertize "[eglot] Server reports (type=%s): %s"
+                            'face (if (<= type 1) 'error))
+                type message)
+        "\nChoose an option: ")
+       (or (mapcar (lambda (obj) (plist-get obj :title)) actions)
+           '("OK"))
+       nil t (plist-get (elt actions 0) :title))
+      (jsonrpc-error :code -32800 :message "User cancelled")))
 
 (cl-defmethod eglot-handle-notification
   (_server (_method (eql window/logMessage)) &key _type _message)
@@ -762,18 +756,13 @@ Uses THING, FACE, DEFS and PREPEND."
 (cl-defun eglot--register-unregister (server things how)
   "Helper for `registerCapability'.
 THINGS are either registrations or unregisterations."
-  (dolist (thing (cl-coerce things 'list))
-    (cl-destructuring-bind (&key id method registerOptions) thing
-      (let (retval)
-        (unwind-protect
-            (setq retval (apply (intern (format "eglot--%s-%s" how method))
-                                server :id id registerOptions))
-          (unless (eq t (car retval))
-            (cl-return-from eglot--register-unregister
-              (jsonrpc-reply
-               server
-               :error `(:code -32601 :message ,(or (cadr retval) 
"sorry")))))))))
-  (jsonrpc-reply server :result `(:message "OK")))
+  (cl-loop
+   for thing in (cl-coerce things 'list)
+   collect (cl-destructuring-bind (&key id method registerOptions) thing
+             (apply (intern (format "eglot--%s-%s" how method))
+                    server :id id registerOptions))
+   into results
+   finally return `(:ok ,@results)))
 
 (cl-defmethod eglot-handle-request
   (server (_method (eql client/registerCapability)) &key registrations)
@@ -787,14 +776,9 @@ THINGS are either registrations or unregisterations."
   (eglot--register-unregister server unregisterations 'unregister))
 
 (cl-defmethod eglot-handle-request
-  (server (_method (eql workspace/applyEdit)) &key _label edit)
+  (_server (_method (eql workspace/applyEdit)) &key _label edit)
   "Handle server request workspace/applyEdit"
-  (condition-case err
-      (progn (eglot--apply-workspace-edit edit 'confirm)
-             (jsonrpc-reply server :result `(:applied )))
-    (error (jsonrpc-reply server
-                          :result `(:applied :json-false)
-                          :error `(:code -32001 :message (format "%s" 
,err))))))
+  (eglot--apply-workspace-edit edit 'confirm))
 
 (defun eglot--TextDocumentIdentifier ()
   "Compute TextDocumentIdentifier object for current buffer."
@@ -1206,8 +1190,8 @@ If SKIP-SIGNATURE, don't try to send 
textDocument/signatureHelp."
 (defun eglot--apply-text-edits (edits &optional version)
   "Apply EDITS for current buffer if at VERSION, or if it's nil."
   (unless (or (not version) (equal version eglot--versioned-identifier))
-    (eglot--error "Edits on `%s' require version %d, you have %d"
-                  (current-buffer) version eglot--versioned-identifier))
+    (jsonrpc-error "Edits on `%s' require version %d, we have %d"
+                   (current-buffer) version eglot--versioned-identifier))
   (eglot--widening
    (mapc (pcase-lambda (`(,newText ,beg . ,end))
            (goto-char beg) (delete-region beg end) (insert newText))
@@ -1223,7 +1207,8 @@ If SKIP-SIGNATURE, don't try to send 
textDocument/signatureHelp."
            (mapcar (jsonrpc-lambda (&key textDocument edits)
                      (cl-destructuring-bind (&key uri version) textDocument
                        (list (eglot--uri-to-path uri) edits version)))
-                   documentChanges)))
+                   documentChanges))
+          edit)
       (cl-loop for (uri edits) on changes by #'cddr
                do (push (list (eglot--uri-to-path uri) edits) prepared))
       (if (or confirm
@@ -1233,16 +1218,17 @@ If SKIP-SIGNATURE, don't try to send 
textDocument/signatureHelp."
                    (format "[eglot] Server wants to edit:\n  %s\n Proceed? "
                            (mapconcat #'identity (mapcar #'car prepared) "\n  
")))
             (eglot--error "User cancelled server edit")))
+      (while (setq edit (car prepared))
+        (cl-destructuring-bind (path edits &optional version) edit
+          (with-current-buffer (find-file-noselect path)
+            (eglot--apply-text-edits edits version))
+          (pop prepared))
+        t)
       (unwind-protect
-          (let (edit) (while (setq edit (car prepared))
-                        (cl-destructuring-bind (path edits &optional version) 
edit
-                          (with-current-buffer (find-file-noselect path)
-                            (eglot--apply-text-edits edits version))
-                          (pop prepared))))
-        (if prepared (eglot--warn "Caution: edits of files %s failed."
-                                  (mapcar #'car prepared))
-          (eglot-eldoc-function)
-          (eglot--message "Edit successful!"))))))
+          (if prepared (eglot--warn "Caution: edits of files %s failed."
+                                    (mapcar #'car prepared))
+            (eglot-eldoc-function)
+            (eglot--message "Edit successful!"))))))
 
 (defun eglot-rename (newname)
   "Rename the current symbol to NEWNAME."
@@ -1345,7 +1331,10 @@ If SKIP-SIGNATURE, don't try to send 
textDocument/signatureHelp."
           (progn (dolist (dir (delete-dups (mapcar #'file-name-directory 
globs)))
                    (push (file-notify-add-watch dir '(change) #'handle-event)
                          (gethash id (eglot--file-watches server))))
-                 (setq success `(t "OK")))
+                 (setq
+                  success
+                  `(:message ,(format "OK, watching %s watchers"
+                                      (length watchers)))))
         (unless success
           (eglot--unregister-workspace/didChangeWatchedFiles server :id 
id))))))
 
diff --git a/jsonrpc-tests.el b/jsonrpc-tests.el
index 9370d09..c2534e5 100644
--- a/jsonrpc-tests.el
+++ b/jsonrpc-tests.el
@@ -51,15 +51,14 @@
                             :name (process-name client)
                             :process client
                             :request-dispatcher
-                            (lambda (endpoint method params)
+                            (lambda (_endpoint method params)
                               (unless (memq method '(+ - * / vconcat append
                                                        sit-for ignore))
                                 (signal 'jsonrpc-error
                                         `((jsonrpc-error-message
                                            . "Sorry, this isn't allowed")
                                           (jsonrpc-error-code . -32601))))
-                              (let ((result (apply method (append params 
nil))))
-                                (jsonrpc-reply endpoint :result result)))
+                              (apply method (append params nil)))
                             :on-shutdown
                             (lambda (conn)
                               (setf (jsonrpc--shutdown-complete-p conn) 
t)))))))
diff --git a/jsonrpc.el b/jsonrpc.el
index d0c6066..36f45ef 100644
--- a/jsonrpc.el
+++ b/jsonrpc.el
@@ -61,7 +61,10 @@
 ;;
 ;; For handling remotely initiated contacts, `jsonrpc-connection'
 ;; objects hold dispatcher functions that the application should pass
-;; to object's constructor if it is interested in those messages.
+;; to object's constructor if it is interested in those messages.  The
+;; request dispatcher's return value determines the success response
+;; to forward to the server.  Alternatively, if the function signals
+;; an error, a suitable error response is forwarded instead.
 ;;
 ;; The JSON objects are passed to the dispatcher after being read by
 ;; `jsonrpc--json-read', which may use either the longstanding json.el
@@ -110,13 +113,30 @@
 
 (define-error 'jsonrpc-error "jsonrpc-error")
 
-(defun jsonrpc-error (format &rest args)
+(defun jsonrpc-error (&rest args)
   "Error out with FORMAT and ARGS.
 If invoked inside a dispatcher function, this function is suitable
-for replying to the remote endpoint with a -32603 error code and
-FORMAT as the message."
-  (signal 'error
-          (list (apply #'format-message (concat "[jsonrpc] " format) args))))
+for replying to the remote endpoint with an error message.
+
+ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying
+with a -32603 error code and a message formed by formatting
+FORMAT-STRING with MOREARGS.
+
+Alternatively ARGS can be plist representing a JSONRPC error
+object, using the keywords `:code', `:message' and `:data'."
+  (if (stringp (car args))
+      (let ((msg
+             (apply #'format-message (car args) (cdr args))))
+        (signal 'jsonrpc-error
+                `(,msg
+                  (jsonrpc-error-code . ,32603)
+                  (jsonrpc-error-message . ,msg))))
+    (cl-destructuring-bind (&key code message data) args
+      (signal 'jsonrpc-error
+              `(,(format "[jsonrpc] error ")
+                (jsonrpc-error-code . ,code)
+                (jsonrpc-error-message . ,message)
+                (jsonrpc-error-data . ,data))))))
 
 (defun jsonrpc-message (format &rest args)
   "Message out with FORMAT with ARGS."
@@ -180,8 +200,8 @@ The following initargs are accepted:
 arguments (CONN METHOD PARAMS) for handling JSONRPC requests.
 CONN is a `jsonrpc-connection' object, method is a symbol, and
 PARAMS is a plist representing a JSON object.  The function is
-expected to call `jsonrpc-reply' or signal an error of type
-`jsonrpc-error'.
+expected to return a JSONRPC result, a plist of (:result
+RESULT) or signal an error of type `jsonrpc-error'.
 
 :NOTIFICATION-DISPATCHER (optional), a function of three
 arguments (CONN METHOD PARAMS) for handling JSONRPC
@@ -403,48 +423,46 @@ originated."
             (setq msg (propertize msg 'face 'error)))
           (insert-before-markers msg))))))
 
-(defvar jsonrpc--unanswered-request-id)
-
 (defun jsonrpc--connection-receive (connection message)
   "Connection MESSAGE from CONNECTION."
-  (cl-destructuring-bind
-      (&key method id error params result _jsonrpc)
+  (cl-destructuring-bind (&key method id error params result _jsonrpc)
       message
-    (pcase-let* ((continuations)
-                 (lisp-err)
-                 (jsonrpc--unanswered-request-id id))
+    (let (continuations)
       (jsonrpc-log-event connection message 'server)
       (when error (setf (jsonrpc-status connection) `(,error t)))
-      (cond (method
-             (let ((debug-on-error
-                    (and debug-on-error
-                         (not (ert-running-test)))))
-               (condition-case-unless-debug oops
-                   (funcall (if id
-                                (jsonrpc--request-dispatcher connection)
-                              (jsonrpc--notification-dispatcher connection))
-                            connection (intern method) params)
-                 (error
-                  (setq lisp-err oops))))
-             (unless (or (not jsonrpc--unanswered-request-id)
-                         (not lisp-err))
-               (jsonrpc-reply
-                connection
-                :error (jsonrpc-obj
-                        :code (or (alist-get 'jsonrpc-error-code (cdr 
lisp-err))
-                                  -32603)
-                        :message (or (alist-get 'jsonrpc-error-message
-                                                (cdr lisp-err))
-                                     "Internal error")))))
-            ((setq continuations
-                   (and id (gethash id (jsonrpc--request-continuations 
connection))))
-             (let ((timer (nth 2 continuations)))
-               (when timer (cancel-timer timer)))
-             (remhash id (jsonrpc--request-continuations connection))
-             (if error (funcall (nth 1 continuations) error)
-               (funcall (nth 0 continuations) result)))
-            (id
-             (jsonrpc-warn "No continuation for id %s" id)))
+      (cond
+       (;; A remote request
+        (and method id)
+        (let* ((debug-on-error (and debug-on-error (not (ert-running-test))))
+               (reply
+                (condition-case-unless-debug _ignore
+                    (condition-case oops
+                        `(:result ,(funcall (jsonrpc--request-dispatcher 
connection)
+                                            connection (intern method) params))
+                      (jsonrpc-error
+                       `(:error
+                         (:code
+                          ,(or (alist-get 'jsonrpc-error-code (cdr oops)) 
-32603)
+                          :message ,(or (alist-get 'jsonrpc-error-message
+                                                   (cdr oops))
+                                        "Internal error")))))
+                  (error
+                   `(:error (:code -32603 :message "Internal error"))))))
+          (apply #'jsonrpc--reply connection id reply)))
+       (;; A remote notification
+        method
+        (funcall (jsonrpc--notification-dispatcher connection)
+                 connection (intern method) params))
+       (;; A remote response
+        (setq continuations
+              (and id (gethash id (jsonrpc--request-continuations 
connection))))
+        (let ((timer (nth 2 continuations)))
+          (when timer (cancel-timer timer)))
+        (remhash id (jsonrpc--request-continuations connection))
+        (if error (funcall (nth 1 continuations) error)
+          (funcall (nth 0 continuations) result)))
+       (;; An abnormal situation
+        id (jsonrpc-warn "No continuation for id %s" id)))
       (jsonrpc--call-deferred connection))))
 
 (cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
@@ -630,7 +648,8 @@ Like `jsonrpc-async-request' for CONNECTION, METHOD and 
PARAMS, but
 synchronous, i.e. doesn't exit until anything
 interesting (success, error or timeout) happens.  Furthermore,
 only exit locally (and return the JSONRPC result object) if the
-request is successful, otherwise exit non-locally with an error.
+request is successful, otherwise exit non-locally with an error
+of type `jsonrpc-error'.
 
 DEFERRED is passed to `jsonrpc-async-request', which see."
   (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer
@@ -672,16 +691,9 @@ DEFERRED is passed to `jsonrpc-async-request', which see."
                            :method method
                            :params params))
 
-(cl-defun jsonrpc-reply (connection &key (result nil result-supplied-p) error)
+(cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p) 
error)
   "Reply to CONNECTION's request ID with RESULT or ERROR."
-  (unless (xor result-supplied-p error)
-    (jsonrpc-error "Can't pass both RESULT and ERROR!"))
-  (jsonrpc-connection-send
-   connection
-   :id jsonrpc--unanswered-request-id
-   :result result
-   :error error)
-  (setq jsonrpc--unanswered-request-id nil))
+  (jsonrpc-connection-send connection :id id :result result :error error))
 
 (provide 'jsonrpc)
 ;;; jsonrpc.el ends here