From: João Távora Date: Fri, 18 May 2018 10:57:22 +0000 (+0100) Subject: Merge branch 'master' into jsonrpc-refactor (using good ol' git merge) X-Git-Tag: emacs-29.0.90~1616^2~524^2~4^2~489^2~20 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=d29b695179719844a8d0cdb0996b250a716f9e23;p=emacs.git Merge branch 'master' into jsonrpc-refactor (using good ol' git merge) --- d29b695179719844a8d0cdb0996b250a716f9e23 diff --cc lisp/progmodes/eglot.el index caf2e8c82fb,4a847bb6029..b820ddeae5c --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@@ -306,61 -393,218 +306,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)) (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 params) + "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) ++ (if (functionp handler-sym) ;; FIXME: fails if params is array, not object + (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 contact) + (let* ((contact (if (functionp contact) (funcall contact) contact)) + (proc (jrpc-connect name contact #'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) + (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 params error result _jsonrpc) 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) - ;; FIXME: will fail if params is array instead of not an object - (apply handler-sym proc (append params (if id `(:id ,id)))) - (eglot--warn "No implementation of method %s yet" method) - (when id - (eglot--reply - proc id - :error `(:code -32601 :message "Method unimplemented")))))) - (continuations - (cancel-timer (cl-third continuations)) - (remhash id (eglot--pending-continuations proc)) - (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 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." @@@ -441,16 -794,12 +443,12 @@@ (defun eglot--server-capable (feat) "Determine if current server is capable of FEAT." - (plist-get (eglot--capabilities (eglot--current-process-or-lose)) feat)) + (plist-get (eglot--capabilities (jrpc-current-process-or-lose)) feat)) - (cl-defmacro eglot--with-lsp-range ((start end) range &body body - &aux (range-sym (cl-gensym))) - "Bind LSP RANGE to START and END. Evaluate BODY." - (declare (indent 2) (debug (sexp sexp &rest form))) - `(let* ((,range-sym ,range) - (,start (eglot--lsp-position-to-point (plist-get ,range-sym :start))) - (,end (eglot--lsp-position-to-point (plist-get ,range-sym :end)))) - ,@body)) + (defun eglot--range-region (range) + "Return region (BEG . END) that represents LSP RANGE." + (cons (eglot--lsp-position-to-point (plist-get range :start)) + (eglot--lsp-position-to-point (plist-get range :end)))) ;;; Minor modes @@@ -894,14 -1247,13 +887,13 @@@ DUMMY is ignored (location-or-locations (if rich-identifier (get-text-property 0 :locations rich-identifier) - (eglot--request (eglot--current-process-or-lose) - :textDocument/definition - (get-text-property - 0 :textDocumentPositionParams identifier))))) - (mapcar (eglot--lambda (&key uri range) - (eglot--xref-make identifier uri (plist-get range :start))) - location-or-locations))) + (jrpc-request (jrpc-current-process-or-lose) + :textDocument/definition + (get-text-property + 0 :textDocumentPositionParams identifier))))) - (mapcar - (jrpc-lambda (&key uri range) ++ (mapcar (jrpc-lambda (&key uri range) + (eglot--xref-make identifier uri (plist-get range :start))) + location-or-locations))) (cl-defmethod xref-backend-references ((_backend (eql eglot)) identifier) (unless (eglot--server-capable :referencesProvider) @@@ -1063,14 -1413,14 +1055,15 @@@ If SKIP-SIGNATURE, don't try to send te (mapc #'delete-overlay eglot--highlights) (setq eglot--highlights (when-buffer-window - (mapcar (eglot--lambda (&key range _kind) - (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)))) + (mapcar + (jrpc-lambda (&key range _kind) - (eglot--with-lsp-range (beg end) range ++ (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)