branch: externals/eglot
commit b3c8b59d4f5ed5470c28684f76431dd5c1882a47
Author: João Távora <joaotav...@gmail.com>
Commit: João Távora <joaotav...@gmail.com>
Refactor JSON-RPC lib jrpc.el from eglot.el
* eglot.el [too many to mention]: Move lower level functions to
jrpc.el. Hook onto jrpc's external interfaces.
* jrpc.el: New file
---
eglot.el | 836 +++++++++++++++++----------------------------------------------
jrpc.el | 502 ++++++++++++++++++++++++++++++++++++++
2 files changed, 727 insertions(+), 611 deletions(-)
diff --git a/eglot.el b/eglot.el
index 4cb3bec..934270c 100644
--- a/eglot.el
+++ b/eglot.el
@@ -40,6 +40,7 @@
(require 'flymake)
(require 'xref)
(require 'subr-x)
+(require 'jrpc)
;;; User tweakable stuff
@@ -58,12 +59,8 @@
'((t (:inherit font-lock-constant-face :weight bold)))
"Face for package-name in EGLOT's mode line.")
-(defcustom eglot-request-timeout 10
- "How many seconds to wait for a reply from the server."
- :type :integer)
-
(defcustom eglot-autoreconnect 3
- "Control EGLOT's ability to reconnect automatically.
+ "Control ability to reconnect automatically to the LSP server.
If t, always reconnect automatically (not recommended). If nil,
never reconnect automatically after unexpected server shutdowns,
crashes or network failures. A positive integer number says to
@@ -77,114 +74,63 @@ lasted more than that many seconds."
(defvar eglot--processes-by-project (make-hash-table :test #'equal)
"Keys are projects. Values are lists of processes.")
-(defun eglot--current-process ()
- "The current logical EGLOT process."
- (let* ((cur (project-current))
- (processes (and cur (gethash cur eglot--processes-by-project))))
- (cl-find major-mode processes :key #'eglot--major-mode)))
-
-(defun eglot--current-process-or-lose ()
- "Return the current EGLOT process or error."
- (or (eglot--current-process)
- (eglot--error "No current EGLOT process%s"
- (if (project-current) "" " (Also no current project)"))))
-
-(defmacro eglot--define-process-var
- (var-sym initval &optional doc)
- "Define VAR-SYM as a generalized process-local variable.
-INITVAL is the default value. DOC is the documentation."
- (declare (indent 2))
- `(progn
- (put ',var-sym 'function-documentation ,doc)
- (defun ,var-sym (proc)
- (let* ((plist (process-plist proc))
- (probe (plist-member plist ',var-sym)))
- (if probe
- (cadr probe)
- (let ((def ,initval))
- (process-put proc ',var-sym def)
- def))))
- (gv-define-setter ,var-sym (to-store process)
- `(let ((once ,to-store)) (process-put ,process ',',var-sym once)
once))))
-
-(eglot--define-process-var eglot--short-name nil
- "A short name for the process")
-
-(eglot--define-process-var eglot--major-mode nil
+(jrpc-define-process-var eglot--major-mode nil
"The major-mode this server is managing.")
-(eglot--define-process-var eglot--expected-bytes nil
- "How many bytes declared by server")
-
-(eglot--define-process-var eglot--pending-continuations (make-hash-table)
- "A hash table of request ID to continuation lambdas")
-
-(eglot--define-process-var eglot--events-buffer nil
- "A buffer pretty-printing the EGLOT RPC events")
-
-(eglot--define-process-var eglot--capabilities :unreported
+(jrpc-define-process-var eglot--capabilities :unreported
"Holds list of capabilities that server reported")
-(eglot--define-process-var eglot--moribund nil
- "Non-nil if server is about to exit")
-
-(eglot--define-process-var eglot--project nil
+(jrpc-define-process-var eglot--project nil
"The project the server belongs to.")
-(eglot--define-process-var eglot--spinner `(nil nil t)
+(jrpc-define-process-var eglot--spinner `(nil nil t)
"\"Spinner\" used by some servers.
A list (ID WHAT DONE-P).")
-(eglot--define-process-var eglot--status `(:unknown nil)
- "Status as declared by the server.
-A list (WHAT SERIOUS-P).")
+(jrpc-define-process-var eglot--moribund nil
+ "Non-nil if server is about to exit")
-(eglot--define-process-var eglot--inhibit-autoreconnect eglot-autoreconnect
+(jrpc-define-process-var eglot--inhibit-autoreconnect eglot-autoreconnect
"If non-nil, don't autoreconnect on unexpected quit.")
-(eglot--define-process-var eglot--contact nil
- "Method used to contact a server.
-Either a list of strings (a shell command and arguments), or a
-list of a single string of the form <host>:<port>")
-
-(eglot--define-process-var eglot--deferred-actions
- (make-hash-table :test #'equal)
- "Actions deferred to when server is thought to be ready.")
-
-(defun eglot--make-process (name managed-major-mode contact)
- "Make a process from CONTACT.
-NAME is a name to give the inferior process or connection.
-MANAGED-MAJOR-MODE is a symbol naming a major mode.
-CONTACT is as `eglot--contact'. Returns a process object."
- (let* ((readable-name (format "EGLOT server (%s/%s)" name
managed-major-mode))
- (buffer (get-buffer-create
- (format "*%s inferior*" readable-name)))
- singleton
- (proc
- (if (and (setq singleton (and (null (cdr contact)) (car contact)))
- (string-match "^[\s\t]*\\(.*\\):\\([[:digit:]]+\\)[\s\t]*$"
- singleton))
- (open-network-stream readable-name
- buffer
- (match-string 1 singleton)
- (string-to-number
- (match-string 2 singleton)))
- (make-process :name readable-name
- :buffer buffer
- :command contact
- :connection-type 'pipe
- :stderr (get-buffer-create (format "*%s stderr*"
- name))))))
- (set-process-filter proc #'eglot--process-filter)
- (set-process-sentinel proc #'eglot--process-sentinel)
- proc))
-
-(defmacro eglot--obj (&rest what)
- "Make WHAT a suitable argument for `json-encode'."
- (declare (debug (&rest form)))
- ;; FIXME: maybe later actually do something, for now this just fixes
- ;; the indenting of literal plists.
- `(list ,@what))
+(defun eglot--on-shutdown (proc)
+ ;; Turn off `eglot--managed-mode' where appropriate.
+ (setf (gethash (eglot--project proc) eglot--processes-by-project)
+ (delq proc
+ (gethash (eglot--project proc) eglot--processes-by-project)))
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (eglot--buffer-managed-p proc)
+ (eglot--managed-mode -1))))
+ (cond ((eglot--moribund proc))
+ ((not (eglot--inhibit-autoreconnect proc))
+ (eglot--warn "Reconnecting unexpected server exit.")
+ (eglot-reconnect proc))
+ (t
+ (eglot--warn "Not auto-reconnecting, last one didn't last long."))))
+
+(defun eglot-shutdown (proc &optional interactive)
+ "Politely ask the server PROC to quit.
+Forcefully quit it if it doesn't respond. Don't leave this
+function with the server still running. INTERACTIVE is t if
+called interactively."
+ (interactive (list (jrpc-current-process-or-lose) t))
+ (when interactive (eglot--message "Asking %s politely to terminate" proc))
+ (unwind-protect
+ (let ((jrpc-request-timeout 3))
+ (setf (eglot--moribund proc) t)
+ (jrpc-request proc :shutdown nil)
+ ;; this one should always fail under normal conditions
+ (ignore-errors (jrpc-request proc :exit nil)))
+ (when (process-live-p proc)
+ (eglot--warn "Brutally deleting existing process %s" proc)
+ (delete-process proc))))
+
+(defun eglot--find-current-process ()
+ "The current logical EGLOT process."
+ (let* ((cur (project-current))
+ (processes (and cur (gethash cur eglot--processes-by-project))))
+ (cl-find major-mode processes :key #'eglot--major-mode)))
(defun eglot--project-short-name (project)
"Give PROJECT a short name."
@@ -200,11 +146,11 @@ CONTACT is as `eglot--contact'. Returns a process
object."
(defun eglot--client-capabilities ()
"What the EGLOT LSP client supports."
- (eglot--obj
- :workspace (eglot--obj
+ (jrpc-obj
+ :workspace (jrpc-obj
:symbol `(:dynamicRegistration :json-false))
- :textDocument (eglot--obj
- :synchronization (eglot--obj
+ :textDocument (jrpc-obj
+ :synchronization (jrpc-obj
:dynamicRegistration :json-false
:willSave t
:willSaveWaitUntil :json-false
@@ -217,49 +163,7 @@ CONTACT is as `eglot--contact'. Returns a process object."
:documentHighlight `(:dynamicRegistration :json-false)
:rename `(:dynamicRegistration :json-false)
:publishDiagnostics `(:relatedInformation :json-false))
- :experimental (eglot--obj)))
-
-(defun eglot--connect (project managed-major-mode short-name contact
interactive)
- "Connect for PROJECT, MANAGED-MAJOR-MODE, SHORT-NAME and CONTACT.
-INTERACTIVE is t if inside interactive call."
- (let* ((proc (eglot--make-process short-name managed-major-mode contact))
- (buffer (process-buffer proc)))
- (setf (eglot--contact proc) contact
- (eglot--project proc) project
- (eglot--major-mode proc) managed-major-mode)
- (with-current-buffer buffer
- (let ((inhibit-read-only t))
- (setf (eglot--inhibit-autoreconnect proc)
- (cond
- ((booleanp eglot-autoreconnect) (not eglot-autoreconnect))
- (interactive nil)
- ((cl-plusp eglot-autoreconnect)
- (run-with-timer eglot-autoreconnect nil
- (lambda ()
- (setf (eglot--inhibit-autoreconnect proc)
- (null eglot-autoreconnect)))))))
- (setf (eglot--short-name proc) short-name)
- (push proc (gethash project eglot--processes-by-project))
- (erase-buffer)
- (read-only-mode t)
- (cl-destructuring-bind (&key capabilities)
- (eglot--request
- proc
- :initialize
- (eglot--obj :processId (unless (eq (process-type proc)
- 'network)
- (emacs-pid))
- :rootUri (eglot--path-to-uri
- (car (project-roots project)))
- :initializationOptions []
- :capabilities (eglot--client-capabilities)))
- (setf (eglot--capabilities proc) capabilities)
- (setf (eglot--status proc) nil)
- (dolist (buffer (buffer-list))
- (with-current-buffer buffer
- (eglot--maybe-activate-editing-mode proc)))
- (eglot--notify proc :initialized (eglot--obj :__dummy__ t))
- proc)))))
+ :experimental (jrpc-obj)))
(defvar eglot--command-history nil
"History of COMMAND arguments to `eglot'.")
@@ -330,7 +234,7 @@ INTERACTIVE is t if called interactively."
(unless project (eglot--error "Cannot work without a current project!"))
(unless command (eglot--error "Don't know how to start EGLOT for %s
buffers"
major-mode))
- (let ((current-process (eglot--current-process)))
+ (let ((current-process (jrpc-current-process)))
(if (and (process-live-p current-process)
interactive
(y-or-n-p "[eglot] Live process found, reconnect instead? "))
@@ -339,7 +243,7 @@ INTERACTIVE is t if called interactively."
(eglot-shutdown current-process))
(let ((proc (eglot--connect project
managed-major-mode
- short-name
+ (format "%s/%s" short-name
managed-major-mode)
command
interactive)))
(eglot--message "Connected! Process `%s' now \
@@ -349,336 +253,56 @@ managing `%s' buffers in project `%s'."
(defun eglot-reconnect (process &optional interactive)
"Reconnect to PROCESS.
INTERACTIVE is t if called interactively."
- (interactive (list (eglot--current-process-or-lose) t))
+ (interactive (list (jrpc-current-process-or-lose) t))
(when (process-live-p process)
(eglot-shutdown process interactive))
(eglot--connect (eglot--project process)
(eglot--major-mode process)
- (eglot--short-name process)
- (eglot--contact process)
+ (jrpc-name process)
+ (jrpc-contact process)
interactive)
(eglot--message "Reconnected!"))
-(defun eglot--process-sentinel (proc change)
- "Called when PROC undergoes CHANGE."
- (eglot--log-event proc `(:message "Process state changed" :change ,change))
- (when (not (process-live-p proc))
- (with-current-buffer (eglot-events-buffer proc)
- (let ((inhibit-read-only t))
- (insert "\n----------b---y---e---b---y---e----------\n")))
- ;; Cancel outstanding timers
- (maphash (lambda (_id triplet)
- (cl-destructuring-bind (_success _error timeout) triplet
- (cancel-timer timeout)))
- (eglot--pending-continuations proc))
- (unwind-protect
- ;; Call all outstanding error handlers
- (maphash (lambda (_id triplet)
- (cl-destructuring-bind (_success error _timeout) triplet
- (funcall error :code -1 :message (format "Server died"))))
- (eglot--pending-continuations proc))
- ;; Turn off `eglot--managed-mode' where appropriate.
+(defalias 'eglot-events-buffer 'jrpc-events-buffer)
+
+(defun eglot--connect (project managed-major-mode name command
+ dont-inhibit)
+ (let ((proc (jrpc-connect name command "eglot--server-")))
+ (setf (eglot--project proc) project)
+ (setf (eglot--major-mode proc)managed-major-mode)
+ (push proc (gethash project eglot--processes-by-project))
+ (cl-destructuring-bind (&key capabilities)
+ (jrpc-request
+ proc
+ :initialize
+ (jrpc-obj :processId (unless (eq (process-type proc)
+ 'network)
+ (emacs-pid))
+ :rootUri (eglot--path-to-uri
+ (car (project-roots project)))
+ :initializationOptions []
+ :capabilities (eglot--client-capabilities)))
+ (setf (eglot--capabilities proc) capabilities)
+ (setf (jrpc-status proc) nil)
(dolist (buffer (buffer-list))
(with-current-buffer buffer
- (when (eglot--buffer-managed-p proc)
- (eglot--managed-mode -1))))
- ;; Forget about the process-project relationship
- (setf (gethash (eglot--project proc) eglot--processes-by-project)
- (delq proc
- (gethash (eglot--project proc) eglot--processes-by-project)))
- (eglot--message "Server exited with status %s" (process-exit-status
proc))
- (cond ((eglot--moribund proc))
- ((not (eglot--inhibit-autoreconnect proc))
- (eglot--warn "Reconnecting unexpected server exit.")
- (eglot-reconnect proc))
- (t
- (eglot--warn "Not auto-reconnecting, last one didn't last
long.")))
- (delete-process proc))))
-
-(defun eglot--process-filter (proc string)
- "Called when new data STRING has arrived for PROC."
- (when (buffer-live-p (process-buffer proc))
- (with-current-buffer (process-buffer proc)
- (let ((inhibit-read-only t)
- (expected-bytes (eglot--expected-bytes proc)))
- ;; Insert the text, advancing the process marker.
- ;;
- (save-excursion
- (goto-char (process-mark proc))
- (insert string)
- (set-marker (process-mark proc) (point)))
- ;; Loop (more than one message might have arrived)
- ;;
- (unwind-protect
- (let (done)
- (while (not done)
- (cond
- ((not expected-bytes)
- ;; Starting a new message
- ;;
- (setq expected-bytes
- (and (search-forward-regexp
- "\\(?:.*: .*\r\n\\)*Content-Length: \
-*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
- (+ (point) 100)
- t)
- (string-to-number (match-string 1))))
- (unless expected-bytes
- (setq done :waiting-for-new-message)))
- (t
- ;; Attempt to complete a message body
- ;;
- (let ((available-bytes (- (position-bytes (process-mark
proc))
- (position-bytes (point)))))
- (cond
- ((>= available-bytes
- expected-bytes)
- (let* ((message-end (byte-to-position
- (+ (position-bytes (point))
- expected-bytes))))
- (unwind-protect
- (save-restriction
- (narrow-to-region (point) message-end)
- (let* ((json-object-type 'plist)
- (json-message (json-read)))
- ;; Process content in another buffer,
- ;; shielding buffer from tamper
- ;;
- (with-temp-buffer
- (eglot--process-receive proc json-message))))
- (goto-char message-end)
- (delete-region (point-min) (point))
- (setq expected-bytes nil))))
- (t
- ;; Message is still incomplete
- ;;
- (setq done
:waiting-for-more-bytes-in-this-message))))))))
- ;; Saved parsing state for next visit to this filter
- ;;
- (setf (eglot--expected-bytes proc) expected-bytes))))))
-
-(defun eglot-events-buffer (process &optional interactive)
- "Display events buffer for current LSP connection PROCESS.
-INTERACTIVE is t if called interactively."
- (interactive (list (eglot--current-process-or-lose) t))
- (let* ((probe (eglot--events-buffer process))
- (buffer (or (and (buffer-live-p probe)
- probe)
- (let ((buffer (get-buffer-create
- (format "*%s events*"
- (process-name process)))))
- (with-current-buffer buffer
- (buffer-disable-undo)
- (read-only-mode t)
- (setf (eglot--events-buffer process) buffer))
- buffer))))
- (when interactive (display-buffer buffer))
- buffer))
-
-(defun eglot--log-event (proc message &optional type)
- "Log an eglot-related event.
-PROC is the current process. MESSAGE is a JSON-like plist. TYPE
-is a symbol saying if this is a client or server originated."
- (with-current-buffer (eglot-events-buffer proc)
- (cl-destructuring-bind (&key method id error &allow-other-keys) message
- (let* ((inhibit-read-only t)
- (subtype (cond ((and method id) 'request)
- (method 'notification)
- (id 'reply)
- (t 'message)))
- (type
- (format "%s-%s" (or type :internal) subtype)))
- (goto-char (point-max))
- (let ((msg (format "%s%s%s:\n%s\n"
- type
- (if id (format " (id:%s)" id) "")
- (if error " ERROR" "")
- (pp-to-string message))))
- (when error
- (setq msg (propertize msg 'face 'error)))
- (insert-before-markers msg))))))
-
-(defun eglot--process-receive (proc message)
- "Process MESSAGE from PROC."
- (cl-destructuring-bind (&key method id error &allow-other-keys) message
- (let* ((continuations (and id
- (not method)
- (gethash id (eglot--pending-continuations
proc)))))
- (eglot--log-event proc message 'server)
- (when error (setf (eglot--status proc) `(,error t)))
- (cond (method
- ;; a server notification or a server request
- (let* ((handler-sym (intern (concat "eglot--server-" method))))
- (if (functionp handler-sym)
- (apply handler-sym proc (append
- (plist-get message :params)
- (if id `(:id ,id))))
- (eglot--warn "No implementation of method %s yet" method)
- (when id
- (eglot--reply
- proc id
- :error (eglot--obj :code -32601
- :message "Method unimplemented"))))))
- (continuations
- (cancel-timer (cl-third continuations))
- (remhash id (eglot--pending-continuations proc))
- (if error
- (apply (cl-second continuations) error)
- (let ((res (plist-get message :result)))
- (if (listp res)
- (apply (cl-first continuations) res)
- (funcall (cl-first continuations) res)))))
- (id
- (eglot--warn "Ooops no continuation for id %s" id)))
- (eglot--call-deferred proc)
- (force-mode-line-update t))))
-
-(defvar eglot--expect-carriage-return nil)
-
-(defun eglot--process-send (proc message)
- "Send MESSAGE to PROC (ID is optional)."
- (let ((json (json-encode message)))
- (process-send-string proc (format "Content-Length: %d\r\n\r\n%s"
- (string-bytes json)
- json))
- (eglot--log-event proc message 'client)))
-
-(defvar eglot--next-request-id 0)
-
-(defun eglot--next-request-id ()
- "Compute the next id for a client request."
- (setq eglot--next-request-id (1+ eglot--next-request-id)))
-
-(defun eglot-forget-pending-continuations (process)
- "Stop waiting for responses from the current LSP PROCESS."
- (interactive (list (eglot--current-process-or-lose)))
- (clrhash (eglot--pending-continuations process)))
-
-(defun eglot-clear-status (process)
- "Clear most recent error message from PROCESS."
- (interactive (list (eglot--current-process-or-lose)))
- (setf (eglot--status process) nil))
-
-(defun eglot--call-deferred (proc)
- "Call PROC's deferred actions, who may again defer themselves."
- (when-let ((actions (hash-table-values (eglot--deferred-actions proc))))
- (eglot--log-event proc `(:running-deferred ,(length actions)))
- (mapc #'funcall (mapcar #'car actions))))
-
-(defvar eglot--ready-predicates '(eglot--server-ready-p)
- "Special hook of predicates controlling deferred actions.
-If one of these returns nil, a deferrable `eglot--async-request'
-will be deferred. Each predicate is passed the symbol for the
-request request and a process object.")
+ (eglot--maybe-activate-editing-mode proc)))
+ (jrpc-notify proc :initialized (jrpc-obj :__dummy__ t))
+ (setf (eglot--inhibit-autoreconnect proc)
+ (cond
+ ((booleanp eglot-autoreconnect) (not eglot-autoreconnect))
+ (dont-inhibit nil)
+ ((cl-plusp eglot-autoreconnect)
+ (run-with-timer eglot-autoreconnect nil
+ (lambda ()
+ (setf (eglot--inhibit-autoreconnect proc)
+ (null eglot-autoreconnect)))))))
+ proc)))
(defun eglot--server-ready-p (_what _proc)
"Tell if server of PROC ready for processing deferred WHAT."
(not (eglot--outstanding-edits-p)))
-(cl-defmacro eglot--lambda (cl-lambda-list &body body)
- (declare (indent 1) (debug (sexp &rest form)))
- `(cl-function (lambda ,cl-lambda-list ,@body)))
-
-(cl-defun eglot--async-request (proc
- method
- params
- &rest args
- &key success-fn error-fn timeout-fn
- (timeout eglot-request-timeout)
- (deferred nil))
- "Make a request to PROCESS, expecting a reply.
-Return the ID of this request. Wait TIMEOUT seconds for response.
-If DEFERRED, maybe defer request to the future, or never at all,
-in case a new request with identical DEFERRED and for the same
-buffer overrides it. However, if that happens, the original
-timeout keeps counting."
- (let* ((id (eglot--next-request-id))
- (existing-timer nil)
- (make-timeout
- (lambda ( )
- (or existing-timer
- (run-with-timer
- timeout nil
- (lambda ()
- (remhash id (eglot--pending-continuations proc))
- (funcall (or timeout-fn
- (lambda ()
- (eglot--error
- "Tired of waiting for reply to %s, id=%s"
- method id))))))))))
- (when deferred
- (let* ((buf (current-buffer))
- (existing (gethash (list deferred buf) (eglot--deferred-actions
proc))))
- (when existing (setq existing-timer (cadr existing)))
- (if (run-hook-with-args-until-failure 'eglot--ready-predicates
- deferred proc)
- (remhash (list deferred buf) (eglot--deferred-actions proc))
- (eglot--log-event proc `(:deferring ,method :id ,id :params ,params))
- (let* ((buf (current-buffer)) (point (point))
- (later (lambda ()
- (when (buffer-live-p buf)
- (with-current-buffer buf
- (save-excursion (goto-char point)
- (apply #'eglot--async-request
proc
- method params args)))))))
- (puthash (list deferred buf) (list later (funcall make-timeout))
- (eglot--deferred-actions proc))
- (cl-return-from eglot--async-request nil)))))
- ;; Really run it
- ;;
- (puthash id
- (list (or success-fn
- (eglot--lambda (&rest _ignored)
- (eglot--log-event
- proc (eglot--obj :message "success ignored" :id
id))))
- (or error-fn
- (eglot--lambda (&key code message &allow-other-keys)
- (setf (eglot--status proc) `(,message t))
- proc (eglot--obj :message "error ignored, status set"
- :id id :error code)))
- (funcall make-timeout))
- (eglot--pending-continuations proc))
- (eglot--process-send proc (eglot--obj :jsonrpc "2.0"
- :id id
- :method method
- :params params))))
-
-(defun eglot--request (proc method params &optional deferred)
- "Like `eglot--async-request' for PROC, METHOD and PARAMS, but synchronous.
-Meaning only return locally if successful, otherwise exit non-locally.
-DEFERRED is passed to `eglot--async-request', which see."
- ;; Launching a deferred sync request with outstanding changes is a
- ;; bad idea, since that might lead to the request never having a
- ;; chance to run, because `eglot--ready-predicates'.
- (when deferred (eglot--signal-textDocument/didChange))
- (let ((retval))
- (eglot--async-request
- proc method params
- :success-fn (lambda (&rest args)
- (setq retval `(done ,(if (vectorp (car args))
- (car args) args))))
- :error-fn (eglot--lambda (&key code message &allow-other-keys)
- (setq retval `(error ,(format "Oops: %s: %s" code message))))
- :timeout-fn (lambda ()
- (setq retval '(error "Timed out")))
- :deferred deferred)
- (while (not retval) (accept-process-output nil 30))
- (when (eq 'error (car retval)) (eglot--error (cadr retval)))
- (cadr retval)))
-
-(cl-defun eglot--notify (process method params)
- "Notify PROCESS of something, don't expect a reply.e"
- (eglot--process-send process (eglot--obj :jsonrpc "2.0"
- :method method
- :params params)))
-
-(cl-defun eglot--reply (process id &key result error)
- "Reply to PROCESS's request ID with MESSAGE."
- (eglot--process-send
- process `(:jsonrpc "2.0" :id ,id
- ,@(when result `(:result ,result))
- ,@(when error `(:error ,error)))))
-
;;; Helpers
;;;
@@ -701,7 +325,7 @@ DEFERRED is passed to `eglot--async-request', which see."
(defun eglot--pos-to-lsp-position (&optional pos)
"Convert point POS to LSP position."
(save-excursion
- (eglot--obj :line
+ (jrpc-obj :line
;; F!@(#*&#$)CKING OFF-BY-ONE
(1- (line-number-at-pos pos t))
:character
@@ -718,11 +342,6 @@ DEFERRED is passed to `eglot--async-request', which see."
(line-beginning-position))))
(point)))
-
-(defun eglot--mapply (fun seq)
- "Apply FUN to every element of SEQ."
- (mapcar (lambda (e) (apply fun e)) seq))
-
(defun eglot--path-to-uri (path)
"Urify PATH."
(url-hexify-string (concat "file://" (file-truename path))
@@ -759,7 +378,7 @@ DEFERRED is passed to `eglot--async-request', which see."
(defun eglot--server-capable (feat)
"Determine if current server is capable of FEAT."
- (plist-get (eglot--capabilities (eglot--current-process-or-lose)) feat))
+ (plist-get (eglot--capabilities (jrpc-current-process-or-lose)) feat))
(cl-defmacro eglot--with-lsp-range ((start end) range &body body
&aux (range-sym (cl-gensym)))
@@ -780,6 +399,9 @@ DEFERRED is passed to `eglot--async-request', which see."
nil nil eglot-mode-map
(cond
(eglot--managed-mode
+ (add-hook 'jrpc-find-process-functions 'eglot--find-current-process nil t)
+ (add-hook 'jrpc-ready-predicates 'eglot--server-ready-p nil t)
+ (add-hook 'jrpc-server-moribund-hook 'eglot--on-shutdown nil t)
(add-hook 'after-change-functions 'eglot--after-change nil t)
(add-hook 'before-change-functions 'eglot--before-change nil t)
(add-hook 'flymake-diagnostic-functions 'eglot-flymake-backend nil t)
@@ -793,6 +415,9 @@ DEFERRED is passed to `eglot--async-request', which see."
#'eglot-eldoc-function)
(add-function :around (local imenu-create-index-function) #'eglot-imenu))
(t
+ (remove-hook 'jrpc-find-process-functions 'eglot--find-current-process t)
+ (remove-hook 'jrpc-ready-predicates 'eglot--server-ready-p t)
+ (remove-hook 'jrpc-server-moribund-hook 'eglot--on-shutdown t)
(remove-hook 'flymake-diagnostic-functions 'eglot-flymake-backend t)
(remove-hook 'after-change-functions 'eglot--after-change t)
(remove-hook 'before-change-functions 'eglot--before-change t)
@@ -805,7 +430,7 @@ DEFERRED is passed to `eglot--async-request', which see."
(remove-function (local 'eldoc-documentation-function)
#'eglot-eldoc-function)
(remove-function (local imenu-create-index-function) #'eglot-imenu)
- (let ((proc (eglot--current-process)))
+ (let ((proc (eglot--find-current-process)))
(when (and (process-live-p proc) (y-or-n-p "[eglot] Kill server too? "))
(eglot-shutdown proc t))))))
@@ -813,10 +438,12 @@ DEFERRED is passed to `eglot--async-request', which see."
(add-hook 'eglot--managed-mode-hook 'eldoc-mode)
(defun eglot--buffer-managed-p (&optional proc)
- "Tell if current buffer is managed by PROC."
- (and buffer-file-name (let ((cur (eglot--current-process)))
- (or (and (null proc) cur)
- (and proc (eq proc cur))))))
+ "Tell if current buffer can be managed by PROC."
+ (and buffer-file-name
+ (cond ((null proc) (jrpc-current-process))
+ (t (and (eq major-mode (eglot--major-mode proc))
+ (let ((proj (project-current)))
+ (and proj (equal proj (eglot--project proc)))))))))
(defvar-local eglot--current-flymake-report-fn nil
"Current flymake report function for this buffer")
@@ -868,12 +495,11 @@ Uses THING, FACE, DEFS and PREPEND."
(defun eglot--mode-line-format ()
"Compose the EGLOT's mode-line."
- (pcase-let* ((proc (eglot--current-process))
- (name (and (process-live-p proc) (eglot--short-name proc)))
- (pending (and proc (hash-table-count
- (eglot--pending-continuations proc))))
+ (pcase-let* ((proc (jrpc-current-process))
+ (name (and (process-live-p proc) (jrpc-name proc)))
+ (pending (and proc (length (jrpc-outstanding-request-ids
proc))))
(`(,_id ,doing ,done-p ,detail) (and proc (eglot--spinner
proc)))
- (`(,status ,serious-p) (and proc (eglot--status proc))))
+ (`(,status ,serious-p) (and proc (jrpc-status proc))))
(append
`(,(eglot--mode-line-props "eglot" 'eglot-mode-line
'((down-mouse-1 eglot-menu "pop up EGLOT
menu"))))
@@ -908,25 +534,6 @@ Uses THING, FACE, DEFS and PREPEND."
;;; Protocol implementation (Requests, notifications, etc)
;;;
-(defun eglot-shutdown (proc &optional interactive)
- "Politely ask the server PROC to quit.
-Forcefully quit it if it doesn't respond. Don't leave this
-function with the server still running. INTERACTIVE is t if
-called interactively."
- (interactive (list (eglot--current-process-or-lose) t))
- (when interactive (eglot--message "Asking %s politely to terminate" proc))
- (unwind-protect
- (let ((eglot-request-timeout 3))
- (setf (eglot--moribund proc) t)
- (eglot--request proc
- :shutdown
- nil)
- ;; this one should always fail
- (ignore-errors (eglot--request proc :exit nil)))
- (when (process-live-p proc)
- (eglot--warn "Brutally deleting existing process %s" proc)
- (delete-process proc))))
-
(cl-defun eglot--server-window/showMessage (_process &key type message)
"Handle notification window/showMessage"
(eglot--message (propertize "Server reports (type=%s): %s"
@@ -949,10 +556,10 @@ called interactively."
'("OK"))
nil t (plist-get (elt actions 0) :title)))
(if reply
- (eglot--reply process id :result (eglot--obj :title reply))
- (eglot--reply process id
- :error (eglot--obj :code -32800
- :message "User cancelled"))))))
+ (jrpc-reply process id :result (jrpc-obj :title reply))
+ (jrpc-reply process id
+ :error (jrpc-obj :code -32800
+ :message "User cancelled"))))))
(cl-defun eglot--server-window/logMessage (_proc &key _type _message)
"Handle notification window/logMessage") ;; noop, use events buffer
@@ -978,12 +585,12 @@ called interactively."
_code source message)
diag-spec
(eglot--with-lsp-range (beg end) range
- (flymake-make-diagnostic (current-buffer)
- beg end
- (cond ((<= severity 1) :error)
- ((= severity 2) :warning)
- (t :note))
- (concat source ": " message))))
+ (flymake-make-diagnostic
(current-buffer)
+ beg end
+ (cond ((<=
severity 1) :error)
+ ((=
severity 2) :warning)
+ (t
:note))
+ (concat
source ": " message))))
into diags
finally (cond (eglot--current-flymake-report-fn
(funcall eglot--current-flymake-report-fn diags)
@@ -996,7 +603,7 @@ called interactively."
(cl-defun eglot--server-client/registerCapability
(proc &key id registrations)
"Handle notification client/registerCapability"
- (let ((jsonrpc-id id)
+ (let ((jrpc-id id)
(done (make-symbol "done")))
(catch done
(mapc
@@ -1012,13 +619,13 @@ called interactively."
(apply handler-sym proc :id id registerOptions))))
(unless ok
(throw done
- (eglot--reply proc jsonrpc-id
- :error (eglot--obj
- :code -32601
- :message (or message "sorry
:-("))))))))
+ (jrpc-reply proc jrpc-id
+ :error (jrpc-obj
+ :code -32601
+ :message (or message "sorry
:-("))))))))
reg))
registrations)
- (eglot--reply proc id :result (eglot--obj :message "OK")))))
+ (jrpc-reply proc id :result (jrpc-obj :message "OK")))))
(cl-defun eglot--server-workspace/applyEdit
(proc &key id _label edit)
@@ -1026,30 +633,30 @@ called interactively."
(condition-case err
(progn
(eglot--apply-workspace-edit edit 'confirm)
- (eglot--reply proc id :result `(:applied )))
+ (jrpc-reply proc id :result `(:applied )))
(error
- (eglot--reply proc id
- :result `(:applied :json-false)
- :error
- (eglot--obj :code -32001
- :message (format "%s" err))))))
+ (jrpc-reply proc id
+ :result `(:applied :json-false)
+ :error
+ (jrpc-obj :code -32001
+ :message (format "%s" err))))))
(defun eglot--TextDocumentIdentifier ()
"Compute TextDocumentIdentifier object for current buffer."
- (eglot--obj :uri (eglot--path-to-uri buffer-file-name)))
+ (jrpc-obj :uri (eglot--path-to-uri buffer-file-name)))
(defvar-local eglot--versioned-identifier 0)
(defun eglot--VersionedTextDocumentIdentifier ()
"Compute VersionedTextDocumentIdentifier object for current buffer."
(append (eglot--TextDocumentIdentifier)
- (eglot--obj :version eglot--versioned-identifier)))
+ (jrpc-obj :version eglot--versioned-identifier)))
(defun eglot--TextDocumentItem ()
"Compute TextDocumentItem object for current buffer."
(append
(eglot--VersionedTextDocumentIdentifier)
- (eglot--obj :languageId
+ (jrpc-obj :languageId
(if (string-match "\\(.*\\)-mode" (symbol-name major-mode))
(match-string 1 (symbol-name major-mode))
"unknown")
@@ -1060,7 +667,7 @@ called interactively."
(defun eglot--TextDocumentPositionParams ()
"Compute TextDocumentPositionParams."
- (eglot--obj :textDocument (eglot--TextDocumentIdentifier)
+ (jrpc-obj :textDocument (eglot--TextDocumentIdentifier)
:position (eglot--pos-to-lsp-position)))
(defvar-local eglot--recent-changes nil
@@ -1091,10 +698,16 @@ Records START, END and PRE-CHANGE-LENGTH locally."
`[(,pre-change-length
,(buffer-substring-no-properties start end))])))
+;; HACK!
+(advice-add #'jrpc-request :before
+ (lambda (_proc _method _params &optional deferred)
+ (when (and eglot--managed-mode deferred)
+ (eglot--signal-textDocument/didChange))))
+
(defun eglot--signal-textDocument/didChange ()
"Send textDocument/didChange to server."
(when (eglot--outstanding-edits-p)
- (let* ((proc (eglot--current-process-or-lose))
+ (let* ((proc (jrpc-current-process-or-lose))
(sync-kind (eglot--server-capable :textDocumentSync))
(emacs-messup (/= (length (car eglot--recent-changes))
(length (cdr eglot--recent-changes))))
@@ -1103,56 +716,57 @@ Records START, END and PRE-CHANGE-LENGTH locally."
(eglot--warn "`eglot--recent-changes' messup: %s"
eglot--recent-changes))
(save-restriction
(widen)
- (eglot--notify
+ (jrpc-notify
proc :textDocument/didChange
- (eglot--obj
+ (jrpc-obj
:textDocument
(eglot--VersionedTextDocumentIdentifier)
:contentChanges
(if full-sync-p (vector
- (eglot--obj
+ (jrpc-obj
:text (buffer-substring-no-properties (point-min)
(point-max))))
(cl-loop for (start-pos end-pos) across (car eglot--recent-changes)
for (len after-text) across (cdr eglot--recent-changes)
- vconcat `[,(eglot--obj :range (eglot--obj :start start-pos
- :end end-pos)
- :rangeLength len
- :text after-text)])))))
+ vconcat `[,(jrpc-obj :range (jrpc-obj :start start-pos
+ :end end-pos)
+ :rangeLength len
+ :text after-text)])))))
(setq eglot--recent-changes (cons [] []))
(setf (eglot--spinner proc) (list nil :textDocument/didChange t))
- (eglot--call-deferred proc))))
+ ;; HACK!
+ (jrpc--call-deferred proc))))
(defun eglot--signal-textDocument/didOpen ()
"Send textDocument/didOpen to server."
(setq eglot--recent-changes (cons [] []))
- (eglot--notify (eglot--current-process-or-lose)
- :textDocument/didOpen
- (eglot--obj :textDocument
- (eglot--TextDocumentItem))))
+ (jrpc-notify (jrpc-current-process-or-lose)
+ :textDocument/didOpen
+ (jrpc-obj :textDocument
+ (eglot--TextDocumentItem))))
(defun eglot--signal-textDocument/didClose ()
"Send textDocument/didClose to server."
- (eglot--notify (eglot--current-process-or-lose)
- :textDocument/didClose
- (eglot--obj :textDocument
- (eglot--TextDocumentIdentifier))))
+ (jrpc-notify (jrpc-current-process-or-lose)
+ :textDocument/didClose
+ (jrpc-obj :textDocument
+ (eglot--TextDocumentIdentifier))))
(defun eglot--signal-textDocument/willSave ()
"Send textDocument/willSave to server."
- (eglot--notify
- (eglot--current-process-or-lose)
+ (jrpc-notify
+ (jrpc-current-process-or-lose)
:textDocument/willSave
- (eglot--obj
+ (jrpc-obj
:reason 1 ; Manual, emacs laughs in the face of auto-save muahahahaha
:textDocument (eglot--TextDocumentIdentifier))))
(defun eglot--signal-textDocument/didSave ()
"Send textDocument/didSave to server."
- (eglot--notify
- (eglot--current-process-or-lose)
+ (jrpc-notify
+ (jrpc-current-process-or-lose)
:textDocument/didSave
- (eglot--obj
+ (jrpc-obj
;; TODO: Handle TextDocumentSaveRegistrationOptions to control this.
:text (buffer-substring-no-properties (point-min) (point-max))
:textDocument (eglot--TextDocumentIdentifier))))
@@ -1192,26 +806,26 @@ DUMMY is ignored"
(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql eglot)))
(when (eglot--server-capable :documentSymbolProvider)
- (let ((proc (eglot--current-process-or-lose))
+ (let ((proc (jrpc-current-process-or-lose))
(text-id (eglot--TextDocumentIdentifier)))
(completion-table-with-cache
(lambda (string)
(setq eglot--xref-known-symbols
- (eglot--mapply
- (eglot--lambda (&key name kind location containerName)
+ (jrpc-mapply
+ (jrpc-lambda (&key name kind location containerName)
(propertize name
:textDocumentPositionParams
- (eglot--obj :textDocument text-id
- :position (plist-get
- (plist-get location
:range)
- :start))
+ (jrpc-obj :textDocument text-id
+ :position (plist-get
+ (plist-get location :range)
+ :start))
:locations (list location)
:kind kind
:containerName containerName))
- (eglot--request proc
- :textDocument/documentSymbol
- (eglot--obj
- :textDocument text-id))))
+ (jrpc-request proc
+ :textDocument/documentSymbol
+ (jrpc-obj
+ :textDocument text-id))))
(all-completions string eglot--xref-known-symbols))))))
(cl-defmethod xref-backend-identifier-at-point ((_backend (eql eglot)))
@@ -1226,12 +840,12 @@ DUMMY is ignored"
(location-or-locations
(if rich-identifier
(get-text-property 0 :locations rich-identifier)
- (eglot--request (eglot--current-process-or-lose)
- :textDocument/definition
- (get-text-property
- 0 :textDocumentPositionParams identifier)))))
- (eglot--mapply
- (eglot--lambda (&key uri range)
+ (jrpc-request (jrpc-current-process-or-lose)
+ :textDocument/definition
+ (get-text-property
+ 0 :textDocumentPositionParams identifier)))))
+ (jrpc-mapply
+ (jrpc-lambda (&key uri range)
(eglot--xref-make identifier uri (plist-get range :start)))
location-or-locations)))
@@ -1244,43 +858,43 @@ DUMMY is ignored"
(and rich (get-text-property 0 :textDocumentPositionParams
rich))))))
(unless params
(eglot--error "Don' know where %s is in the workspace!" identifier))
- (eglot--mapply
- (eglot--lambda (&key uri range)
+ (jrpc-mapply
+ (jrpc-lambda (&key uri range)
(eglot--xref-make identifier uri (plist-get range :start)))
- (eglot--request (eglot--current-process-or-lose)
- :textDocument/references
- (append
- params
- (eglot--obj :context
- (eglot--obj :includeDeclaration t)))))))
+ (jrpc-request (jrpc-current-process-or-lose)
+ :textDocument/references
+ (append
+ params
+ (jrpc-obj :context
+ (jrpc-obj :includeDeclaration t)))))))
(cl-defmethod xref-backend-apropos ((_backend (eql eglot)) pattern)
(when (eglot--server-capable :workspaceSymbolProvider)
- (eglot--mapply
- (eglot--lambda (&key name location &allow-other-keys)
+ (jrpc-mapply
+ (jrpc-lambda (&key name location &allow-other-keys)
(cl-destructuring-bind (&key uri range) location
(eglot--xref-make name uri (plist-get range :start))))
- (eglot--request (eglot--current-process-or-lose)
- :workspace/symbol
- (eglot--obj :query pattern)))))
+ (jrpc-request (jrpc-current-process-or-lose)
+ :workspace/symbol
+ (jrpc-obj :query pattern)))))
(defun eglot-completion-at-point ()
"EGLOT's `completion-at-point' function."
(let ((bounds (bounds-of-thing-at-point 'symbol))
- (proc (eglot--current-process-or-lose)))
+ (proc (jrpc-current-process-or-lose)))
(when (eglot--server-capable :completionProvider)
(list
(or (car bounds) (point))
(or (cdr bounds) (point))
(completion-table-with-cache
(lambda (_ignored)
- (let* ((resp (eglot--request proc
- :textDocument/completion
- (eglot--TextDocumentPositionParams)
- :textDocument/completion))
+ (let* ((resp (jrpc-request proc
+ :textDocument/completion
+ (eglot--TextDocumentPositionParams)
+ :textDocument/completion))
(items (if (vectorp resp) resp (plist-get resp :items))))
- (eglot--mapply
- (eglot--lambda (&rest all &key label &allow-other-keys)
+ (jrpc-mapply
+ (jrpc-lambda (&rest all &key label &allow-other-keys)
(add-text-properties 0 1 all label) label)
items))))
:annotation-function
@@ -1299,8 +913,8 @@ DUMMY is ignored"
(lambda (obj)
(let ((documentation
(or (get-text-property 0 :documentation obj)
- (plist-get (eglot--request proc :completionItem/resolve
- (text-properties-at 0 obj))
+ (plist-get (jrpc-request proc :completionItem/resolve
+ (text-properties-at 0 obj))
:documentation))))
(when documentation
(with-current-buffer (get-buffer-create " *eglot doc*")
@@ -1317,7 +931,7 @@ DUMMY is ignored"
(defun eglot--hover-info (contents &optional range)
(concat (and range
(eglot--with-lsp-range (beg end) range
- (concat (buffer-substring beg end) ": ")))
+ (concat (buffer-substring beg end) ":
")))
(mapconcat #'eglot--format-markup
(append
(cond ((vectorp contents)
@@ -1329,8 +943,8 @@ DUMMY is ignored"
"Request \"hover\" information for the thing at point."
(interactive)
(cl-destructuring-bind (&key contents range)
- (eglot--request (eglot--current-process-or-lose) :textDocument/hover
- (eglot--TextDocumentPositionParams))
+ (jrpc-request (jrpc-current-process-or-lose) :textDocument/hover
+ (eglot--TextDocumentPositionParams))
(when (seq-empty-p contents) (eglot--error "No hover info here"))
(with-help-window "*eglot help*"
(with-current-buffer standard-output
@@ -1339,26 +953,26 @@ DUMMY is ignored"
(defun eglot-eldoc-function ()
"EGLOT's `eldoc-documentation-function' function."
(let ((buffer (current-buffer))
- (proc (eglot--current-process-or-lose))
+ (proc (jrpc-current-process-or-lose))
(position-params (eglot--TextDocumentPositionParams)))
(when (eglot--server-capable :hoverProvider)
- (eglot--async-request
+ (jrpc-async-request
proc :textDocument/hover position-params
- :success-fn (eglot--lambda (&key contents range)
+ :success-fn (jrpc-lambda (&key contents range)
(when (get-buffer-window buffer)
(with-current-buffer buffer
(eldoc-message (eglot--hover-info contents range)))))
:deferred :textDocument/hover))
(when (eglot--server-capable :documentHighlightProvider)
- (eglot--async-request
+ (jrpc-async-request
proc :textDocument/documentHighlight position-params
:success-fn (lambda (highlights)
(mapc #'delete-overlay eglot--highlights)
(setq eglot--highlights
(when (get-buffer-window buffer)
(with-current-buffer buffer
- (eglot--mapply
- (eglot--lambda (&key range _kind)
+ (jrpc-mapply
+ (jrpc-lambda (&key range _kind)
(eglot--with-lsp-range (beg end) range
(let ((ov (make-overlay beg end)))
(overlay-put ov 'face 'highlight)
@@ -1372,15 +986,15 @@ DUMMY is ignored"
"EGLOT's `imenu-create-index-function' overriding OLDFUN."
(if (eglot--server-capable :documentSymbolProvider)
(let ((entries
- (eglot--mapply
- (eglot--lambda (&key name kind location _containerName)
+ (jrpc-mapply
+ (jrpc-lambda (&key name kind location _containerName)
(cons (propertize name :kind (cdr (assoc kind
eglot--kind-names)))
(eglot--lsp-position-to-point
(plist-get (plist-get location :range) :start))))
- (eglot--request (eglot--current-process-or-lose)
- :textDocument/documentSymbol
- (eglot--obj
- :textDocument
(eglot--TextDocumentIdentifier))))))
+ (jrpc-request (jrpc-current-process-or-lose)
+ :textDocument/documentSymbol
+ (jrpc-obj
+ :textDocument (eglot--TextDocumentIdentifier))))))
(append
(seq-group-by (lambda (e) (get-text-property 0 :kind (car e)))
entries)
@@ -1394,8 +1008,8 @@ DUMMY is ignored"
(equal version eglot--versioned-identifier))
(eglot--error "Edits on `%s' require version %d, you have %d"
buffer version eglot--versioned-identifier))
- (eglot--mapply
- (eglot--lambda (&key range newText)
+ (jrpc-mapply
+ (jrpc-lambda (&key range newText)
(save-restriction
(widen)
(save-excursion
@@ -1448,9 +1062,9 @@ Proceed? "
(unless (eglot--server-capable :renameProvider)
(eglot--error "Server can't rename!"))
(eglot--apply-workspace-edit
- (eglot--request (eglot--current-process-or-lose)
- :textDocument/rename `(,@(eglot--TextDocumentPositionParams)
- ,@(eglot--obj :newName newname)))
+ (jrpc-request (jrpc-current-process-or-lose)
+ :textDocument/rename `(,@(eglot--TextDocumentPositionParams)
+ ,@(jrpc-obj :newName newname)))
current-prefix-arg))
@@ -1478,7 +1092,7 @@ Proceed? "
(add-hook 'rust-mode-hook 'eglot--setup-rls-idiosyncrasies)
(defun eglot--setup-rls-idiosyncrasies ()
"Prepare `eglot' to deal with RLS's special treatment."
- (add-hook 'eglot--ready-predicates 'eglot--rls-probably-ready-for-p t t)))
+ (add-hook 'jrpc-ready-predicates 'eglot--rls-probably-ready-for-p t t)))
(cl-defun eglot--server-window/progress
(process &key id done title message &allow-other-keys)
diff --git a/jrpc.el b/jrpc.el
new file mode 100644
index 0000000..91ad0ea
--- /dev/null
+++ b/jrpc.el
@@ -0,0 +1,502 @@
+;;; jrpc.el --- JSON-RPC library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotav...@gmail.com>
+;; Maintainer: João Távora <joaotav...@gmail.com>
+;; URL: https://github.com/joaotavora/eglot
+;; Keywords: processes, languages, extensions
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Originally extracted from eglot.el (Emacs LSP client)
+;;
+;;
+;; code message meaning
+;; -32700 Parse error Invalid JSON was received by the server.
+;; An error occurred on the server while parsing the JSON text.
+;; -32600 Invalid Request The JSON sent is not a valid Request object.
+;; -32601 Method not found The method does not exist / is not
available.
+;; -32602 Invalid params Invalid method parameter(s).
+;; -32603 Internal error Internal JSON-RPC error.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'json)
+(require 'subr-x)
+(require 'warnings)
+
+(defgroup jrpc nil
+ "Interaction with Language Server Protocol servers"
+ :prefix "jrpc-"
+ :group 'applications)
+
+(defcustom jrpc-request-timeout 10
+ "How many seconds to wait for a reply from the server."
+ :type :integer)
+
+(defvar jrpc-find-process-functions nil
+ "Special hook to find an active JSON-RPC process.")
+
+(defun jrpc-current-process ()
+ "The current logical JSON-RPC process."
+ (run-hook-with-args-until-success 'jrpc-find-process-functions))
+
+(defun jrpc-current-process-or-lose ()
+ "Return the current JSON-RPC process or error."
+ (or (jrpc-current-process)
+ (jrpc-error "No current JSON-RPC process")))
+
+(defun jrpc-error (format &rest args)
+ "Error out with FORMAT with ARGS."
+ (error (apply #'format format args)))
+
+(defun jrpc-message (format &rest args)
+ "Message out with FORMAT with ARGS."
+ (message (concat "[jrpc] " (apply #'format format args))))
+
+(defun jrpc-warn (format &rest args)
+ "Warning message with FORMAT and ARGS."
+ (apply #'jrpc-message (concat "(warning) " format) args)
+ (let ((warning-minimum-level :error))
+ (display-warning 'jrpc
+ (apply #'format format args)
+ :warning)))
+
+(defmacro jrpc-define-process-var
+ (var-sym initval &optional doc)
+ "Define VAR-SYM as a generalized process-local variable.
+INITVAL is the default value. DOC is the documentation."
+ (declare (indent 2))
+ `(progn
+ (put ',var-sym 'function-documentation ,doc)
+ (defun ,var-sym (proc)
+ (let* ((plist (process-plist proc))
+ (probe (plist-member plist ',var-sym)))
+ (if probe
+ (cadr probe)
+ (let ((def ,initval))
+ (process-put proc ',var-sym def)
+ def))))
+ (gv-define-setter ,var-sym (to-store process)
+ `(let ((once ,to-store)) (process-put ,process ',',var-sym once)
once))))
+
+(jrpc-define-process-var jrpc-name nil
+ "A name for the process")
+
+(jrpc-define-process-var jrpc--method-prefix nil
+ "Emacs-lisp function prefix for server-invoked methods.")
+
+(jrpc-define-process-var jrpc-status `(:unknown nil)
+ "Status as declared by the server.
+A list (WHAT SERIOUS-P).")
+
+(jrpc-define-process-var jrpc--expected-bytes nil
+ "How many bytes declared by server")
+
+(jrpc-define-process-var jrpc--pending-continuations (make-hash-table)
+ "A hash table of request ID to continuation lambdas")
+
+(jrpc-define-process-var jrpc--events-buffer nil
+ "A buffer pretty-printing the JSON-RPC RPC events")
+
+(jrpc-define-process-var jrpc-contact nil
+ "Method used to contact a server.")
+
+(jrpc-define-process-var jrpc--deferred-actions
+ (make-hash-table :test #'equal)
+ "Actions deferred to when server is thought to be ready.")
+
+(defun jrpc-outstanding-request-ids (proc)
+ "IDs of outstanding JSON-RPC requests for PROC."
+ (hash-table-keys (jrpc--pending-continuations proc)))
+
+(defun jrpc--make-process (name contact)
+ "Make a process from CONTACT.
+NAME is a name to give the inferior process or connection.
+CONTACT is as `jrpc-contact'. Returns a process object."
+ (let* ((readable-name (format "JSON-RPC server (%s)" name)
)
+ (buffer (get-buffer-create
+ (format "*%s inferior*" readable-name)))
+ singleton
+ (proc
+ (if (and (setq singleton (and (null (cdr contact)) (car contact)))
+ (string-match "^[\s\t]*\\(.*\\):\\([[:digit:]]+\\)[\s\t]*$"
+ singleton))
+ (open-network-stream readable-name
+ buffer
+ (match-string 1 singleton)
+ (string-to-number
+ (match-string 2 singleton)))
+ (make-process :name readable-name
+ :buffer buffer
+ :command contact
+ :connection-type 'pipe
+ :stderr (get-buffer-create (format "*%s stderr*"
+ name))))))
+ (set-process-filter proc #'jrpc--process-filter)
+ (set-process-sentinel proc #'jrpc--process-sentinel)
+ proc))
+
+(defmacro jrpc-obj (&rest what)
+ "Make WHAT a suitable argument for `json-encode'."
+ (declare (debug (&rest form)))
+ ;; FIXME: maybe later actually do something, for now this just fixes
+ ;; the indenting of literal plists, i.e. is basically `list'
+ `(list ,@what))
+
+(cl-defun jrpc-connect (name contact prefix)
+ "Connect to JSON-RPC server hereafter known as NAME through CONTACT.
+
+NAME is a string naming the server.
+
+CONTACT is either a list of strings (a shell command and
+arguments), or a list of a single string of the form
+<host>:<port>.
+
+PREFIX specifies how the server-invoked methods find their Elisp
+counterpart. If a server invokes method \"FooBar\" and PREFIX is
+\"fancy-mode-\", then the function `fancy-mode-FooBar' will be
+called with arguments (PROCESS [JSON]). JSON is either a plist of
+key-value pairs or, for JSON arrays, a non-list sequence."
+ (let* ((proc (jrpc--make-process name contact))
+ (buffer (process-buffer proc)))
+ (setf (jrpc-contact proc) contact
+ (jrpc-name proc) name
+ (jrpc--method-prefix proc) prefix)
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (read-only-mode t)
+ proc))))
+
+(defvar jrpc-server-moribund-hook nil
+ "Hook run when JSON-RPC server is dying.
+Run after running any error handlers for outstanding requests.
+Each hook function is passed the process object for the server.")
+
+(defun jrpc--process-sentinel (proc change)
+ "Called when PROC undergoes CHANGE."
+ (jrpc-log-event proc `(:message "Process state changed" :change ,change))
+ (when (not (process-live-p proc))
+ (with-current-buffer (jrpc-events-buffer proc)
+ (let ((inhibit-read-only t))
+ (insert "\n----------b---y---e---b---y---e----------\n")))
+ ;; Cancel outstanding timers
+ (maphash (lambda (_id triplet)
+ (cl-destructuring-bind (_success _error timeout) triplet
+ (cancel-timer timeout)))
+ (jrpc--pending-continuations proc))
+ (unwind-protect
+ ;; Call all outstanding error handlers
+ (maphash (lambda (_id triplet)
+ (cl-destructuring-bind (_success error _timeout) triplet
+ (funcall error :code -1 :message (format "Server died"))))
+ (jrpc--pending-continuations proc))
+ (jrpc-message "Server exited with status %s" (process-exit-status proc))
+ (run-hook-with-args 'jrpc-server-moribund-hook proc)
+ (delete-process proc))))
+
+(defun jrpc--process-filter (proc string)
+ "Called when new data STRING has arrived for PROC."
+ (when (buffer-live-p (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (let ((inhibit-read-only t)
+ (expected-bytes (jrpc--expected-bytes proc)))
+ ;; Insert the text, advancing the process marker.
+ ;;
+ (save-excursion
+ (goto-char (process-mark proc))
+ (insert string)
+ (set-marker (process-mark proc) (point)))
+ ;; Loop (more than one message might have arrived)
+ ;;
+ (unwind-protect
+ (let (done)
+ (while (not done)
+ (cond
+ ((not expected-bytes)
+ ;; Starting a new message
+ ;;
+ (setq expected-bytes
+ (and (search-forward-regexp
+ "\\(?:.*: .*\r\n\\)*Content-Length: \
+*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
+ (+ (point) 100)
+ t)
+ (string-to-number (match-string 1))))
+ (unless expected-bytes
+ (setq done :waiting-for-new-message)))
+ (t
+ ;; Attempt to complete a message body
+ ;;
+ (let ((available-bytes (- (position-bytes (process-mark
proc))
+ (position-bytes (point)))))
+ (cond
+ ((>= available-bytes
+ expected-bytes)
+ (let* ((message-end (byte-to-position
+ (+ (position-bytes (point))
+ expected-bytes))))
+ (unwind-protect
+ (save-restriction
+ (narrow-to-region (point) message-end)
+ (let* ((json-object-type 'plist)
+ (json-message (json-read)))
+ ;; Process content in another buffer,
+ ;; shielding buffer from tamper
+ ;;
+ (with-temp-buffer
+ (jrpc--process-receive proc json-message))))
+ (goto-char message-end)
+ (delete-region (point-min) (point))
+ (setq expected-bytes nil))))
+ (t
+ ;; Message is still incomplete
+ ;;
+ (setq done
:waiting-for-more-bytes-in-this-message))))))))
+ ;; Saved parsing state for next visit to this filter
+ ;;
+ (setf (jrpc--expected-bytes proc) expected-bytes))))))
+
+(defun jrpc-events-buffer (process &optional interactive)
+ "Display events buffer for current LSP connection PROCESS.
+INTERACTIVE is t if called interactively."
+ (interactive (list (jrpc-current-process-or-lose) t))
+ (let* ((probe (jrpc--events-buffer process))
+ (buffer (or (and (buffer-live-p probe)
+ probe)
+ (let ((buffer (get-buffer-create
+ (format "*%s events*"
+ (process-name process)))))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (read-only-mode t)
+ (setf (jrpc--events-buffer process) buffer))
+ buffer))))
+ (when interactive (display-buffer buffer))
+ buffer))
+
+(defun jrpc-log-event (proc message &optional type)
+ "Log an jrpc-related event.
+PROC is the current process. MESSAGE is a JSON-like plist. TYPE
+is a symbol saying if this is a client or server originated."
+ (with-current-buffer (jrpc-events-buffer proc)
+ (cl-destructuring-bind (&key method id error &allow-other-keys) message
+ (let* ((inhibit-read-only t)
+ (subtype (cond ((and method id) 'request)
+ (method 'notification)
+ (id 'reply)
+ (t 'message)))
+ (type
+ (format "%s-%s" (or type :internal) subtype)))
+ (goto-char (point-max))
+ (let ((msg (format "%s%s%s:\n%s\n"
+ type
+ (if id (format " (id:%s)" id) "")
+ (if error " ERROR" "")
+ (pp-to-string message))))
+ (when error
+ (setq msg (propertize msg 'face 'error)))
+ (insert-before-markers msg))))))
+
+(defun jrpc--process-receive (proc message)
+ "Process MESSAGE from PROC."
+ (cl-destructuring-bind (&key method id error &allow-other-keys) message
+ (let* ((continuations (and id
+ (not method)
+ (gethash id (jrpc--pending-continuations
proc)))))
+ (jrpc-log-event proc message 'server)
+ (when error (setf (jrpc-status proc) `(,error t)))
+ (cond (method
+ ;; a server notification or a server request
+ (let* ((handler-sym (intern (concat (jrpc--method-prefix proc)
+ method))))
+ (if (functionp handler-sym)
+ (apply handler-sym proc (append
+ (plist-get message :params)
+ (if id `(:id ,id))))
+ (jrpc-warn "No implementation of method %s yet" method)
+ (when id
+ (jrpc-reply
+ proc id
+ :error (jrpc-obj :code -32601
+ :message "Method unimplemented"))))))
+ (continuations
+ (cancel-timer (cl-third continuations))
+ (remhash id (jrpc--pending-continuations proc))
+ (if error
+ (apply (cl-second continuations) error)
+ (let ((res (plist-get message :result)))
+ (if (listp res)
+ (apply (cl-first continuations) res)
+ (funcall (cl-first continuations) res)))))
+ (id
+ (jrpc-warn "Ooops no continuation for id %s" id)))
+ (jrpc--call-deferred proc)
+ (force-mode-line-update t))))
+
+(defun jrpc-process-send (proc message)
+ "Send MESSAGE to PROC (ID is optional)."
+ (let ((json (json-encode message)))
+ (process-send-string proc (format "Content-Length: %d\r\n\r\n%s"
+ (string-bytes json)
+ json))
+ (jrpc-log-event proc message 'client)))
+
+(defvar jrpc--next-request-id 0)
+
+(defun jrpc--next-request-id ()
+ "Compute the next id for a client request."
+ (setq jrpc--next-request-id (1+ jrpc--next-request-id)))
+
+(defun jrpc-forget-pending-continuations (process)
+ "Stop waiting for responses from the current LSP PROCESS."
+ (interactive (list (jrpc-current-process-or-lose)))
+ (clrhash (jrpc--pending-continuations process)))
+
+(defun jrpc-clear-status (process)
+ "Clear most recent error message from PROCESS."
+ (interactive (list (jrpc-current-process-or-lose)))
+ (setf (jrpc-status process) nil))
+
+(defun jrpc--call-deferred (proc)
+ "Call PROC's deferred actions, who may again defer themselves."
+ (when-let ((actions (hash-table-values (jrpc--deferred-actions proc))))
+ (jrpc-log-event proc `(:running-deferred ,(length actions)))
+ (mapc #'funcall (mapcar #'car actions))))
+
+(defvar jrpc-ready-predicates '()
+ "Special hook of predicates controlling deferred actions.
+If one of these returns nil, a deferrable `jrpc-async-request'
+will be deferred. Each predicate is passed the symbol for the
+request request and a process object.")
+
+(cl-defmacro jrpc-lambda (cl-lambda-list &body body)
+ (declare (indent 1) (debug (sexp &rest form)))
+ `(cl-function (lambda ,cl-lambda-list ,@body)))
+
+(cl-defun jrpc-async-request (proc
+ method
+ params
+ &rest args
+ &key success-fn error-fn timeout-fn
+ (timeout jrpc-request-timeout)
+ (deferred nil))
+ "Make a request to PROCESS, expecting a reply.
+Return the ID of this request. Wait TIMEOUT seconds for response.
+If DEFERRED, maybe defer request to the future, or never at all,
+in case a new request with identical DEFERRED and for the same
+buffer overrides it. However, if that happens, the original
+timeout keeps counting."
+ (let* ((id (jrpc--next-request-id))
+ (existing-timer nil)
+ (make-timeout
+ (lambda ( )
+ (or existing-timer
+ (run-with-timer
+ timeout nil
+ (lambda ()
+ (remhash id (jrpc--pending-continuations proc))
+ (funcall (or timeout-fn
+ (lambda ()
+ (jrpc-error
+ "Tired of waiting for reply to %s, id=%s"
+ method id))))))))))
+ (when deferred
+ (let* ((buf (current-buffer))
+ (existing (gethash (list deferred buf) (jrpc--deferred-actions
proc))))
+ (when existing (setq existing-timer (cadr existing)))
+ (if (run-hook-with-args-until-failure 'jrpc-ready-predicates
+ deferred proc)
+ (remhash (list deferred buf) (jrpc--deferred-actions proc))
+ (jrpc-log-event proc `(:deferring ,method :id ,id :params ,params))
+ (let* ((buf (current-buffer)) (point (point))
+ (later (lambda ()
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (save-excursion (goto-char point)
+ (apply #'jrpc-async-request proc
+ method params args)))))))
+ (puthash (list deferred buf) (list later (funcall make-timeout))
+ (jrpc--deferred-actions proc))
+ (cl-return-from jrpc-async-request nil)))))
+ ;; Really run it
+ ;;
+ (puthash id
+ (list (or success-fn
+ (jrpc-lambda (&rest _ignored)
+ (jrpc-log-event
+ proc (jrpc-obj :message "success ignored" :id id))))
+ (or error-fn
+ (jrpc-lambda (&key code message &allow-other-keys)
+ (setf (jrpc-status proc) `(,message t))
+ proc (jrpc-obj :message "error ignored, status set"
+ :id id :error code)))
+ (funcall make-timeout))
+ (jrpc--pending-continuations proc))
+ (jrpc-process-send proc (jrpc-obj :jsonrpc "2.0"
+ :id id
+ :method method
+ :params params))))
+
+(defun jrpc-request (proc method params &optional deferred)
+ "Like `jrpc-async-request' for PROC, METHOD and PARAMS, but synchronous.
+Meaning only return locally if successful, otherwise exit non-locally.
+DEFERRED is passed to `jrpc-async-request', which see."
+ ;; Launching a deferred sync request with outstanding changes is a
+ ;; bad idea, since that might lead to the request never having a
+ ;; chance to run, because `jrpc-ready-predicates'.
+ (let* ((tag (cl-gensym "jrpc-request-catch-tag"))
+ (retval
+ (catch tag
+ (jrpc-async-request
+ proc method params
+ :success-fn (lambda (&rest args)
+ (throw tag
+ `(done ,(if (vectorp (car args))
+ (car args) args))))
+ :error-fn (jrpc-lambda (&key code message &allow-other-keys)
+ (throw tag
+ `(error ,(format "Oops: %s: %s" code
message))))
+ :timeout-fn (lambda ()
+ (throw tag
+ '(error "Timed out")))
+ :deferred deferred)
+ (while t (accept-process-output nil 30)))))
+ (when (eq 'error (car retval)) (jrpc-error (cadr retval)))
+ (cadr retval)))
+
+(cl-defun jrpc-notify (process method params)
+ "Notify PROCESS of something, don't expect a reply.e"
+ (jrpc-process-send process (jrpc-obj :jasonrpc "2.0"
+ :method method
+ :params params)))
+
+(cl-defun jrpc-reply (process id &key result error)
+ "Reply to PROCESS's request ID with MESSAGE."
+ (jrpc-process-send
+ process `(:jasonrpc "2.0" :id ,id
+ ,@(when result `(:result ,result))
+ ,@(when error `(:error ,error)))))
+
+(defun jrpc-mapply (fun seq)
+ "Apply FUN to every element of SEQ."
+ (mapcar (lambda (e) (apply fun e)) seq))
+
+(provide 'jrpc)
+;;; jrpc.el ends here
