(require 'flymake)
(require 'xref)
(require 'subr-x)
+(require 'jsonrpc)
(require 'filenotify)
+ (require 'ert)
\f
;;; User tweakable stuff
\f
;;; API (WORK-IN-PROGRESS!)
;;;
- (defmacro eglot--obj (&rest what)
- "Make WHAT a JSON object suitable for `json-encode'."
- (declare (debug (&rest form)))
- ;; FIXME: not really API. Should it be?
- ;; FIXME: maybe later actually do something, for now this just fixes
- ;; the indenting of literal plists.
- `(list ,@what))
+ (cl-defmacro eglot--with-live-buffer (buf &rest body)
+ "Check BUF live, then do BODY in it." (declare (indent 1) (debug t))
+ (let ((b (cl-gensym)))
+ `(let ((,b ,buf)) (if (buffer-live-p ,b) (with-current-buffer ,b ,@body)))))
+
+ (cl-defmacro eglot--lambda (cl-lambda-list &body body)
+ "Make a unary function of ARG, a plist-like JSON object.
+ CL-LAMBDA-LIST destructures ARGS before running BODY."
+ (declare (indent 1) (debug (sexp &rest form)))
+ (let ((e (gensym "eglot--lambda-elem")))
+ `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e))))
+
+ (cl-defmacro eglot--widening (&rest body)
+ "Save excursion and restriction. Widen. Then run BODY." (declare (debug t))
+ `(save-excursion (save-restriction (widen) ,@body)))
-(cl-defgeneric eglot-server-ready-p (server what) ;; API
- "Tell if SERVER is ready for WHAT in current buffer.
-If it isn't, a deferrable `eglot--async-request' *will* be
-deferred to the future.")
-
(cl-defgeneric eglot-handle-request (server method id &rest params)
"Handle SERVER's METHOD request with ID and PARAMS.")
:documentHighlight `(:dynamicRegistration :json-false)
:rename `(:dynamicRegistration :json-false)
:publishDiagnostics `(:relatedInformation :json-false))
- :experimental (eglot--obj))))
+ :experimental (list))))
-\f
-;;; Process management
-(defvar eglot--servers-by-project (make-hash-table :test #'equal)
- "Keys are projects. Values are lists of processes.")
-
-(defclass eglot-lsp-server ()
- ((process
- :documentation "Wrapped process object."
- :initarg :process :accessor eglot--process)
- (name
- :documentation "Readable name used for naming processes, buffers, etc..."
- :initarg :name :accessor eglot--name)
- (project-nickname
+(defclass eglot-lsp-server (jsonrpc-process-connection)
+ ((project-nickname
:documentation "Short nickname for the associated project."
:initarg :project-nickname :accessor eglot--project-nickname)
(major-mode
:documentation
"Represents a server. Wraps a process for LSP communication.")
-(cl-defmethod cl-print-object ((obj eglot-lsp-server) stream)
- (princ (format "#<%s: %s>" (eieio-object-class obj) (eglot--name obj)) stream))
+\f
+;;; Process management
+(defvar eglot--servers-by-project (make-hash-table :test #'equal)
+ "Keys are projects. Values are lists of processes.")
-(defun eglot--current-server ()
- "The current logical EGLOT process."
- (let* ((probe (or (project-current) `(transient . ,default-directory))))
- (cl-find major-mode (gethash probe eglot--servers-by-project)
- :key #'eglot--major-mode)))
+;; HACK: Do something to fix this in the jsonrpc API or here, but in
+;; the meantime concentrate the hack here.
+(defalias 'eglot--process 'jsonrpc--process
+ "An abuse of `jsonrpc--process', a jsonrpc.el internal.")
-(defun eglot--current-server-or-lose ()
- "Return the current EGLOT process or error."
- (or (eglot--current-server) (eglot--error "No current EGLOT process")))
-
-(defun eglot--make-process (name contact)
- "Make a process object from CONTACT.
-NAME is used to name the the started process or connection.
-CONTACT is in `eglot'. Returns a process object."
- (let* ((stdout (format "*%s stdout*" name)) stderr
- (proc (cond
- ((processp contact) contact)
- ((integerp (cadr contact))
- (apply #'open-network-stream name stdout contact))
- (t (make-process
- :name name :command contact :buffer stdout
- :coding 'no-conversion :connection-type 'pipe
- :stderr (setq stderr (format "*%s stderr*" name)))))))
- (process-put proc 'eglot-stderr stderr)
- (set-process-buffer proc (get-buffer-create stdout))
- (set-marker (process-mark proc) (with-current-buffer stdout (point-min)))
- (set-process-filter proc #'eglot--process-filter)
- (set-process-sentinel proc #'eglot--process-sentinel)
- (with-current-buffer stdout
- (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t)))
- proc))
+(defun eglot-shutdown (server &optional _interactive)
+ "Politely ask SERVER to quit.
+Forcefully quit it if it doesn't respond. Don't leave this
+function with the server still running."
+ (interactive (list (jsonrpc-current-connection-or-lose) t))
+ (eglot--message "Asking %s politely to terminate" (jsonrpc-name server))
+ (unwind-protect
+ (progn
- (setf (eglot--moribund server) t)
++ (setf (eglot--shutdown-requested server) t)
+ (jsonrpc-request server :shutdown nil :timeout 3)
+ ;; this one is supposed to always fail, hence ignore-errors
+ (ignore-errors (jsonrpc-request server :exit nil :timeout 1)))
+ ;; Turn off `eglot--managed-mode' where appropriate.
+ (dolist (buffer (eglot--managed-buffers server))
+ (with-current-buffer buffer (eglot--managed-mode-onoff server -1)))
- (when (process-live-p (eglot--process server))
- (eglot--warn "Brutally deleting non-compliant server %s" (jsonrpc-name server))
++ (while (progn (accept-process-output nil 0.1)
++ (not (eq (eglot--shutdown-requested server) :sentinel-done)))
++ (eglot--warn "Sentinel for %s still hasn't run, brutally deleting it!"
++ (eglot--process server))
+ (delete-process (eglot--process server)))))
+
+(defun eglot--on-shutdown (server)
+ "Called by jsonrpc.el when SERVER is already dead."
+ ;; Turn off `eglot--managed-mode' where appropriate.
+ (dolist (buffer (eglot--managed-buffers server))
+ (with-current-buffer buffer (eglot--managed-mode-onoff server -1)))
+ ;; Kill any expensive watches
+ (maphash (lambda (_id watches)
+ (mapcar #'file-notify-rm-watch watches))
+ (eglot--file-watches server))
- ;; Sever the project/process relationship for proc
++ ;; Sever the project/server relationship for `server'
+ (setf (gethash (eglot--project server) eglot--servers-by-project)
+ (delq server
+ (gethash (eglot--project server) eglot--servers-by-project)))
- (cond ((eglot--moribund server))
++ (cond ((eglot--shutdown-requested server)
++ (setf (eglot--shutdown-requested server) :sentinel-done))
+ ((not (eglot--inhibit-autoreconnect server))
+ (eglot--warn "Reconnecting after unexpected server exit.")
+ (eglot-reconnect server))
+ ((timerp (eglot--inhibit-autoreconnect server))
+ (eglot--warn "Not auto-reconnecting, last one didn't last long."))))
(defun eglot--all-major-modes ()
"Return all know major modes."
interactive
(y-or-n-p "[eglot] Live process found, reconnect instead? "))
(eglot-reconnect current-server interactive)
- (when live-p (eglot-shutdown current-server))
- (when (and current-server
- (process-live-p (eglot--process current-server)))
- (ignore-errors (eglot-shutdown current-server)))
++ (when live-p (ignore-errors (eglot-shutdown current-server)))
(let ((server (eglot--connect project
managed-major-mode
- command
- server-class)))
- (eglot--message "Connected! Server `%s' now \
+ (format "%s/%s" nickname managed-major-mode)
+ nickname
+ contact)))
+ (eglot--message "Connected! Process `%s' now \
managing `%s' buffers in project `%s'."
- (eglot--name server) managed-major-mode
- (eglot--project-nickname server))
+ (jsonrpc-name server) managed-major-mode
+ nickname)
server))))
(defun eglot-reconnect (server &optional interactive)
"Reconnect to SERVER.
INTERACTIVE is t if called interactively."
- (interactive (list (eglot--current-server-or-lose) t))
+ (interactive (list (jsonrpc-current-connection-or-lose) t))
(when (process-live-p (eglot--process server))
- (eglot-shutdown server interactive))
+ (ignore-errors (eglot-shutdown server interactive)))
(eglot--connect (eglot--project server)
(eglot--major-mode server)
- (eglot--contact server)
- (eieio-object-class server))
+ (jsonrpc-name server)
+ (eglot--project-nickname server)
+ (jsonrpc-contact server))
(eglot--message "Reconnected!"))
-(defun eglot--process-sentinel (proc change)
- "Called when PROC undergoes CHANGE."
- (let ((server (process-get proc 'eglot-server)))
- (eglot--debug server "Process state changed: %s" change)
- (when (not (process-live-p proc))
- (with-current-buffer (eglot-events-buffer server)
- (let ((inhibit-read-only t))
- (insert "\n----------b---y---e---b---y---e----------\n")))
- ;; Cancel outstanding timers and file system watches
- (maphash (lambda (_id triplet)
- (cl-destructuring-bind (_success _error timeout) triplet
- (cancel-timer timeout)))
- (eglot--pending-continuations server))
- (maphash (lambda (_id watches)
- (mapcar #'file-notify-rm-watch watches))
- (eglot--file-watches server))
- (unwind-protect
- ;; Call all outstanding error handlers
- (maphash (lambda (_id triplet)
- (cl-destructuring-bind (_success error _timeout) triplet
- (funcall error `(:code -1 :message "Server died"))))
- (eglot--pending-continuations server))
- ;; Turn off `eglot--managed-mode' where appropriate.
- (dolist (buffer (eglot--managed-buffers server))
- (with-current-buffer buffer (eglot--managed-mode-onoff server -1)))
- ;; Forget about the process-project relationship
- (setf (gethash (eglot--project server) eglot--servers-by-project)
- (delq server
- (gethash (eglot--project server) eglot--servers-by-project)))
- ;; Say last words
- (eglot--message "%s exited with status %s" (eglot--name server)
- (process-exit-status
- (eglot--process server)))
- (delete-process proc)
- ;; Consider autoreconnecting
- (cond ((eglot--shutdown-requested server)
- (setf (eglot--shutdown-requested server) :sentinel-done))
- ((not (eglot--inhibit-autoreconnect server))
- (eglot--warn "Reconnecting after unexpected server exit")
- (eglot-reconnect server))
- ((timerp (eglot--inhibit-autoreconnect server))
- (eglot--warn "Not auto-reconnecting, last on didn't last long.")))))))
-
-(defun eglot--process-filter (proc string)
- "Called when new data STRING has arrived for PROC."
- (eglot--with-live-buffer (process-buffer proc)
- (let ((expected-bytes (process-get proc 'eglot-expected-bytes))
- (inhibit-read-only t) done)
- ;; 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
- (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--server-receive
- (process-get proc 'eglot-server)
- 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
- ;;
- (process-put proc 'eglot-expected-bytes expected-bytes)))))
-
-(defun eglot-events-buffer (server &optional interactive)
- "Display events buffer for current LSP SERVER.
-INTERACTIVE is t if called interactively."
- (interactive (list (eglot--current-server-or-lose) t))
- (let* ((probe (eglot--events-buffer server))
- (buffer (or (and (buffer-live-p probe) probe)
- (let ((buffer (get-buffer-create
- (format "*%s events*"
- (eglot--name server)))))
- (with-current-buffer buffer
- (buffer-disable-undo)
- (read-only-mode t)
- (setf (eglot--events-buffer server) buffer))
- buffer))))
- (when interactive (display-buffer buffer))
- buffer))
-
-(defun eglot-stderr-buffer (server)
- "Pop to stderr of SERVER, if it exists, else error."
- (interactive (list (eglot--current-server-or-lose)))
- (if-let ((b (process-get (eglot--process server) 'eglot-stderr)))
- (pop-to-buffer b) (user-error "[eglot] No stderr buffer!")))
-
-(defun eglot--log-event (server message &optional type)
- "Log an eglot-related event.
-SERVER is the current server. 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 server)
- (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--server-receive (server message)
- "Process MESSAGE from SERVER."
- (cl-destructuring-bind (&key method id params error result _jsonrpc) message
- (let* ((continuations (and id
- (not method)
- (gethash id (eglot--pending-continuations server)))))
- (eglot--log-event server message 'server)
- (when error (setf (eglot--status server) `(,error t)))
- (unless (or (null method) (keywordp method))
- (setq method (intern (format ":%s" method))))
- (cond
- (method
- (condition-case-unless-debug _err
- (if id
- (apply #'eglot-handle-request server id method params)
- (apply #'eglot-handle-notification server method params))
- (cl-no-applicable-method
- (if id
- (eglot--reply
- server id :error `(:code -32601 :message "Method unimplemented"))
- (eglot--debug
- server '(:error `(:message "Notification unimplemented")))))))
- (continuations
- (cancel-timer (cl-third continuations))
- (remhash id (eglot--pending-continuations server))
- (if error
- (funcall (cl-second continuations) error)
- (funcall (cl-first continuations) result)))
- (id
- (eglot--warn "Ooops no continuation for id %s" id)))
- (eglot--call-deferred server)
+(defalias 'eglot-events-buffer 'jsonrpc-events-buffer)
+
+(defvar eglot-connect-hook nil "Hook run after connecting in `eglot--connect'.")
+
+(defun eglot--dispatch (server method id params)
+ "Dispatcher passed to `jsonrpc-connect'.
+Calls a function on SERVER, METHOD ID and PARAMS."
+ (let ((method (intern (format ":%s" method))))
+ (if id
+ (apply #'eglot-handle-request server id method params)
+ (apply #'eglot-handle-notification server method params)
(force-mode-line-update t))))
-(defun eglot--send (server message)
- "Send MESSAGE to SERVER (ID is optional)."
- (let ((json (json-encode message)))
- (process-send-string (eglot--process server)
- (format "Content-Length: %d\r\n\r\n%s"
- (string-bytes json) json))
- (eglot--log-event server message 'client)))
-
-(defun eglot-forget-pending-continuations (server)
- "Stop waiting for responses from the current LSP SERVER."
- (interactive (list (eglot--current-server-or-lose)))
- (clrhash (eglot--pending-continuations server)))
-
-(defun eglot-clear-status (server)
- "Clear most recent error message from SERVER."
- (interactive (list (eglot--current-server-or-lose)))
- (setf (eglot--status server) nil)
- (force-mode-line-update t))
-
-(defun eglot--call-deferred (server)
- "Call SERVER's deferred actions, who may again defer themselves."
- (when-let ((actions (hash-table-values (eglot--deferred-actions server))))
- (eglot--debug server `(:maybe-run-deferred ,(mapcar #'caddr actions)))
- (mapc #'funcall (mapcar #'car actions))))
-
-(defvar-local eglot--next-request-id 0 "ID for next `eglot--async-request'.")
-
-(cl-defun eglot--async-request (server
- method
- params
- &rest args
- &key success-fn error-fn timeout-fn
- (timeout eglot-request-timeout)
- (deferred nil))
- "Make a request to SERVER expecting a reply later on.
-SUCCESS-FN and ERROR-FN are passed `:result' and `:error'
-objects, respectively. Wait TIMEOUT seconds for response or call
-nullary TIMEOUT-FN. If DEFERRED, maybe defer request to the
-future, or to never at all, in case a new request with identical
-DEFERRED and for the same buffer overrides it (however, if that
-happens, the original timer keeps counting). Return (ID TIMER)."
- (pcase-let* ( (buf (current-buffer))
- (`(,_ ,timer ,old-id)
- (and deferred (gethash (list deferred buf)
- (eglot--deferred-actions server))))
- (id (or old-id (cl-incf eglot--next-request-id)))
- (make-timer
- (lambda ( )
- (run-with-timer
- timeout nil
- (lambda ()
- (remhash id (eglot--pending-continuations server))
- (if timeout-fn (funcall timeout-fn)
- (eglot--debug
- server `(:timed-out ,method :id ,id :params ,params))))))))
- (when deferred
- (if (eglot-server-ready-p server deferred)
- ;; Server is ready, we jump below and send it immediately.
- (remhash (list deferred buf) (eglot--deferred-actions server))
- ;; Otherwise, save in `eglot--deferred-actions' and exit non-locally
- (unless old-id
- ;; Also, if it's the first deferring for this id, inform the log
- (eglot--debug server `(:deferring ,method :id ,id :params ,params)))
- (puthash (list deferred buf)
- (list (lambda () (eglot--with-live-buffer buf
- (apply #'eglot--async-request server
- method params args)))
- (or timer (funcall make-timer)) id)
- (eglot--deferred-actions server))
- (cl-return-from eglot--async-request nil)))
- ;; Really send the request
- (eglot--send server `(:jsonrpc "2.0" :id ,id :method ,method :params ,params))
- (puthash id (list
- (or success-fn
- (eglot--lambda (&rest _ignored)
- (eglot--debug
- server `(:message "success ignored" :id ,id))))
- (or error-fn
- (eglot--lambda (&key code message &allow-other-keys)
- (setf (eglot--status server) `(,message t))
- server `(:message "error ignored, status set"
- :id ,id :error ,code)))
- (or timer (funcall make-timer)))
- (eglot--pending-continuations server))
- (list id timer)))
-
-(defun eglot--request (server method params &optional deferred)
- "Like `eglot--async-request' for SERVER, METHOD and PARAMS, but synchronous.
-Meaning only return locally if successful, otherwise exit non-locally.
-DEFERRED is passed to `eglot--async-request', which see."
- ;; HACK: 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 idle timers don't run in `accept-process-output'.
- (when deferred (eglot--signal-textDocument/didChange))
- (let* ((done (make-symbol "eglot-catch")) id-and-timer
- (res
- (unwind-protect
- (catch done
- (setq
- id-and-timer
- (eglot--async-request
- server method params
- :success-fn (lambda (result) (throw done `(done ,result)))
- :timeout-fn (lambda () (throw done '(error "Timed out")))
- :error-fn (eglot--lambda (&key code message _data)
- (throw done `(error
- ,(format "Ooops: %s: %s" code message))))
- :deferred deferred))
- (while t (accept-process-output nil 30)))
- (pcase-let ((`(,id ,timer) id-and-timer))
- (when id (remhash id (eglot--pending-continuations server)))
- (when timer (cancel-timer timer))))))
- (when (eq 'error (car res)) (eglot--error (cadr res)))
- (cadr res)))
-
-(cl-defun eglot--notify (server method params)
- "Notify SERVER of something, don't expect a reply.e"
- (eglot--send server `(:jsonrpc "2.0" :method ,method :params ,params)))
-
-(cl-defun eglot--reply (server id &key result error)
- "Reply to PROCESS's request ID with MESSAGE."
- (eglot--send
- server `(:jsonrpc "2.0" :id ,id
- ,@(when result `(:result ,result))
- ,@(when error `(:error ,error)))))
+(defun eglot--connect (project managed-major-mode name nickname contact)
+ "Connect to PROJECT, MANAGED-MAJOR-MODE, NAME.
+And NICKNAME and CONTACT."
+ (let* ((contact (if (functionp contact) (funcall contact) contact))
+ (server
+ (jsonrpc-connect name contact #'eglot--dispatch #'eglot--on-shutdown))
+ success)
+ (setf (eglot--project server) project)
+ (setf (eglot--project-nickname server) nickname)
+ (setf (eglot--major-mode server) managed-major-mode)
+ (push server (gethash project eglot--servers-by-project))
+ (run-hook-with-args 'eglot-connect-hook server)
+ (unwind-protect
+ (cl-destructuring-bind (&key capabilities)
+ (jsonrpc-request
+ server
+ :initialize
- (jsonrpc-obj :processId (unless (eq (process-type
- (eglot--process server))
- 'network)
- (emacs-pid))
- :rootPath (expand-file-name
- (car (project-roots project)))
- :rootUri (eglot--path-to-uri
- (car (project-roots project)))
- :initializationOptions (eglot-initialization-options server)
- :capabilities (eglot-client-capabilities server)))
++ (list :processId (unless (eq (process-type
++ (eglot--process server))
++ 'network)
++ (emacs-pid))
++ :rootPath (expand-file-name
++ (car (project-roots project)))
++ :rootUri (eglot--path-to-uri
++ (car (project-roots project)))
++ :initializationOptions (eglot-initialization-options server)
++ :capabilities (eglot-client-capabilities server)))
+ (setf (eglot--capabilities server) capabilities)
+ (setf (jsonrpc-status server) nil)
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (eglot--maybe-activate-editing-mode server)))
- (jsonrpc-notify server :initialized (jsonrpc-obj :__dummy__ t))
++ (jsonrpc-notify server :initialized `(:__dummy__ t))
+ (setf (eglot--inhibit-autoreconnect server)
+ (cond
+ ((booleanp eglot-autoreconnect) (not eglot-autoreconnect))
+ ((cl-plusp eglot-autoreconnect)
+ (run-with-timer eglot-autoreconnect nil
+ (lambda ()
+ (setf (eglot--inhibit-autoreconnect server)
+ (null eglot-autoreconnect)))))))
+ (setq success server))
- (unless (or success (not (process-live-p (eglot--process server)))
- (eglot--moribund server))
++ (unless (or success (not (process-live-p (eglot--process server))))
+ (eglot-shutdown server)))))
\f
- ;;; Helpers
+ ;;; Helpers (move these to API?)
;;;
(defun eglot--error (format &rest args)
"Error out with FORMAT with ARGS."
nil nil eglot-mode-map
(cond
(eglot--managed-mode
- (add-hook 'jsonrpc-ready-predicates 'eglot--server-ready-p nil t)
+ (add-hook 'jsonrpc-find-connection-functions 'eglot--find-current-server 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)
#'eglot-eldoc-function)
(add-function :around (local imenu-create-index-function) #'eglot-imenu))
(t
- (remove-hook 'jsonrpc-ready-predicates 'eglot--server-ready-p t)
+ (remove-hook 'jsonrpc-find-connection-functions 'eglot--find-current-server 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)
(add-hook 'eglot--managed-mode-hook 'flymake-mode)
(add-hook 'eglot--managed-mode-hook 'eldoc-mode)
- (defvar-local eglot--current-flymake-report-fn nil
- "Current flymake report function for this buffer")
-
+(defun eglot--find-current-server ()
+ "Find the current logical EGLOT server."
+ (let* ((probe (or (project-current) `(transient . ,default-directory))))
+ (cl-find major-mode (gethash probe eglot--servers-by-project)
+ :key #'eglot--major-mode)))
+
(defun eglot--maybe-activate-editing-mode (&optional server)
"Maybe activate mode function `eglot--managed-mode'.
If SERVER is supplied, do it only if BUFFER is managed by it. In
(defun eglot--mode-line-format ()
"Compose the EGLOT's mode-line."
- (pcase-let* ((server (eglot--current-server))
- (name (and
- server
- (eglot--project-nickname server)))
+ (pcase-let* ((server (jsonrpc-current-connection))
+ (nick (and server (eglot--project-nickname server)))
(pending (and server (hash-table-count
- (eglot--pending-continuations server))))
+ (jsonrpc--request-continuations server))))
(`(,_id ,doing ,done-p ,detail) (and server (eglot--spinner server)))
- (`(,status ,serious-p) (and server (eglot--status server))))
+ (`(,status ,serious-p) (and server (jsonrpc-status server))))
(append
`(,(eglot--mode-line-props "eglot" 'eglot-mode-line nil))
- (when name
+ (when nick
`(":" ,(eglot--mode-line-props
- nick'eglot-mode-line
- '((mouse-1 eglot-events-buffer "go to events buffer")
- name 'eglot-mode-line
- '((C-mouse-1 eglot-stderr-buffer "go to stderr buffer")
++ nick 'eglot-mode-line
++ '((C-mouse-1 jsonrpc-stderr-buffer "go to stderr buffer")
+ (mouse-1 eglot-events-buffer "go to events buffer")
(mouse-2 eglot-shutdown "quit server")
(mouse-3 eglot-reconnect "reconnect to server")))
,@(when serious-p
`("/" ,(eglot--mode-line-props
"error" 'compilation-mode-line-fail
- '((mouse-1 eglot-events-buffer "go to events buffer")
- (mouse-3 jsonrpc-clear-status "clear this status"))
- '((mouse-3 eglot-clear-status "clear this status"))
++ '((mouse-3 jsonrpc-clear-status "clear this status"))
(format "An error occured: %s\n" status))))
,@(when (and doing (not done-p))
`("/" ,(eglot--mode-line-props
(format "%s%s" doing
(if detail (format ":%s" detail) ""))
- 'compilation-mode-line-run
- '((mouse-1 eglot-events-buffer "go to events buffer")))))
+ 'compilation-mode-line-run '())))
,@(when (cl-plusp pending)
`("/" ,(eglot--mode-line-props
- (format "%d" pending) 'warning
- '((mouse-3 eglot-forget-pending-continuations
- "forget these continuations"))
- (format "%d pending requests\n" pending)))))))))
+ (format "%d oustanding requests" pending) 'warning
- '((mouse-1 eglot-events-buffer "go to events buffer")
- (mouse-3 jsonrpc-forget-pending-continuations
++ '((mouse-3 jsonrpc-forget-pending-continuations
+ "fahgettaboudit"))))))))))
(add-to-list 'mode-line-misc-info
`(eglot--managed-mode (" [" eglot--mode-line-format "] ")))
'("OK"))
nil t (plist-get (elt actions 0) :title)))
(if reply
- (jsonrpc-reply server id :result (jsonrpc-obj :title reply))
- (eglot--reply server id :result `(:title ,reply))
- (eglot--reply server id
- :error `(:code -32800 :message "User cancelled"))))))
++ (jsonrpc-reply server id :result `(:title ,reply))
+ (jsonrpc-reply server id
- :error (jsonrpc-obj :code -32800
- :message "User cancelled"))))))
++ :error `(:code -32800 :message "User cancelled"))))))
(cl-defmethod eglot-handle-notification
(_server (_method (eql :window/logMessage)) &key _type _message)
(funcall eglot--current-flymake-report-fn diags)
(setq eglot--unreported-diagnostics nil))
(t
- (setq eglot--unreported-diagnostics diags)))))
- (eglot--warn "Diagnostics received for unvisited %s" uri)))
+ (setq eglot--unreported-diagnostics (cons t diags))))))
- (eglot--debug server "Diagnostics received for unvisited %s" uri)))
++ (jsonrpc--debug server "Diagnostics received for unvisited %s" uri)))
(cl-defun eglot--register-unregister (server jsonrpc-id things how)
"Helper for `registerCapability'.
server :id id registerOptions))
(unless (eq t (car retval))
(cl-return-from eglot--register-unregister
- (eglot--reply
+ (jsonrpc-reply
server jsonrpc-id
:error `(:code -32601 :message ,(or (cadr retval) "sorry")))))))))
- (jsonrpc-reply server jsonrpc-id :result (jsonrpc-obj :message "OK")))
- (eglot--reply server jsonrpc-id :result `(:message "OK")))
++ (jsonrpc-reply server jsonrpc-id :result `(:message "OK")))
(cl-defmethod eglot-handle-request
(server id (_method (eql :client/registerCapability)) &key registrations)
"Handle server request workspace/applyEdit"
(condition-case err
(progn (eglot--apply-workspace-edit edit 'confirm)
- (eglot--reply server id :result `(:applied )))
- (error (eglot--reply server id
- :result `(:applied :json-false)
- :error `(:code -32001 :message ,(format "%s" err))))))
+ (jsonrpc-reply server id :result `(:applied )))
+ (error (jsonrpc-reply server id
+ :result `(:applied :json-false)
- :error (eglot--obj :code -32001
- :message (format "%s" err))))))
++ :error `(:code -32001 :message (format "%s" ,err))))))
(defun eglot--TextDocumentIdentifier ()
"Compute TextDocumentIdentifier object for current buffer."
- (jsonrpc-obj :uri (eglot--path-to-uri buffer-file-name)))
- (list :uri (eglot--path-to-uri buffer-file-name)))
++ `(:uri ,(eglot--path-to-uri buffer-file-name)))
(defvar-local eglot--versioned-identifier 0)
(defvar-local eglot--recent-changes nil
"Recent buffer changes as collected by `eglot--before-change'.")
- (defun eglot--outstanding-edits-p ()
- "Non-nil if there are outstanding edits."
- (cl-plusp (+ (length (car eglot--recent-changes))
- (length (cdr eglot--recent-changes)))))
-
-(defmethod eglot-server-ready-p (_s _what)
- "Normally ready if no outstanding changes." (not eglot--recent-changes))
+(cl-defmethod jsonrpc-connection-ready-p ((_server eglot-lsp-server) _what)
- "Tell if SERVER is ready for WHAT in current buffer.
- If it isn't, a deferrable `eglot--async-request' *will* be
- deferred to the future."
- (and (cl-call-next-method)
- (not (eglot--outstanding-edits-p))))
++ "Tell if SERVER is ready for WHAT in current buffer."
++ (and (cl-call-next-method) (not eglot--recent-changes)))
+
+ (defvar-local eglot--change-idle-timer nil "Idle timer for didChange signals.")
(defun eglot--before-change (start end)
"Hook onto `before-change-functions'.
"Hook onto `after-change-functions'.
Records START, END and PRE-CHANGE-LENGTH locally."
(cl-incf eglot--versioned-identifier)
- (setf (cdr eglot--recent-changes)
- (vconcat (cdr eglot--recent-changes)
- `[(,pre-change-length
- ,(buffer-substring-no-properties start end))])))
+ (if (and (listp eglot--recent-changes)
+ (null (cddr (car eglot--recent-changes))))
+ (setf (cddr (car eglot--recent-changes))
+ `(,pre-change-length ,(buffer-substring-no-properties start end)))
+ (setf eglot--recent-changes :emacs-messup))
+ (when eglot--change-idle-timer (cancel-timer eglot--change-idle-timer))
+ (let ((buf (current-buffer)))
+ (setq eglot--change-idle-timer
+ (run-with-idle-timer
+ 0.5 nil (lambda () (eglot--with-live-buffer buf
+ (when eglot--managed-mode
+ (eglot--signal-textDocument/didChange)
+ (setq eglot--change-idle-timer nil))))))))
- ;; chance to run, because `jsonrpc-ready-predicates'.
+;; HACK! 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 `jsonrpc-connection-ready-p'.
+(advice-add #'jsonrpc-request :before
+ (cl-function (lambda (_proc _method _params &key deferred _timeout)
+ (when (and eglot--managed-mode deferred)
+ (eglot--signal-textDocument/didChange))))
+ '((name . eglot--signal-textDocument/didChange)))
+
(defun eglot--signal-textDocument/didChange ()
"Send textDocument/didChange to server."
- (when (eglot--outstanding-edits-p)
+ (when eglot--recent-changes
- (let* ((server (eglot--current-server-or-lose))
+ (let* ((server (jsonrpc-current-connection-or-lose))
(sync-kind (eglot--server-capable :textDocumentSync))
- (emacs-messup (/= (length (car eglot--recent-changes))
- (length (cdr eglot--recent-changes))))
- (full-sync-p (or (eq sync-kind 1) emacs-messup)))
- (when emacs-messup
- (eglot--warn "`eglot--recent-changes' messup: %s" eglot--recent-changes))
- (save-restriction
- (widen)
- (jsonrpc-notify
- server :textDocument/didChange
- (jsonrpc-obj
- :textDocument
- (eglot--VersionedTextDocumentIdentifier)
- :contentChanges
- (if full-sync-p (vector
- (jsonrpc-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 `[,(jsonrpc-obj :range (jsonrpc-obj :start start-pos
- :end end-pos)
- :rangeLength len
- :text after-text)])))))
- (setq eglot--recent-changes (cons [] []))
+ (full-sync-p (or (eq sync-kind 1)
+ (eq :emacs-messup eglot--recent-changes))))
- (eglot--notify
++ (jsonrpc-notify
+ server :textDocument/didChange
+ (list
+ :textDocument (eglot--VersionedTextDocumentIdentifier)
+ :contentChanges
+ (if full-sync-p
+ (vector `(:text ,(eglot--widening
+ (buffer-substring-no-properties (point-min)
+ (point-max)))))
+ (cl-loop for (beg end len text) in (reverse eglot--recent-changes)
+ vconcat `[,(list :range `(:start ,beg :end ,end)
+ :rangeLength len :text text)]))))
-
+ (setq eglot--recent-changes nil)
(setf (eglot--spinner server) (list nil :textDocument/didChange t))
- ;; HACK! perhaps jsonrpc should just call this on every send
- (eglot--call-deferred server))))
+ (jsonrpc--call-deferred server))))
(defun eglot--signal-textDocument/didOpen ()
"Send textDocument/didOpen to server."
- (setq eglot--recent-changes (cons [] []))
+ (setq eglot--recent-changes nil eglot--versioned-identifier 0)
- (eglot--notify
- (eglot--current-server-or-lose)
+ (jsonrpc-notify
+ (jsonrpc-current-connection-or-lose)
:textDocument/didOpen `(:textDocument ,(eglot--TextDocumentItem))))
(defun eglot--signal-textDocument/didClose ()
(defun eglot--signal-textDocument/didSave ()
"Send textDocument/didSave to server."
- (eglot--notify
- (eglot--current-server-or-lose)
+ (jsonrpc-notify
+ (jsonrpc-current-connection-or-lose)
:textDocument/didSave
- (jsonrpc-obj
+ (list
;; TODO: Handle TextDocumentSaveRegistrationOptions to control this.
:text (buffer-substring-no-properties (point-min) (point-max))
:textDocument (eglot--TextDocumentIdentifier))))
(lambda (string)
(setq eglot--xref-known-symbols
(mapcar
- (eglot--lambda (&key name kind location containerName)
+ (jsonrpc-lambda
+ (&key name kind location containerName)
(propertize name
:textDocumentPositionParams
- (jsonrpc-obj :textDocument text-id
- :position (plist-get
- (plist-get location :range)
- :start))
+ (list :textDocument text-id
+ :position (plist-get
+ (plist-get location :range)
+ :start))
:locations (list location)
:kind kind
:containerName containerName))
- (eglot--request
- server :textDocument/documentSymbol `(:textDocument ,text-id))))
+ (jsonrpc-request server
+ :textDocument/documentSymbol
- (jsonrpc-obj
- :textDocument text-id))))
++ `(:textDocument ,text-id))))
(all-completions string eglot--xref-known-symbols))))))
(cl-defmethod xref-backend-identifier-at-point ((_backend (eql eglot)))
(and rich (get-text-property 0 :textDocumentPositionParams rich))))))
(unless params
(eglot--error "Don' know where %s is in the workspace!" identifier))
- (mapcar (eglot--lambda (&key uri range)
- (eglot--xref-make identifier uri (plist-get range :start)))
- (eglot--request (eglot--current-server-or-lose)
- :textDocument/references
- (append
- params
- `(:context (:includeDeclaration t)))))))
+ (mapcar
+ (jsonrpc-lambda (&key uri range)
+ (eglot--xref-make identifier uri (plist-get range :start)))
+ (jsonrpc-request (jsonrpc-current-connection-or-lose)
+ :textDocument/references
+ (append
+ params
- (jsonrpc-obj :context
- (jsonrpc-obj :includeDeclaration t)))))))
++ (list :context
++ (list :includeDeclaration t)))))))
(cl-defmethod xref-backend-apropos ((_backend (eql eglot)) pattern)
(when (eglot--server-capable :workspaceSymbolProvider)
- (mapcar (eglot--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-server-or-lose)
- :workspace/symbol
- (list :query pattern)))))
+ (mapcar
+ (jsonrpc-lambda (&key name location &allow-other-keys)
+ (cl-destructuring-bind (&key uri range) location
+ (eglot--xref-make name uri (plist-get range :start))))
+ (jsonrpc-request (jsonrpc-current-connection-or-lose)
+ :workspace/symbol
- (jsonrpc-obj :query pattern)))))
++ `(:query ,pattern)))))
(defun eglot-completion-at-point ()
"EGLOT's `completion-at-point' function."
(defvar eglot--highlights nil "Overlays for textDocument/documentHighlight.")
(defun eglot--hover-info (contents &optional range)
- (concat (and range (pcase-let ((`(,beg ,end) (eglot--range-region range)))
- (concat (and range (pcase-let ((`(,beg . ,end) (eglot--range-region range)))
-- (concat (buffer-substring beg end) ": ")))
-- (mapconcat #'eglot--format-markup
-- (append (cond ((vectorp contents) contents)
-- (contents (list contents)))) "\n")))
++ (let ((heading (and range (pcase-let ((`(,beg . ,end) (eglot--range-region range)))
++ (concat (buffer-substring beg end) ": "))))
++ (body (mapconcat #'eglot--format-markup
++ (append (cond ((vectorp contents) contents)
++ ((stringp contents) (list contents)))) "\n")))
++ (when (or heading (cl-plusp (length body))) (concat heading body))))
(defun eglot--sig-info (sigs active-sig active-param)
(cl-loop
"Request \"hover\" information for the thing at point."
(interactive)
(cl-destructuring-bind (&key contents range)
- (eglot--request (eglot--current-server-or-lose) :textDocument/hover
- (eglot--TextDocumentPositionParams))
+ (jsonrpc-request (jsonrpc-current-connection-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
- (insert (eglot--hover-info contents range))))))
+ (let ((blurb (eglot--hover-info contents range)))
+ (with-help-window "*eglot help*"
+ (with-current-buffer standard-output (insert blurb))))))
(defun eglot-eldoc-function ()
"EGLOT's `eldoc-documentation-function' function.
(position-params (eglot--TextDocumentPositionParams))
sig-showing)
(cl-macrolet ((when-buffer-window
- (&body body) `(when (get-buffer-window buffer)
- (with-current-buffer buffer ,@body))))
- (&body body)
++ (&body body) ; notice the exception when testing with `ert'
+ `(when (or (get-buffer-window buffer) (ert-running-test))
+ (with-current-buffer buffer ,@body))))
(when (eglot--server-capable :signatureHelpProvider)
- (eglot--async-request
+ (jsonrpc-async-request
server :textDocument/signatureHelp position-params
- :success-fn (eglot--lambda (&key signatures activeSignature
- activeParameter)
- (when-buffer-window
- (when (cl-plusp (length signatures))
- (setq sig-showing t)
- (eldoc-message (eglot--sig-info signatures
- activeSignature
- activeParameter)))))
+ :success-fn
+ (jsonrpc-lambda (&key signatures activeSignature
+ activeParameter)
+ (when-buffer-window
+ (when (cl-plusp (length signatures))
+ (setq sig-showing t)
+ (eldoc-message (eglot--sig-info signatures
+ activeSignature
+ activeParameter)))))
:deferred :textDocument/signatureHelp))
(when (eglot--server-capable :hoverProvider)
- (eglot--async-request
+ (jsonrpc-async-request
server :textDocument/hover position-params
- :success-fn (eglot--lambda (&key contents range)
+ :success-fn (jsonrpc-lambda (&key contents range)
(unless sig-showing
- ;; for eglot-tests.el's sake, set this unconditionally
- (setq eldoc-last-message
- (eglot--hover-info contents range))
- (when-buffer-window (eldoc-message eldoc-last-message))))
+ (when-buffer-window
- (eldoc-message (eglot--hover-info contents range)))))
++ (when-let (info (eglot--hover-info contents range))
++ (eglot--message "OK so info is %S and %S" info (null info))
++ (eldoc-message info)))))
:deferred :textDocument/hover))
(when (eglot--server-capable :documentHighlightProvider)
- (eglot--async-request
+ (jsonrpc-async-request
server :textDocument/documentHighlight position-params
- :success-fn (lambda (highlights)
- (mapc #'delete-overlay eglot--highlights)
- (setq eglot--highlights
- (when-buffer-window
- (mapcar (eglot--lambda (&key range _kind _role)
- (pcase-let ((`(,beg . ,end)
- (eglot--range-region range)))
- (let ((ov (make-overlay beg end)))
- (overlay-put ov 'face 'highlight)
- (overlay-put ov 'evaporate t)
- ov)))
- highlights))))
+ :success-fn
+ (lambda (highlights)
+ (mapc #'delete-overlay eglot--highlights)
+ (setq eglot--highlights
+ (when-buffer-window
+ (mapcar
- (jsonrpc-lambda (&key range _kind)
++ (jsonrpc-lambda (&key range _kind _role)
+ (pcase-let ((`(,beg ,end)
+ (eglot--range-region range)))
+ (let ((ov (make-overlay beg end)))
+ (overlay-put ov 'face 'highlight)
+ (overlay-put ov 'evaporate t)
+ ov)))
+ highlights))))
:deferred :textDocument/documentHighlight))))
nil)
(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-server-or-lose)
- :textDocument/documentSymbol
- `(:textDocument ,(eglot--TextDocumentIdentifier))))))
+ (jsonrpc-request (jsonrpc-current-connection-or-lose)
+ :textDocument/documentSymbol
- (jsonrpc-obj
- :textDocument (eglot--TextDocumentIdentifier))))))
++ `(:textDocument ,(eglot--TextDocumentIdentifier))))))
(append
(seq-group-by (lambda (e) (get-text-property 0 :kind (car e)))
entries)
(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))
- (save-restriction
- (widen)
- (save-excursion
- (mapc (jsonrpc-lambda (newText beg end)
- (goto-char beg) (delete-region beg end) (insert newText))
- (mapcar (jsonrpc-lambda (&key range newText)
- (cons newText (eglot--range-region range 'markers)))
- edits))))
+ (eglot--widening
+ (mapc (pcase-lambda (`(,newText ,beg . ,end))
+ (goto-char beg) (delete-region beg end) (insert newText))
- (mapcar (eglot--lambda (&key range newText)
++ (mapcar (jsonrpc-lambda (&key range newText)
+ (cons newText (eglot--range-region range 'markers)))
+ edits)))
(eglot--message "%s: Performed %s edits" (current-buffer) (length edits)))
(defun eglot--apply-workspace-edit (wedit &optional confirm)
"Apply the workspace edit WEDIT. If CONFIRM, ask user first."
- (let (prepared)
- (cl-destructuring-bind (&key changes documentChanges)
- wedit
- (cl-loop
- for change on documentChanges
- do (push (cl-destructuring-bind (&key textDocument edits) change
- (cl-destructuring-bind (&key uri version) textDocument
- (list (eglot--uri-to-path uri) edits version)))
- prepared))
+ (cl-destructuring-bind (&key changes documentChanges) wedit
+ (let ((prepared
- (mapcar (eglot--lambda (&key textDocument edits)
++ (mapcar (jsonrpc-lambda (&key textDocument edits)
+ (cl-destructuring-bind (&key uri version) textDocument
+ (list (eglot--uri-to-path uri) edits version)))
+ documentChanges)))
(cl-loop for (uri edits) on changes by #'cddr
- do (push (list (eglot--uri-to-path uri) edits) prepared)))
- (if (or confirm
- (cl-notevery #'find-buffer-visiting
- (mapcar #'car prepared)))
- (unless (y-or-n-p
- (format "[eglot] Server requests to edit %s files.\n %s\n\
- Proceed? "
- (length prepared)
- (mapconcat #'identity
- (mapcar #'car prepared)
- "\n ")))
- (eglot--error "User cancelled server edit")))
- (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--message "Edit successful!")))))
+ do (push (list (eglot--uri-to-path uri) edits) prepared))
+ (if (or confirm
+ (cl-notevery #'find-buffer-visiting
+ (mapcar #'car prepared)))
+ (unless (y-or-n-p
+ (format "[eglot] Server wants to edit:\n %s\n Proceed? "
+ (mapconcat #'identity (mapcar #'car prepared) "\n ")))
+ (eglot--error "User cancelled server edit")))
+ (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--message "Edit successful!"))))))
(defun eglot-rename (newname)
"Rename the current symbol to NEWNAME."
(unless (eglot--server-capable :renameProvider)
(eglot--error "Server can't rename!"))
(eglot--apply-workspace-edit
- (eglot--request (eglot--current-server-or-lose)
- :textDocument/rename `(,@(eglot--TextDocumentPositionParams)
- :newName ,newname))
+ (jsonrpc-request (jsonrpc-current-connection-or-lose)
+ :textDocument/rename `(,@(eglot--TextDocumentPositionParams)
- ,@(jsonrpc-obj :newName newname)))
++ :newName ,newname))
current-prefix-arg))
\f
projects / emacs.git / commitdiff