From: João Távora Date: Wed, 16 May 2018 00:21:36 +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~23 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=d184bed317e57f11dc14359952218179cc0ffa5c;p=emacs.git Merge master into jsonrpc-refactor (using imerge) --- d184bed317e57f11dc14359952218179cc0ffa5c diff --cc lisp/progmodes/eglot.el index 11d048e03aa,da3a09f3b22..13c1b49c758 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@@ -87,58 -155,59 +109,58 @@@ lasted more than that many seconds. "\"Spinner\" used by some servers. A list (ID WHAT DONE-P).") -(eglot--define-process-var eglot--status `(:unknown nil) - "Status as declared by the server. -A list (WHAT SERIOUS-P).") +(jrpc-define-process-var eglot--moribund nil + "Non-nil if server is about to exit") -(eglot--define-process-var eglot--inhibit-autoreconnect eglot-autoreconnect +(jrpc-define-process-var eglot--inhibit-autoreconnect eglot-autoreconnect "If non-nil, don't autoreconnect on unexpected quit.") -(eglot--define-process-var eglot--contact nil - "Method used to contact a server. -Either a list of strings (a shell command and arguments), or a -list of a single string of the form :") +(jrpc-define-process-var eglot--file-watches (make-hash-table :test #'equal) + "File system watches for the didChangeWatchedfiles thingy.") -(eglot--define-process-var eglot--deferred-actions - (make-hash-table :test #'equal) - "Actions deferred to when server is thought to be ready.") +(defun eglot--on-shutdown (proc) + ;; Turn off `eglot--managed-mode' where appropriate. + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (eglot--buffer-managed-p proc) + (eglot--managed-mode -1)))) + ;; Kill any expensive watches + (maphash (lambda (_id watches) + (mapcar #'file-notify-rm-watch watches)) + (eglot--file-watches proc)) + ;; Sever the project/process relationship for proc + (setf (gethash (eglot--project proc) eglot--processes-by-project) + (delq proc + (gethash (eglot--project proc) eglot--processes-by-project))) + (cond ((eglot--moribund proc)) + ((not (eglot--inhibit-autoreconnect proc)) - (eglot--warn "Reconnecting unexpected server exit.") ++ (eglot--warn "Reconnecting after unexpected server exit.") + (eglot-reconnect proc)) - (t ++ ((timerp (eglot--inhibit-autoreconnect proc)) + (eglot--warn "Not auto-reconnecting, last one didn't last long.")))) -(eglot--define-process-var eglot--file-watches (make-hash-table :test #'equal) - "File system watches for the didChangeWatchedfiles thingy.") +(defun eglot-shutdown (proc &optional interactive) + "Politely ask the server PROC to quit. +Forcefully quit it if it doesn't respond. Don't leave this +function with the server still running. INTERACTIVE is t if +called interactively." + (interactive (list (jrpc-current-process-or-lose) t)) + (when interactive (eglot--message "Asking %s politely to terminate" proc)) + (unwind-protect + (let ((jrpc-request-timeout 3)) + (setf (eglot--moribund proc) t) + (jrpc-request proc :shutdown nil) + ;; this one should always fail under normal conditions + (ignore-errors (jrpc-request proc :exit nil))) + (when (process-live-p proc) + (eglot--warn "Brutally deleting existing process %s" proc) + (delete-process proc)))) -(defun eglot--make-process (name managed-major-mode contact) - "Make a process from CONTACT. -NAME is a name to give the inferior process or connection. -MANAGED-MAJOR-MODE is a symbol naming a major mode. -CONTACT is as `eglot--contact'. Returns a process object." - (let* ((readable-name (format "EGLOT server (%s/%s)" name managed-major-mode)) - (buffer (get-buffer-create - (format "*%s inferior*" readable-name))) - singleton - (proc - (if (and (setq singleton (and (null (cdr contact)) (car contact))) - (string-match "^[\s\t]*\\(.*\\):\\([[:digit:]]+\\)[\s\t]*$" - singleton)) - (open-network-stream readable-name - buffer - (match-string 1 singleton) - (string-to-number - (match-string 2 singleton))) - (make-process :name readable-name - :buffer buffer - :command contact - :connection-type 'pipe - :stderr (get-buffer-create (format "*%s stderr*" - name)))))) - (set-process-filter proc #'eglot--process-filter) - (set-process-sentinel proc #'eglot--process-sentinel) - proc)) - -(defmacro eglot--obj (&rest what) - "Make WHAT a suitable argument for `json-encode'." - (declare (debug (&rest form))) - ;; FIXME: maybe later actually do something, for now this just fixes - ;; the indenting of literal plists. - `(list ,@what)) +(defun eglot--find-current-process () + "The current logical EGLOT process." + (let* ((probe (or (project-current) `(transient . ,default-directory)))) + (cl-find major-mode (gethash probe eglot--processes-by-project) + :key #'eglot--major-mode))) (defun eglot--project-short-name (project) "Give PROJECT a short name." @@@ -252,9 -376,9 +281,8 @@@ INTERACTIVE is t if called interactivel (eglot-shutdown current-process)) (let ((proc (eglot--connect project managed-major-mode - short-name - command - interactive))) + (format "%s/%s" short-name managed-major-mode) - command - interactive))) ++ command))) (eglot--message "Connected! Process `%s' now \ managing `%s' buffers in project `%s'." proc managed-major-mode short-name) @@@ -268,58 -392,223 +296,61 @@@ INTERACTIVE is t if called interactivel (eglot-shutdown process interactive)) (eglot--connect (eglot--project process) (eglot--major-mode process) - (eglot--short-name process) - (eglot--contact process) - interactive) + (jrpc-name process) - (jrpc-contact process) - interactive) ++ (jrpc-contact process)) (eglot--message "Reconnected!")) -(defun eglot--process-sentinel (proc change) - "Called when PROC undergoes CHANGE." - (eglot--log-event proc `(:message "Process state changed" :change ,change)) - (when (not (process-live-p proc)) - (with-current-buffer (eglot-events-buffer proc) - (let ((inhibit-read-only t)) - (insert "\n----------b---y---e---b---y---e----------\n"))) - ;; Cancel outstanding timers and file system watches - (maphash (lambda (_id triplet) - (cl-destructuring-bind (_success _error timeout) triplet - (cancel-timer timeout))) - (eglot--pending-continuations proc)) - (maphash (lambda (_id watches) - (mapcar #'file-notify-rm-watch watches)) - (eglot--file-watches proc)) - (unwind-protect - ;; Call all outstanding error handlers - (maphash (lambda (_id triplet) - (cl-destructuring-bind (_success error _timeout) triplet - (funcall error :code -1 :message (format "Server died")))) - (eglot--pending-continuations proc)) - ;; Turn off `eglot--managed-mode' where appropriate. - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (eglot--buffer-managed-p proc) - (eglot--managed-mode -1)))) - ;; Forget about the process-project relationship - (setf (gethash (eglot--project proc) eglot--processes-by-project) - (delq proc - (gethash (eglot--project proc) eglot--processes-by-project))) - (eglot--message "Server exited with status %s" (process-exit-status proc)) - (cond ((eglot--moribund proc)) - ((not (eglot--inhibit-autoreconnect proc)) - (eglot--warn "Reconnecting after unexpected server exit") - (eglot-reconnect proc)) - ((timerp (eglot--inhibit-autoreconnect proc)) - (eglot--warn "Not auto-reconnecting, last on didn't last long."))) - (delete-process proc)))) +(defalias 'eglot-events-buffer 'jrpc-events-buffer) -(defun eglot--process-filter (proc string) - "Called when new data STRING has arrived for PROC." - (when (buffer-live-p (process-buffer proc)) - (with-current-buffer (process-buffer proc) - (let ((inhibit-read-only t) - (expected-bytes (eglot--expected-bytes proc))) - ;; Insert the text, advancing the process marker. - ;; - (save-excursion - (goto-char (process-mark proc)) - (insert string) - (set-marker (process-mark proc) (point))) - ;; Loop (more than one message might have arrived) - ;; - (unwind-protect - (let (done) - (while (not done) +(defvar eglot-connect-hook nil "Hook run after connecting in `eglot--connect'.") + +(defun eglot--dispatch (proc method id &rest params) - ;; a server notification or a server request ++ "Dispatcher passed to `jrpc-connect'. ++Builds a function from METHOD, passes it PROC, ID and PARAMS." + (let* ((handler-sym (intern (concat "eglot--server-" method)))) + (if (functionp handler-sym) + (apply handler-sym proc (append params (if id `(:id ,id)))) + (jrpc-reply + proc id + :error (jrpc-obj :code -32601 :message "Unimplemented"))))) + - (defun eglot--connect (project managed-major-mode name command - dont-inhibit) - (let ((proc (jrpc-connect name command #'eglot--dispatch #'eglot--on-shutdown))) ++(defun eglot--connect (project managed-major-mode name command) ++ (let ((proc (jrpc-connect name command #'eglot--dispatch #'eglot--on-shutdown)) ++ success) + (setf (eglot--project proc) project) + (setf (eglot--major-mode proc)managed-major-mode) + (push proc (gethash project eglot--processes-by-project)) + (run-hook-with-args 'eglot-connect-hook proc) - (cl-destructuring-bind (&key capabilities) - (jrpc-request - proc - :initialize - (jrpc-obj :processId (unless (eq (process-type proc) - 'network) - (emacs-pid)) - :rootUri (eglot--path-to-uri - (car (project-roots project))) - :initializationOptions [] - :capabilities (eglot--client-capabilities))) - (setf (eglot--capabilities proc) capabilities) - (setf (jrpc-status proc) nil) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (eglot--maybe-activate-editing-mode proc))) - (jrpc-notify proc :initialized (jrpc-obj :__dummy__ t)) - (setf (eglot--inhibit-autoreconnect proc) - (cond - ((booleanp eglot-autoreconnect) (not eglot-autoreconnect)) - (dont-inhibit nil) - ((cl-plusp eglot-autoreconnect) - (run-with-timer eglot-autoreconnect nil - (lambda () - (setf (eglot--inhibit-autoreconnect proc) - (null eglot-autoreconnect))))))) - proc))) ++ (unwind-protect ++ (cl-destructuring-bind (&key capabilities) ++ (jrpc-request ++ proc ++ :initialize ++ (jrpc-obj :processId (unless (eq (process-type proc) ++ 'network) ++ (emacs-pid)) ++ :rootPath (car (project-roots project)) ++ :rootUri (eglot--path-to-uri ++ (car (project-roots project))) ++ :initializationOptions [] ++ :capabilities (eglot--client-capabilities))) ++ (setf (eglot--capabilities proc) capabilities) ++ (setf (jrpc-status proc) nil) ++ (dolist (buffer (buffer-list)) ++ (with-current-buffer buffer ++ (eglot--maybe-activate-editing-mode proc))) ++ (jrpc-notify proc :initialized (jrpc-obj :__dummy__ t)) ++ (setf (eglot--inhibit-autoreconnect proc) + (cond - ((not expected-bytes) - ;; Starting a new message - ;; - (setq expected-bytes - (and (search-forward-regexp - "\\(?:.*: .*\r\n\\)*Content-Length: \ -*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n" - (+ (point) 100) - t) - (string-to-number (match-string 1)))) - (unless expected-bytes - (setq done :waiting-for-new-message))) - (t - ;; Attempt to complete a message body - ;; - (let ((available-bytes (- (position-bytes (process-mark proc)) - (position-bytes (point))))) - (cond - ((>= available-bytes - expected-bytes) - (let* ((message-end (byte-to-position - (+ (position-bytes (point)) - expected-bytes)))) - (unwind-protect - (save-restriction - (narrow-to-region (point) message-end) - (let* ((json-object-type 'plist) - (json-message (json-read))) - ;; Process content in another buffer, - ;; shielding buffer from tamper - ;; - (with-temp-buffer - (eglot--process-receive proc json-message)))) - (goto-char message-end) - (delete-region (point-min) (point)) - (setq expected-bytes nil)))) - (t - ;; Message is still incomplete - ;; - (setq done :waiting-for-more-bytes-in-this-message)))))))) - ;; Saved parsing state for next visit to this filter - ;; - (setf (eglot--expected-bytes proc) expected-bytes)))))) - -(defun eglot-events-buffer (process &optional interactive) - "Display events buffer for current LSP connection PROCESS. -INTERACTIVE is t if called interactively." - (interactive (list (eglot--current-process-or-lose) t)) - (let* ((probe (eglot--events-buffer process)) - (buffer (or (and (buffer-live-p probe) - probe) - (let ((buffer (get-buffer-create - (format "*%s events*" - (process-name process))))) - (with-current-buffer buffer - (buffer-disable-undo) - (read-only-mode t) - (setf (eglot--events-buffer process) buffer)) - buffer)))) - (when interactive (display-buffer buffer)) - buffer)) - -(defun eglot--log-event (proc message &optional type) - "Log an eglot-related event. -PROC is the current process. MESSAGE is a JSON-like plist. TYPE -is a symbol saying if this is a client or server originated." - (with-current-buffer (eglot-events-buffer proc) - (cl-destructuring-bind (&key method id error &allow-other-keys) message - (let* ((inhibit-read-only t) - (subtype (cond ((and method id) 'request) - (method 'notification) - (id 'reply) - (t 'message))) - (type - (format "%s-%s" (or type :internal) subtype))) - (goto-char (point-max)) - (let ((msg (format "%s%s%s:\n%s\n" - type - (if id (format " (id:%s)" id) "") - (if error " ERROR" "") - (pp-to-string message)))) - (when error - (setq msg (propertize msg 'face 'error))) - (insert-before-markers msg)))))) - -(defun eglot--process-receive (proc message) - "Process MESSAGE from PROC." - (cl-destructuring-bind (&key method id error &allow-other-keys) message - (let* ((continuations (and id - (not method) - (gethash id (eglot--pending-continuations proc))))) - (eglot--log-event proc message 'server) - (when error (setf (eglot--status proc) `(,error t))) - (cond (method - ;; a server notification or a server request - (let* ((handler-sym (intern (concat "eglot--server-" method)))) - (if (functionp handler-sym) - (apply handler-sym proc (append - (plist-get message :params) - (if id `(:id ,id)))) - (eglot--warn "No implementation of method %s yet" method) - (when id - (eglot--reply - proc id - :error (eglot--obj :code -32601 - :message "Method unimplemented")))))) - (continuations - (cancel-timer (cl-third continuations)) - (remhash id (eglot--pending-continuations proc)) - (if error - (apply (cl-second continuations) error) - (let ((res (plist-get message :result))) - (if (listp res) - (apply (cl-first continuations) res) - (funcall (cl-first continuations) res))))) - (id - (eglot--warn "Ooops no continuation for id %s" id))) - (eglot--call-deferred proc) - (force-mode-line-update t)))) - -(defun eglot--process-send (proc message) - "Send MESSAGE to PROC (ID is optional)." - (let ((json (json-encode message))) - (process-send-string proc (format "Content-Length: %d\r\n\r\n%s" - (string-bytes json) - json)) - (eglot--log-event proc message 'client))) - -(defvar eglot--next-request-id 0 "ID for next request.") - -(defun eglot--next-request-id () - "Compute the next id for a client request." - (setq eglot--next-request-id (1+ eglot--next-request-id))) - -(defun eglot-forget-pending-continuations (process) - "Stop waiting for responses from the current LSP PROCESS." - (interactive (list (eglot--current-process-or-lose))) - (clrhash (eglot--pending-continuations process))) - -(defun eglot-clear-status (process) - "Clear most recent error message from PROCESS." - (interactive (list (eglot--current-process-or-lose))) - (setf (eglot--status process) nil)) - -(defun eglot--call-deferred (proc) - "Call PROC's deferred actions, who may again defer themselves." - (when-let ((actions (hash-table-values (eglot--deferred-actions proc)))) - (eglot--log-event proc `(:running-deferred ,(length actions))) - (mapc #'funcall (mapcar #'car actions)))) - -(defvar eglot--ready-predicates '(eglot--server-ready-p) - "Special hook of predicates controlling deferred actions. -If one of these returns nil, a deferrable `eglot--async-request' -will be deferred. Each predicate is passed the symbol for the -request request and a process object.") ++ ((booleanp eglot-autoreconnect) (not eglot-autoreconnect)) ++ ((cl-plusp eglot-autoreconnect) ++ (run-with-timer eglot-autoreconnect nil ++ (lambda () ++ (setf (eglot--inhibit-autoreconnect proc) ++ (null eglot-autoreconnect))))))) ++ (setq success proc)) ++ (unless (or success (not (process-live-p proc)) (eglot--moribund proc)) ++ (eglot-shutdown proc))))) (defun eglot--server-ready-p (_what _proc) "Tell if server of PROC ready for processing deferred WHAT."