From: João Távora Date: Fri, 22 Jun 2018 15:44:09 +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 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=c45e4a916a3978e0a6c614e3f5420e592ae86658;p=emacs.git Merge master into jsonrpc-refactor (using imerge) --- c45e4a916a3978e0a6c614e3f5420e592ae86658 diff --cc lisp/progmodes/eglot.el index 0a060a53e9f,f4a03da7e6c..290e80b5bdb --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@@ -86,8 -87,10 +88,10 @@@ (php-mode . ("php" "vendor/felixfbecker/\ language-server/bin/php-language-server.php"))) "How the command `eglot' guesses the server to start. - An association list of (MAJOR-MODE . CONTACT) pair. MAJOR-MODE - is a mode symbol. CONTACT is: -An association list of (MAJOR-MODE . SPEC) pair. MAJOR-MODE is a -mode symbol, or a list of mode symbols. The associated SPEC -specifies how to start a server for managing buffers of those -modes. SPEC can be: ++An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE ++is a mode symbol, or a list of mode symbols. The associated ++CONTACT specifies how to start a server for managing buffers of ++those modes. CONTACT can be: * In the most common case, a list of strings (PROGRAM [ARGS...]). PROGRAM is called with ARGS and is expected to serve LSP requests @@@ -205,51 -246,40 +210,51 @@@ lasted more than that many seconds. :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)) - -(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))) + +;;; Process management +(defvar eglot--servers-by-project (make-hash-table :test #'equal) + "Keys are projects. Values are lists of processes.") - (defun eglot-shutdown (server &optional _interactive) -(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 'utf-8-emacs-unix :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 timeout) + "Politely ask SERVER to quit. - Forcefully quit it if it doesn't respond. Don't leave this - function with the server still running." ++Forcefully quit it if it doesn't respond within TIMEOUT seconds. ++Don't leave this function with the server still running." + (interactive (list (eglot--current-server-or-lose) t)) + (eglot--message "Asking %s politely to terminate" (jsonrpc-name server)) + (unwind-protect + (progn + (setf (eglot--shutdown-requested server) t) - (jsonrpc-request server :shutdown nil :timeout 3) ++ (jsonrpc-request server :shutdown nil :timeout (or timeout 1.5)) + ;; this one is supposed to always fail, because it asks the + ;; server to exit itself. 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))) + ;; Now ask jsonrpc.el to shutdown server (which in normal + ;; conditions should return immediately). + (jsonrpc-shutdown 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/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--shutdown-requested server) + t) + ((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 known major modes." @@@ -386,99 -481,324 +400,100 @@@ INTERACTIVE is t if called interactivel (let ((server (apply #'eglot--connect (eglot--guess-contact)))) (eglot--message "Automatically started `%s' to manage `%s' buffers in project `%s'" - (eglot--name server) + (eglot--project-nickname server) major-mode (eglot--project-nickname server))))))) - (add-hook 'post-command-hook #'maybe-connect 'append nil)))) + (when buffer-file-name + (add-hook 'post-command-hook #'maybe-connect 'append nil))))) -(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-events-buffer (server) + "Display events buffer for SERVER." + (interactive (eglot--current-server-or-lose)) + (display-buffer (jsonrpc-events-buffer server))) (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) - (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))) + "Display stderr buffer for SERVER." + (interactive (eglot--current-server-or-lose)) + (display-buffer (jsonrpc-stderr-buffer server))) (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))) + "Forget pending requests for SERVER." + (interactive (eglot--current-server-or-lose)) + (jsonrpc-forget-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))) - (setq timer (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 - ,(format "Request id=%s timed out" - (car id-and-timer))))) - :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." - (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))))) +(defvar eglot-connect-hook nil "Hook run after connecting in `eglot--connect'.") + +(defun eglot--connect (managed-major-mode project class contact) + "Connect to MANAGED-MAJOR-MODE, PROJECT, CLASS and CONTACT. +This docstring appeases checkdoc, that's all." + (let* ((nickname (file-name-base (directory-file-name + (car (project-roots project))))) + (readable-name (format "EGLOT (%s/%s)" nickname managed-major-mode)) + (initargs + (cond ((keywordp (car contact)) contact) + ((integerp (cadr contact)) + `(:process ,(lambda () + (apply #'open-network-stream + readable-name nil + (car contact) (cadr contact) + (cddr contact))))) + ((stringp (car contact)) + `(:process ,(lambda () + (make-process + :name readable-name + :command contact + :connection-type 'pipe + :coding 'utf-8-emacs-unix + :stderr (get-buffer-create + (format "*%s stderr*" readable-name)))))))) + (spread + (lambda (fn) + (lambda (&rest args) + (apply fn (append (butlast args) (car (last args))))))) + (server + (apply + #'make-instance class + :name readable-name + :notification-dispatcher (funcall spread #'eglot-handle-notification) + :request-dispatcher (funcall spread #'eglot-handle-request) + :on-shutdown #'eglot--on-shutdown + initargs)) + success) + (setf (eglot--saved-initargs server) initargs) + (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 + (list :processId (unless (eq (jsonrpc-process-type 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) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (eglot--maybe-activate-editing-mode server))) + (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)) + (when (and (not success) (jsonrpc-running-p server)) + (eglot-shutdown server))))) ;;; Helpers (move these to API?) @@@ -1057,14 -1399,28 +1080,29 @@@ DUMMY is ignored. (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 (eglot--current-server-or-lose) + :workspace/symbol + `(:query ,pattern))))) + (defun eglot-format-buffer () + "Format contents of current buffer." + (interactive) + (unless (eglot--server-capable :documentFormattingProvider) + (eglot--error "Server can't format!")) + (eglot--apply-text-edits - (eglot--request ++ (jsonrpc-request + (eglot--current-server-or-lose) + :textDocument/formatting + (list :textDocument (eglot--TextDocumentIdentifier) + :options (list :tabSize tab-width + :insertSpaces + (if indent-tabs-mode :json-false t))) - :textDocument/formatting))) ++ :deferred :textDocument/formatting))) + (defun eglot-completion-at-point () "EGLOT's `completion-at-point' function." (let ((bounds (bounds-of-thing-at-point 'symbol)) @@@ -1239,15 -1589,32 +1277,32 @@@ If SKIP-SIGNATURE, don't try to send te (defun eglot--apply-text-edits (edits &optional version) "Apply EDITS for current buffer if at VERSION, or if it's nil." (unless (or (not version) (equal version eglot--versioned-identifier)) - (jsonrpc-error "Edits on `%s' require version %d, we have %d" - (eglot--error "Edits on `%s' require version %d, you have %d" - (current-buffer) version eglot--versioned-identifier)) ++ (jsonrpc-error "Edits on `%s' require version %d, you have %d" + (current-buffer) version eglot--versioned-identifier)) - (eglot--widening - (mapc (pcase-lambda (`(,newText ,beg . ,end)) - (goto-char beg) (delete-region beg end) (insert newText)) - (mapcar (jsonrpc-lambda (&key range newText) - (cons newText (eglot--range-region range 'markers))) - edits))) - (eglot--message "%s: Performed %s edits" (current-buffer) (length edits))) + (atomic-change-group + (let* ((change-group (prepare-change-group)) + (howmany (length edits)) + (reporter (make-progress-reporter + (format "[eglot] applying %s edits to `%s'..." + howmany (current-buffer)) + 0 howmany)) + (done 0)) + (mapc (pcase-lambda (`(,newText ,beg . ,end)) + (let ((source (current-buffer))) + (with-temp-buffer + (insert newText) + (let ((temp (current-buffer))) + (with-current-buffer source + (save-excursion + (save-restriction + (narrow-to-region beg end) + (replace-buffer-contents temp))) + (progress-reporter-update reporter (cl-incf done))))))) - (mapcar (eglot--lambda (&key range newText) ++ (mapcar (jsonrpc-lambda (&key range newText) + (cons newText (eglot--range-region range 'markers))) + edits)) + (undo-amalgamate-change-group change-group) + (progress-reporter-done reporter)))) (defun eglot--apply-workspace-edit (wedit &optional confirm) "Apply the workspace edit WEDIT. If CONFIRM, ask user first."