branch: externals/eglot
commit d371f058e2b0634f2593d372f45253ec9c9bf700
Author: João Távora <joaotav...@gmail.com>
Commit: João Távora <joaotav...@gmail.com>
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
