"\"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 <host>:<port>")
+(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."
(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)
(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."
projects / emacs.git / commitdiff