From: João Távora Date: Wed, 30 May 2018 15:27:30 +0000 (+0100) Subject: Merge master into jsonrpc-refactor (using imerge) X-Git-Tag: emacs-29.0.90~1616^2~524^2~4^2~489^2~12 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=97b07351560ce5c7416c3cbaec6924d12ac6c84a;p=emacs.git Merge master into jsonrpc-refactor (using imerge) --- 97b07351560ce5c7416c3cbaec6924d12ac6c84a diff --cc lisp/progmodes/eglot.el index ccb7b4908ae,cc5649fa382..31ef081bd07 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@@ -59,8 -59,8 +59,9 @@@ (require 'flymake) (require 'xref) (require 'subr-x) +(require 'jsonrpc) (require 'filenotify) + (require 'ert) ;;; User tweakable stuff @@@ -112,14 -118,27 +115,22 @@@ lasted more than that many seconds. ;;; 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.") @@@ -153,10 -172,21 +164,10 @@@ :documentHighlight `(:dynamicRegistration :json-false) :rename `(:dynamicRegistration :json-false) :publishDiagnostics `(:relatedInformation :json-false)) - :experimental (eglot--obj)))) + :experimental (list)))) - -;;; 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 @@@ -186,54 -232,40 +197,57 @@@ :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)) + +;;; 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." @@@ -340,92 -410,343 +354,91 @@@ INTERACTIVE is t if called interactivel 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))))) - ;;; Helpers + ;;; Helpers (move these to API?) ;;; (defun eglot--error (format &rest args) "Error out with FORMAT with ARGS." @@@ -515,8 -849,6 +536,7 @@@ If optional MARKERS, make markers. nil nil eglot-mode-map (cond (eglot--managed-mode + (add-hook 'jsonrpc-find-connection-functions 'eglot--find-current-server nil t) - (add-hook 'jsonrpc-ready-predicates 'eglot--server-ready-p 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) @@@ -530,8 -862,6 +550,7 @@@ #'eglot-eldoc-function) (add-function :around (local imenu-create-index-function) #'eglot-imenu)) (t + (remove-hook 'jsonrpc-find-connection-functions 'eglot--find-current-server t) - (remove-hook 'jsonrpc-ready-predicates 'eglot--server-ready-p 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) @@@ -557,15 -888,6 +577,12 @@@ (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 @@@ -612,38 -931,39 +627,36 @@@ Uses THING, FACE, DEFS and PREPEND. (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 "] "))) @@@ -674,10 -1015,9 +687,9 @@@ '("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) @@@ -712,8 -1052,8 +724,8 @@@ (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'. @@@ -726,10 -1066,10 +738,10 @@@ THINGS are either registrations or unre 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) @@@ -747,15 -1087,14 +759,14 @@@ "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) @@@ -785,17 -1123,10 +795,11 @@@ (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'. @@@ -812,58 -1143,49 +816,57 @@@ were deleted/added) "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)))))))) +;; 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-ready-predicates'. ++;; 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 () @@@ -885,10 -1208,10 +888,10 @@@ (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)))) @@@ -934,21 -1255,18 +935,20 @@@ DUMMY is ignored (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))) @@@ -980,25 -1298,22 +980,25 @@@ (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." @@@ -1055,11 -1370,11 +1055,12 @@@ (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 @@@ -1087,12 -1402,12 +1088,12 @@@ "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. @@@ -1102,48 -1417,44 +1103,49 @@@ If SKIP-SIGNATURE, don't try to send te (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) @@@ -1157,10 -1467,9 +1159,9 @@@ (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) @@@ -1172,51 -1481,40 +1173,40 @@@ (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." @@@ -1225,9 -1523,9 +1215,9 @@@ (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))