From: João Távora Date: Sun, 10 Jun 2018 13:56:10 +0000 (+0100) Subject: Merge branch 'master' into jsonrpc-refactor X-Git-Tag: emacs-29.0.90~1616^2~524^2~4^2~489^2~1 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=97c17252e386ead858f5633e9d578052bf447c98;p=emacs.git Merge branch 'master' into jsonrpc-refactor --- 97c17252e386ead858f5633e9d578052bf447c98 diff --cc lisp/progmodes/eglot.el index 32879ec320c,47352f75234..0a060a53e9f --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@@ -252,11 -284,64 +259,13 @@@ function with the server still running. (push sym retval)))) retval)) -(defvar eglot-connect-hook nil "Hook run after connecting in `eglot--connect'.") - -(defun eglot--connect (managed-major-mode project server-class contact) - "Connect for PROJECT, MANAGED-MAJOR-MODE and CONTACT. -INTERACTIVE is t if inside interactive call. Return an object of -class SERVER-CLASS." - (let* ((nickname (file-name-base (directory-file-name - (car (project-roots project))))) - (name (format "EGLOT (%s/%s)" nickname managed-major-mode)) - (proc (eglot--make-process - name (if (functionp contact) (funcall contact) contact))) - server connect-success) - (setq server - (make-instance - (or server-class 'eglot-lsp-server) - :process proc :major-mode managed-major-mode - :project project :contact contact - :name name :project-nickname nickname - :inhibit-autoreconnect - (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)))))))) - (push server (gethash project eglot--servers-by-project)) - (process-put proc 'eglot-server server) - (unwind-protect - (cl-destructuring-bind (&key capabilities) - (eglot--request - server - :initialize - (list - :processId (unless (eq (process-type proc) 'network) (emacs-pid)) - :capabilities (eglot-client-capabilities server) - :rootPath (expand-file-name (car (project-roots project))) - :rootUri (eglot--path-to-uri (car (project-roots project))) - :initializationOptions (eglot-initialization-options server))) - (setf (eglot--capabilities server) capabilities) - (setf (eglot--status server) nil) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (eglot--maybe-activate-editing-mode server))) - (eglot--notify server :initialized `(:__dummy__ t)) - (run-hook-with-args 'eglot-connect-hook server) - (setq connect-success server)) - (unless (or connect-success - (not (process-live-p proc))) - (eglot-shutdown server))))) - (defvar eglot--command-history nil - "History of COMMAND arguments to `eglot'.") + "History of CONTACT arguments to `eglot'.") - (defun eglot--interactive () - "Helper for `eglot'." + (defun eglot--guess-contact (&optional interactive) + "Helper for `eglot'. + Return (MANAGED-MODE PROJECT CONTACT CLASS). + If INTERACTIVE, maybe prompt user." (let* ((guessed-mode (if buffer-file-name major-mode)) (managed-mode (cond @@@ -270,21 -355,23 +279,24 @@@ (t guessed-mode))) (project (or (project-current) `(transient . ,default-directory))) (guess (cdr (assoc managed-mode eglot-server-programs))) - (class (and (consp guess) (symbolp (car guess)) - (prog1 (car guess) (setq guess (cdr guess))))) + (class (if (and (consp guess) (symbolp (car guess))) + (prog1 (car guess) (setq guess (cdr guess))) + 'eglot-lsp-server)) (program (and (listp guess) (stringp (car guess)) (car guess))) - (base-prompt "[eglot] Enter program to execute (or :): ") + (base-prompt + (and interactive + "[eglot] Enter program to execute (or :): ")) (prompt - (cond (current-prefix-arg base-prompt) - ((null guess) - (format "[eglot] Sorry, couldn't guess for `%s'\n%s!" - managed-mode base-prompt)) - ((and program (not (executable-find program))) - (concat (format "[eglot] I guess you want to run `%s'" - (combine-and-quote-strings guess)) - (format ", but I can't find `%s' in PATH!" program) - "\n" base-prompt)))) + (and base-prompt + (cond (current-prefix-arg base-prompt) + ((null guess) + (format "[eglot] Sorry, couldn't guess for `%s'!\n%s" + managed-mode base-prompt)) + ((and program (not (executable-find program))) + (concat (format "[eglot] I guess you want to run `%s'" + (combine-and-quote-strings guess)) + (format ", but I can't find `%s' in PATH!" program) + "\n" base-prompt))))) (contact (if prompt (let ((s (read-shell-command @@@ -296,15 -383,16 +308,15 @@@ (list (match-string 1 s) (string-to-number (match-string 2 s))) (split-string-and-unquote s))) guess))) - (list managed-mode project class contact t))) + (list managed-mode project class contact))) ;;;###autoload -(defun eglot (managed-major-mode project server-class command - &optional interactive) +(defun eglot (managed-major-mode project class contact &optional interactive) "Manage a project with a Language Server Protocol (LSP) server. -The LSP server is started (or contacted) via COMMAND. If this -operation is successful, current *and future* file buffers of -MANAGED-MAJOR-MODE inside PROJECT automatically become +The LSP server of CLASS started (or contacted) via CONTACT. If +this operation is successful, current *and future* file buffers +of MANAGED-MAJOR-MODE inside PROJECT automatically become \"managed\" by the LSP server, meaning information about their contents is exchanged periodically to provide enhanced code-analysis via `xref-find-definitions', `flymake-mode', @@@ -320,137 -407,379 +332,153 @@@ MANAGED-MAJOR-MODE PROJECT is a project instance as returned by `project-current'. -COMMAND is a list of strings, an executable program and -optionally its arguments. If the first and only string in the -list is of the form \":\" it is taken as an -indication to connect to a server instead of starting one. This -is also know as the server's \"contact\". +CLASS is a subclass of symbol `eglot-lsp-server'. -SERVER-CLASS is a symbol naming a class that must inherit from -`eglot-server', or nil to use the default server class. +CONTACT specifies how to contact the server. It is a +keyword-value plist used to initialize CLASS or a plain list as +described in `eglot-server-programs', which see. INTERACTIVE is t if called interactively." - (interactive (eglot--interactive)) - (let* ((nickname (file-name-base (directory-file-name - (car (project-roots project))))) - (current-server (eglot--current-server)) + (interactive (append (eglot--guess-contact t) '(t))) - (let ((current-server (eglot--current-server))) - (if (and current-server - (process-live-p (eglot--process current-server)) ++ (let* ((current-server (eglot--current-server)) + (live-p (and current-server (jsonrpc-running-p current-server)))) + (if (and live-p interactive (y-or-n-p "[eglot] Live process found, reconnect instead? ")) (eglot-reconnect current-server interactive) - (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 - (format "%s/%s" nickname managed-major-mode) - nickname + (let ((server (eglot--connect managed-major-mode + project - server-class - command))) - (eglot--message "Connected! Server `%s' now \ + class + contact))) + (eglot--message "Connected! Process `%s' now \ managing `%s' buffers in project `%s'." - (eglot--name server) managed-major-mode + (jsonrpc-name server) managed-major-mode - nickname) + (eglot--project-nickname server)) server)))) (defun eglot-reconnect (server &optional interactive) "Reconnect to SERVER. INTERACTIVE is t if called interactively." (interactive (list (eglot--current-server-or-lose) t)) - (when (process-live-p (eglot--process server)) + (when (jsonrpc-running-p server) (ignore-errors (eglot-shutdown server interactive))) - (eglot--connect (eglot--project server) - (eglot--major-mode server) - (jsonrpc-name server) - (eglot--project-nickname server) + (eglot--connect (eglot--major-mode server) + (eglot--project server) - (eieio-object-class server) - (eglot--contact server)) + (eieio-object-class-name server) + (eglot--saved-initargs server)) (eglot--message "Reconnected!")) -(defvar eglot--managed-mode) ;forward decl ++(defvar eglot--managed-mode) ; forward decl + + (defun eglot-ensure () + "Start Eglot session for current buffer if there isn't one." + (let ((buffer (current-buffer))) + (cl-labels + ((maybe-connect + () + (remove-hook 'post-command-hook #'maybe-connect nil) + (eglot--with-live-buffer buffer + (if eglot--managed-mode + (eglot--message "%s is already managed by existing `%s'" + buffer - (eglot--name (eglot--current-server))) ++ (eglot--project-nickname (eglot--current-server))) + (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)))) + -(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))) - (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." - (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 (project managed-major-mode name nickname - class contact) - "Connect to PROJECT, MANAGED-MAJOR-MODE, NAME. - And don't forget NICKNAME and CLASS, CONTACT. This docstring - appeases checkdoc, that's all." - (let* ((readable-name (format "EGLOT (%s/%s)" nickname managed-major-mode)) ++(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 name ++ :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?)