From ecb08911dcf5b2eae1338ef832640603eaf441b3 Mon Sep 17 00:00:00 2001 From: Dimitri Belopopsky Date: Mon, 2 Jan 2023 22:06:07 +0100 Subject: [PATCH] Add inlay hint functionality --- eglot.el | 3731 +++++++++++++++++++++++++++++------------------------- 1 file changed, 1985 insertions(+), 1746 deletions(-) diff --git a/eglot.el b/eglot.el index 901bf30..9e5a9dd 100644 --- a/eglot.el +++ b/eglot.el @@ -114,13 +114,13 @@ ;; using the latest version from GNU Elpa when we load eglot.el. Use an ;; heuristic to see if we need to `load' it in Emacs < 28. (if (and (< emacs-major-version 28) - (not (boundp 'eldoc-documentation-strategy))) - (load "eldoc") + (not (boundp 'eldoc-documentation-strategy))) + (load "eldoc") (require 'eldoc)) ;; Similar issue as above for Emacs 26.3 and seq.el. (if (< emacs-major-version 27) - (load "seq") + (load "seq") (require 'seq)) ;; forward-declare, but don't require (Emacs 28 doesn't seem to care) @@ -150,90 +150,90 @@ chosen (interactively or automatically)." ;; `eglot--executable-find' may take much longer to execute on ;; remote files. (let* ((listified (cl-loop for a in alternatives - collect (if (listp a) a (list a)))) - (err (lambda () - (error "None of '%s' are valid executables" - (mapconcat #'car listified ", "))))) + collect (if (listp a) a (list a)))) + (err (lambda () + (error "None of '%s' are valid executables" + (mapconcat #'car listified ", "))))) (cond (interactive - (let* ((augmented (mapcar (lambda (a) - (let ((found (eglot--executable-find - (car a) t))) - (and found - (cons (car a) (cons found (cdr a)))))) - listified)) - (available (remove nil augmented))) - (cond ((cdr available) - (cdr (assoc - (completing-read - "[eglot] More than one server executable available:" - (mapcar #'car available) - nil t nil nil (car (car available))) - available #'equal))) - ((cdr (car available))) - (t - ;; Don't error when used interactively, let the - ;; Eglot prompt the user for alternative (github#719) - nil)))) - (t - (cl-loop for (p . args) in listified - for probe = (eglot--executable-find p t) - when probe return (cons probe args) - finally (funcall err))))))) + (let* ((augmented (mapcar (lambda (a) + (let ((found (eglot--executable-find + (car a) t))) + (and found + (cons (car a) (cons found (cdr a)))))) + listified)) + (available (remove nil augmented))) + (cond ((cdr available) + (cdr (assoc + (completing-read + "[eglot] More than one server executable available:" + (mapcar #'car available) + nil t nil nil (car (car available))) + available #'equal))) + ((cdr (car available))) + (t + ;; Don't error when used interactively, let the + ;; Eglot prompt the user for alternative (github#719) + nil)))) + (t + (cl-loop for (p . args) in listified + for probe = (eglot--executable-find p t) + when probe return (cons probe args) + finally (funcall err))))))) (defvar eglot-server-programs `((rust-mode . ,(eglot-alternatives '("rust-analyzer" "rls"))) - (cmake-mode . ("cmake-language-server")) - (vimrc-mode . ("vim-language-server" "--stdio")) - (python-mode - . ,(eglot-alternatives - '("pylsp" "pyls" ("pyright-langserver" "--stdio") "jedi-language-server"))) - ((js-mode typescript-mode) - . ("typescript-language-server" "--stdio")) - (sh-mode . ("bash-language-server" "start")) - ((php-mode phps-mode) - . ("php" "vendor/felixfbecker/\ + (cmake-mode . ("cmake-language-server")) + (vimrc-mode . ("vim-language-server" "--stdio")) + (python-mode + . ,(eglot-alternatives + '("pylsp" "pyls" ("pyright-langserver" "--stdio") "jedi-language-server"))) + ((js-mode typescript-mode) + . ("typescript-language-server" "--stdio")) + (sh-mode . ("bash-language-server" "start")) + ((php-mode phps-mode) + . ("php" "vendor/felixfbecker/\ language-server/bin/php-language-server.php")) - ((c++-mode c-mode) . ,(eglot-alternatives - '("clangd" "ccls"))) - (((caml-mode :language-id "ocaml") - (tuareg-mode :language-id "ocaml") reason-mode) - . ("ocamllsp")) - (ruby-mode - . ("solargraph" "socket" "--port" :autoport)) - (haskell-mode - . ("haskell-language-server-wrapper" "--lsp")) - (elm-mode . ("elm-language-server")) - (mint-mode . ("mint" "ls")) - (kotlin-mode . ("kotlin-language-server")) - (go-mode . ("gopls")) - ((R-mode ess-r-mode) . ("R" "--slave" "-e" - "languageserver::run()")) - (java-mode . ("jdtls")) - (dart-mode . ("dart" "language-server" - "--client-id" "emacs.eglot-dart")) - (elixir-mode . ("language_server.sh")) - (ada-mode . ("ada_language_server")) - (scala-mode . ("metals-emacs")) - (racket-mode . ("racket" "-l" "racket-langserver")) - ((tex-mode context-mode texinfo-mode bibtex-mode) - . ("digestif")) - (erlang-mode . ("erlang_ls" "--transport" "stdio")) - (yaml-mode . ("yaml-language-server" "--stdio")) - (nix-mode . ("rnix-lsp")) - (gdscript-mode . ("localhost" 6008)) - ((fortran-mode f90-mode) . ("fortls")) - (futhark-mode . ("futhark" "lsp")) - (lua-mode . ("lua-lsp")) - (zig-mode . ("zls")) - (css-mode . ,(eglot-alternatives '(("vscode-css-language-server" "--stdio") ("css-languageserver" "--stdio")))) - (html-mode . ,(eglot-alternatives '(("vscode-html-language-server" "--stdio") ("html-languageserver" "--stdio")))) - (json-mode . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio") ("json-languageserver" "--stdio")))) - (dockerfile-mode . ("docker-langserver" "--stdio")) - ((clojure-mode clojurescript-mode clojurec-mode) - . ("clojure-lsp")) - (csharp-mode . ("omnisharp" "-lsp")) - (purescript-mode . ("purescript-language-server" "--stdio")) - (perl-mode . ("perl" "-MPerl::LanguageServer" "-e" "Perl::LanguageServer::run")) - (markdown-mode . ("marksman" "server"))) + ((c++-mode c-mode) . ,(eglot-alternatives + '("clangd" "ccls"))) + (((caml-mode :language-id "ocaml") + (tuareg-mode :language-id "ocaml") reason-mode) + . ("ocamllsp")) + (ruby-mode + . ("solargraph" "socket" "--port" :autoport)) + (haskell-mode + . ("haskell-language-server-wrapper" "--lsp")) + (elm-mode . ("elm-language-server")) + (mint-mode . ("mint" "ls")) + (kotlin-mode . ("kotlin-language-server")) + (go-mode . ("gopls")) + ((R-mode ess-r-mode) . ("R" "--slave" "-e" + "languageserver::run()")) + (java-mode . ("jdtls")) + (dart-mode . ("dart" "language-server" + "--client-id" "emacs.eglot-dart")) + (elixir-mode . ("language_server.sh")) + (ada-mode . ("ada_language_server")) + (scala-mode . ("metals-emacs")) + (racket-mode . ("racket" "-l" "racket-langserver")) + ((tex-mode context-mode texinfo-mode bibtex-mode) + . ("digestif")) + (erlang-mode . ("erlang_ls" "--transport" "stdio")) + (yaml-mode . ("yaml-language-server" "--stdio")) + (nix-mode . ("rnix-lsp")) + (gdscript-mode . ("localhost" 6008)) + ((fortran-mode f90-mode) . ("fortls")) + (futhark-mode . ("futhark" "lsp")) + (lua-mode . ("lua-lsp")) + (zig-mode . ("zls")) + (css-mode . ,(eglot-alternatives '(("vscode-css-language-server" "--stdio") ("css-languageserver" "--stdio")))) + (html-mode . ,(eglot-alternatives '(("vscode-html-language-server" "--stdio") ("html-languageserver" "--stdio")))) + (json-mode . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio") ("json-languageserver" "--stdio")))) + (dockerfile-mode . ("docker-langserver" "--stdio")) + ((clojure-mode clojurescript-mode clojurec-mode) + . ("clojure-lsp")) + (csharp-mode . ("omnisharp" "-lsp")) + (purescript-mode . ("purescript-language-server" "--stdio")) + (perl-mode . ("perl" "-MPerl::LanguageServer" "-e" "Perl::LanguageServer::run")) + (markdown-mode . ("marksman" "server"))) "How the command `eglot' guesses the server to start. An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE identifies the buffers that are to be managed by a specific @@ -314,6 +314,10 @@ CONTACT can be: '((t . (:inherit shadow :strike-through t))) "Face used to render deprecated or obsolete code.") +(defface eglot-flymake-inlay-hint + '((t (:inherit shadow :height 0.8))) + "Face used for inlay hint overlays in flymake.") + (defcustom eglot-autoreconnect 3 "Control ability to reconnect automatically to the LSP server. If t, always reconnect automatically (not recommended). If nil, @@ -322,7 +326,7 @@ crashes or network failures. A positive integer number says to only autoreconnect if the previous successful connection attempt lasted more than that many seconds." :type '(choice (boolean :tag "Whether to inhibit autoreconnection") - (integer :tag "Number of seconds"))) + (integer :tag "Number of seconds"))) (defcustom eglot-connect-timeout 30 "Number of seconds before timing out LSP connection attempts. @@ -336,7 +340,7 @@ integer number means block for that many seconds, and then wait for the connection in the background. nil has the same meaning as 0, i.e. don't block at all." :type '(choice (boolean :tag "Whether to inhibit autoreconnection") - (integer :tag "Number of seconds"))) + (integer :tag "Number of seconds"))) (defcustom eglot-autoshutdown nil "If non-nil, shut down server after killing last managed buffer." @@ -356,12 +360,12 @@ For changes on this variable to take effect on a connection already started, you need to restart the connection. That can be done by `eglot-reconnect'." :type '(choice (const :tag "No limit" nil) - (integer :tag "Number of characters"))) + (integer :tag "Number of characters"))) (defcustom eglot-confirm-server-initiated-edits 'confirm "Non-nil if server-initiated edits should be confirmed with user." :type '(choice (const :tag "Don't show confirmation prompt" nil) - (symbol :tag "Show confirmation prompt" 'confirm))) + (symbol :tag "Show confirmation prompt" 'confirm))) (defcustom eglot-extend-to-xref nil "If non-nil, activate Eglot in cross-referenced non-project files." @@ -384,27 +388,27 @@ This can be useful when using docker to run a language server.") ;;; (defconst eglot--symbol-kind-names `((1 . "File") (2 . "Module") - (3 . "Namespace") (4 . "Package") (5 . "Class") - (6 . "Method") (7 . "Property") (8 . "Field") - (9 . "Constructor") (10 . "Enum") (11 . "Interface") - (12 . "Function") (13 . "Variable") (14 . "Constant") - (15 . "String") (16 . "Number") (17 . "Boolean") - (18 . "Array") (19 . "Object") (20 . "Key") - (21 . "Null") (22 . "EnumMember") (23 . "Struct") - (24 . "Event") (25 . "Operator") (26 . "TypeParameter"))) + (3 . "Namespace") (4 . "Package") (5 . "Class") + (6 . "Method") (7 . "Property") (8 . "Field") + (9 . "Constructor") (10 . "Enum") (11 . "Interface") + (12 . "Function") (13 . "Variable") (14 . "Constant") + (15 . "String") (16 . "Number") (17 . "Boolean") + (18 . "Array") (19 . "Object") (20 . "Key") + (21 . "Null") (22 . "EnumMember") (23 . "Struct") + (24 . "Event") (25 . "Operator") (26 . "TypeParameter"))) (defconst eglot--kind-names `((1 . "Text") (2 . "Method") (3 . "Function") (4 . "Constructor") - (5 . "Field") (6 . "Variable") (7 . "Class") (8 . "Interface") - (9 . "Module") (10 . "Property") (11 . "Unit") (12 . "Value") - (13 . "Enum") (14 . "Keyword") (15 . "Snippet") (16 . "Color") - (17 . "File") (18 . "Reference") (19 . "Folder") (20 . "EnumMember") - (21 . "Constant") (22 . "Struct") (23 . "Event") (24 . "Operator") - (25 . "TypeParameter"))) + (5 . "Field") (6 . "Variable") (7 . "Class") (8 . "Interface") + (9 . "Module") (10 . "Property") (11 . "Unit") (12 . "Value") + (13 . "Enum") (14 . "Keyword") (15 . "Snippet") (16 . "Color") + (17 . "File") (18 . "Reference") (19 . "Folder") (20 . "EnumMember") + (21 . "Constant") (22 . "Struct") (23 . "Event") (24 . "Operator") + (25 . "TypeParameter"))) (defconst eglot--tag-faces `((1 . eglot-diagnostic-tag-unnecessary-face) - (2 . eglot-diagnostic-tag-deprecated-face))) + (2 . eglot-diagnostic-tag-deprecated-face))) (defconst eglot--{} (make-hash-table :size 1) "The empty JSON object.") (defvaralias 'eglot-{} 'eglot--{}) @@ -420,43 +424,43 @@ This can be useful when using docker to run a language server.") (eval-and-compile (defvar eglot--lsp-interface-alist `( - (CodeAction (:title) (:kind :diagnostics :edit :command :isPreferred)) - (ConfigurationItem () (:scopeUri :section)) - (Command ((:title . string) (:command . string)) (:arguments)) - (CompletionItem (:label) - (:kind :detail :documentation :deprecated :preselect - :sortText :filterText :insertText :insertTextFormat - :textEdit :additionalTextEdits :commitCharacters - :command :data :tags)) - (Diagnostic (:range :message) (:severity :code :source :relatedInformation :codeDescription :tags)) - (DocumentHighlight (:range) (:kind)) - (FileSystemWatcher (:globPattern) (:kind)) - (Hover (:contents) (:range)) - (InitializeResult (:capabilities) (:serverInfo)) - (Location (:uri :range)) - (LocationLink (:targetUri :targetRange :targetSelectionRange) (:originSelectionRange)) - (LogMessageParams (:type :message)) - (MarkupContent (:kind :value)) - (ParameterInformation (:label) (:documentation)) - (Position (:line :character)) - (Range (:start :end)) - (Registration (:id :method) (:registerOptions)) - (ResponseError (:code :message) (:data)) - (ShowMessageParams (:type :message)) - (ShowMessageRequestParams (:type :message) (:actions)) - (SignatureHelp (:signatures) (:activeSignature :activeParameter)) - (SignatureInformation (:label) (:documentation :parameters :activeParameter)) - (SymbolInformation (:name :kind :location) - (:deprecated :containerName)) - (DocumentSymbol (:name :range :selectionRange :kind) - ;; `:containerName' isn't really allowed , but - ;; it simplifies the impl of `eglot-imenu'. - (:detail :deprecated :children :containerName)) - (TextDocumentEdit (:textDocument :edits) ()) - (TextEdit (:range :newText)) - (VersionedTextDocumentIdentifier (:uri :version) ()) - (WorkspaceEdit () (:changes :documentChanges)) - (WorkspaceSymbol (:name :kind) (:containerName :location :data))) + (CodeAction (:title) (:kind :diagnostics :edit :command :isPreferred)) + (ConfigurationItem () (:scopeUri :section)) + (Command ((:title . string) (:command . string)) (:arguments)) + (CompletionItem (:label) + (:kind :detail :documentation :deprecated :preselect + :sortText :filterText :insertText :insertTextFormat + :textEdit :additionalTextEdits :commitCharacters + :command :data :tags)) + (Diagnostic (:range :message) (:severity :code :source :relatedInformation :codeDescription :tags)) + (DocumentHighlight (:range) (:kind)) + (FileSystemWatcher (:globPattern) (:kind)) + (Hover (:contents) (:range)) + (InitializeResult (:capabilities) (:serverInfo)) + (Location (:uri :range)) + (LocationLink (:targetUri :targetRange :targetSelectionRange) (:originSelectionRange)) + (LogMessageParams (:type :message)) + (MarkupContent (:kind :value)) + (ParameterInformation (:label) (:documentation)) + (Position (:line :character)) + (Range (:start :end)) + (Registration (:id :method) (:registerOptions)) + (ResponseError (:code :message) (:data)) + (ShowMessageParams (:type :message)) + (ShowMessageRequestParams (:type :message) (:actions)) + (SignatureHelp (:signatures) (:activeSignature :activeParameter)) + (SignatureInformation (:label) (:documentation :parameters :activeParameter)) + (SymbolInformation (:name :kind :location) + (:deprecated :containerName)) + (DocumentSymbol (:name :range :selectionRange :kind) + ;; `:containerName' isn't really allowed , but + ;; it simplifies the impl of `eglot-imenu'. + (:detail :deprecated :children :containerName)) + (TextDocumentEdit (:textDocument :edits) ()) + (TextEdit (:range :newText)) + (VersionedTextDocumentIdentifier (:uri :version) ()) + (WorkspaceEdit () (:changes :documentChanges)) + (WorkspaceSymbol (:name :kind) (:containerName :location :data))) "Alist (INTERFACE-NAME . INTERFACE) of known external LSP interfaces. INTERFACE-NAME is a symbol designated by the spec as @@ -474,10 +478,10 @@ Here's what an element of this alist might look like: (eval-and-compile (defvar eglot-strict-mode '(;; Uncomment next lines for fun and debugging - ;; disallow-non-standard-keys - ;; enforce-required-keys - ;; enforce-optional-keys - ) + ;; disallow-non-standard-keys + ;; enforce-required-keys + ;; enforce-optional-keys + ) "How strictly to check LSP interfaces at compile- and run-time. Value is a list of symbols (if the list is empty, no checks are @@ -501,31 +505,31 @@ If the symbol `disallow-unknown-methods' is present, Eglot warns on unknown notifications and errors on unknown requests.")) (cl-defun eglot--check-object (interface-name - object - &optional - (enforce-required t) - (disallow-non-standard t) - (check-types t)) + object + &optional + (enforce-required t) + (disallow-non-standard t) + (check-types t)) "Check that OBJECT conforms to INTERFACE. Error otherwise." (cl-destructuring-bind - (&key types required-keys optional-keys &allow-other-keys) - (eglot--interface interface-name) + (&key types required-keys optional-keys &allow-other-keys) + (eglot--interface interface-name) (when-let ((missing (and enforce-required - (cl-set-difference required-keys - (eglot--plist-keys object))))) + (cl-set-difference required-keys + (eglot--plist-keys object))))) (eglot--error "A `%s' must have %s" interface-name missing)) (when-let ((excess (and disallow-non-standard - (cl-set-difference - (eglot--plist-keys object) - (append required-keys optional-keys))))) + (cl-set-difference + (eglot--plist-keys object) + (append required-keys optional-keys))))) (eglot--error "A `%s' mustn't have %s" interface-name excess)) (when check-types (cl-loop - for (k v) on object by #'cddr - for type = (or (cdr (assoc k types)) t) ;; FIXME: enforce nil type? - unless (cl-typep v type) - do (eglot--error "A `%s' must have a %s as %s, but has %s" - interface-name ))) + for (k v) on object by #'cddr + for type = (or (cdr (assoc k types)) t) ;; FIXME: enforce nil type? + unless (cl-typep v type) + do (eglot--error "A `%s' must have a %s as %s, but has %s" + interface-name ))) t)) (eval-and-compile @@ -536,44 +540,44 @@ on unknown notifications and errors on unknown requests.")) (defun eglot--interface (interface-name) (let* ((interface (assoc interface-name eglot--lsp-interface-alist)) - (required (mapcar #'eglot--ensure-type (car (cdr interface)))) - (optional (mapcar #'eglot--ensure-type (cadr (cdr interface))))) + (required (mapcar #'eglot--ensure-type (car (cdr interface)))) + (optional (mapcar #'eglot--ensure-type (cadr (cdr interface))))) (list :types (append required optional) - :required-keys (mapcar #'car required) - :optional-keys (mapcar #'car optional)))) + :required-keys (mapcar #'car required) + :optional-keys (mapcar #'car optional)))) (defun eglot--check-dspec (interface-name dspec) "Check destructuring spec DSPEC against INTERFACE-NAME." (cl-destructuring-bind (&key required-keys optional-keys &allow-other-keys) - (eglot--interface interface-name) + (eglot--interface interface-name) (cond ((or required-keys optional-keys) - (let ((too-many - (and - (memq 'disallow-non-standard-keys eglot-strict-mode) - (cl-set-difference - (eglot--keywordize-vars dspec) - (append required-keys optional-keys)))) - (ignored-required - (and - (memq 'enforce-required-keys eglot-strict-mode) - (cl-set-difference - required-keys (eglot--keywordize-vars dspec)))) - (missing-out - (and - (memq 'enforce-optional-keys eglot-strict-mode) - (cl-set-difference - optional-keys (eglot--keywordize-vars dspec))))) - (when too-many (byte-compile-warn - "Destructuring for %s has extraneous %s" - interface-name too-many)) - (when ignored-required (byte-compile-warn - "Destructuring for %s ignores required %s" - interface-name ignored-required)) - (when missing-out (byte-compile-warn - "Destructuring for %s is missing out on %s" - interface-name missing-out)))) - (t - (byte-compile-warn "Unknown LSP interface %s" interface-name)))))) + (let ((too-many + (and + (memq 'disallow-non-standard-keys eglot-strict-mode) + (cl-set-difference + (eglot--keywordize-vars dspec) + (append required-keys optional-keys)))) + (ignored-required + (and + (memq 'enforce-required-keys eglot-strict-mode) + (cl-set-difference + required-keys (eglot--keywordize-vars dspec)))) + (missing-out + (and + (memq 'enforce-optional-keys eglot-strict-mode) + (cl-set-difference + optional-keys (eglot--keywordize-vars dspec))))) + (when too-many (byte-compile-warn + "Destructuring for %s has extraneous %s" + interface-name too-many)) + (when ignored-required (byte-compile-warn + "Destructuring for %s ignores required %s" + interface-name ignored-required)) + (when missing-out (byte-compile-warn + "Destructuring for %s is missing out on %s" + interface-name missing-out)))) + (t + (byte-compile-warn "Unknown LSP interface %s" interface-name)))))) (cl-defmacro eglot--dbind (vars object &body body) "Destructure OBJECT, binding VARS in BODY. @@ -581,26 +585,26 @@ VARS is ([(INTERFACE)] SYMS...) Honour `eglot-strict-mode'." (declare (indent 2) (debug (sexp sexp &rest form))) (let ((interface-name (if (consp (car vars)) - (car (pop vars)))) - (object-once (make-symbol "object-once")) - (fn-once (make-symbol "fn-once"))) + (car (pop vars)))) + (object-once (make-symbol "object-once")) + (fn-once (make-symbol "fn-once"))) (cond (interface-name - (eglot--check-dspec interface-name vars) - `(let ((,object-once ,object)) - (cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once - (eglot--check-object ',interface-name ,object-once - (memq 'enforce-required-keys eglot-strict-mode) - (memq 'disallow-non-standard-keys eglot-strict-mode) - (memq 'check-types eglot-strict-mode)) - ,@body))) - (t - `(let ((,object-once ,object) - (,fn-once (lambda (,@vars) ,@body))) - (if (memq 'disallow-non-standard-keys eglot-strict-mode) - (cl-destructuring-bind (&key ,@vars) ,object-once - (funcall ,fn-once ,@vars)) - (cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once - (funcall ,fn-once ,@vars)))))))) + (eglot--check-dspec interface-name vars) + `(let ((,object-once ,object)) + (cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once + (eglot--check-object ',interface-name ,object-once + (memq 'enforce-required-keys eglot-strict-mode) + (memq 'disallow-non-standard-keys eglot-strict-mode) + (memq 'check-types eglot-strict-mode)) + ,@body))) + (t + `(let ((,object-once ,object) + (,fn-once (lambda (,@vars) ,@body))) + (if (memq 'disallow-non-standard-keys eglot-strict-mode) + (cl-destructuring-bind (&key ,@vars) ,object-once + (funcall ,fn-once ,@vars)) + (cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once + (funcall ,fn-once ,@vars)))))))) (cl-defmacro eglot--lambda (cl-lambda-list &body body) @@ -618,38 +622,38 @@ treated as in `eglot-dbind'." (let ((obj-once (make-symbol "obj-once"))) `(let ((,obj-once ,obj)) (cond - ,@(cl-loop - for (vars . body) in clauses - for vars-as-keywords = (eglot--keywordize-vars vars) - for interface-name = (if (consp (car vars)) + ,@(cl-loop + for (vars . body) in clauses + for vars-as-keywords = (eglot--keywordize-vars vars) + for interface-name = (if (consp (car vars)) (car (pop vars))) - for condition = - (cond (interface-name - (eglot--check-dspec interface-name vars) - ;; In this mode, in runtime, we assume - ;; `eglot-strict-mode' is partially on, otherwise we - ;; can't disambiguate between certain types. - `(ignore-errors - (eglot--check-object - ',interface-name ,obj-once - t - (memq 'disallow-non-standard-keys eglot-strict-mode) - t))) - (t - ;; In this interface-less mode we don't check - ;; `eglot-strict-mode' at all: just check that the object - ;; has all the keys the user wants to destructure. - `(null (cl-set-difference + for condition = + (cond (interface-name + (eglot--check-dspec interface-name vars) + ;; In this mode, in runtime, we assume + ;; `eglot-strict-mode' is partially on, otherwise we + ;; can't disambiguate between certain types. + `(ignore-errors + (eglot--check-object + ',interface-name ,obj-once + t + (memq 'disallow-non-standard-keys eglot-strict-mode) + t))) + (t + ;; In this interface-less mode we don't check + ;; `eglot-strict-mode' at all: just check that the object + ;; has all the keys the user wants to destructure. + `(null (cl-set-difference ',vars-as-keywords (eglot--plist-keys ,obj-once))))) - collect `(,condition - (cl-destructuring-bind (&key ,@vars &allow-other-keys) - ,obj-once - ,@body))) - (t - (eglot--error "%S didn't match any of %S" - ,obj-once - ',(mapcar #'car clauses))))))) + collect `(,condition + (cl-destructuring-bind (&key ,@vars &allow-other-keys) + ,obj-once + ,@body))) + (t + (eglot--error "%S didn't match any of %S" + ,obj-once + ',(mapcar #'car clauses))))))) ;;; API (WORK-IN-PROGRESS!) @@ -683,154 +687,154 @@ treated as in `eglot-dbind'." (cl-defgeneric eglot-initialization-options (server) "JSON object to send under `initializationOptions'." (:method (s) - (let ((probe (plist-get (eglot--saved-initargs s) :initializationOptions))) - (cond ((functionp probe) (funcall probe s)) - (probe) - (t eglot--{}))))) + (let ((probe (plist-get (eglot--saved-initargs s) :initializationOptions))) + (cond ((functionp probe) (funcall probe s)) + (probe) + (t eglot--{}))))) (cl-defgeneric eglot-register-capability (server method id &rest params) "Ask SERVER to register capability METHOD marked with ID." (:method - (_s method _id &rest _params) - (eglot--warn "Server tried to register unsupported capability `%s'" - method))) + (_s method _id &rest _params) + (eglot--warn "Server tried to register unsupported capability `%s'" + method))) (cl-defgeneric eglot-unregister-capability (server method id &rest params) "Ask SERVER to register capability METHOD marked with ID." (:method - (_s method _id &rest _params) - (eglot--warn "Server tried to unregister unsupported capability `%s'" - method))) + (_s method _id &rest _params) + (eglot--warn "Server tried to unregister unsupported capability `%s'" + method))) (cl-defgeneric eglot-client-capabilities (server) "What the Eglot LSP client supports for SERVER." (:method (s) - (list - :workspace (list - :applyEdit t - :executeCommand `(:dynamicRegistration :json-false) - :workspaceEdit `(:documentChanges t) - :didChangeWatchedFiles - `(:dynamicRegistration - ,(if (eglot--trampish-p s) :json-false t)) - :symbol `(:dynamicRegistration :json-false) - :configuration t - :workspaceFolders t) - :textDocument - (list - :synchronization (list - :dynamicRegistration :json-false - :willSave t :willSaveWaitUntil t :didSave t) - :completion (list :dynamicRegistration :json-false - :completionItem - `(:snippetSupport - ,(if (eglot--snippet-expansion-fn) - t - :json-false) - :deprecatedSupport t - :tagSupport (:valueSet [1])) - :contextSupport t) - :hover (list :dynamicRegistration :json-false - :contentFormat - (if (fboundp 'gfm-view-mode) - ["markdown" "plaintext"] - ["plaintext"])) - :signatureHelp (list :dynamicRegistration :json-false - :signatureInformation - `(:parameterInformation - (:labelOffsetSupport t) - :activeParameterSupport t)) - :references `(:dynamicRegistration :json-false) - :definition (list :dynamicRegistration :json-false - :linkSupport t) - :declaration (list :dynamicRegistration :json-false - :linkSupport t) - :implementation (list :dynamicRegistration :json-false - :linkSupport t) - :typeDefinition (list :dynamicRegistration :json-false - :linkSupport t) - :documentSymbol (list - :dynamicRegistration :json-false - :hierarchicalDocumentSymbolSupport t - :symbolKind `(:valueSet - [,@(mapcar - #'car eglot--symbol-kind-names)])) - :documentHighlight `(:dynamicRegistration :json-false) - :codeAction (list - :dynamicRegistration :json-false - :codeActionLiteralSupport - '(:codeActionKind - (:valueSet - ["quickfix" - "refactor" "refactor.extract" - "refactor.inline" "refactor.rewrite" - "source" "source.organizeImports"])) - :isPreferredSupport t) - :formatting `(:dynamicRegistration :json-false) - :rangeFormatting `(:dynamicRegistration :json-false) - :rename `(:dynamicRegistration :json-false) - :publishDiagnostics (list :relatedInformation :json-false - ;; TODO: We can support :codeDescription after - ;; adding an appropriate UI to - ;; Flymake. - :codeDescriptionSupport :json-false - :tagSupport - `(:valueSet - [,@(mapcar - #'car eglot--tag-faces)]))) - :experimental eglot--{}))) + (list + :workspace (list + :applyEdit t + :executeCommand `(:dynamicRegistration :json-false) + :workspaceEdit `(:documentChanges t) + :didChangeWatchedFiles + `(:dynamicRegistration + ,(if (eglot--trampish-p s) :json-false t)) + :symbol `(:dynamicRegistration :json-false) + :configuration t + :workspaceFolders t) + :textDocument + (list + :synchronization (list + :dynamicRegistration :json-false + :willSave t :willSaveWaitUntil t :didSave t) + :completion (list :dynamicRegistration :json-false + :completionItem + `(:snippetSupport + ,(if (eglot--snippet-expansion-fn) + t + :json-false) + :deprecatedSupport t + :tagSupport (:valueSet [1])) + :contextSupport t) + :hover (list :dynamicRegistration :json-false + :contentFormat + (if (fboundp 'gfm-view-mode) + ["markdown" "plaintext"] + ["plaintext"])) + :signatureHelp (list :dynamicRegistration :json-false + :signatureInformation + `(:parameterInformation + (:labelOffsetSupport t) + :activeParameterSupport t)) + :references `(:dynamicRegistration :json-false) + :definition (list :dynamicRegistration :json-false + :linkSupport t) + :declaration (list :dynamicRegistration :json-false + :linkSupport t) + :implementation (list :dynamicRegistration :json-false + :linkSupport t) + :typeDefinition (list :dynamicRegistration :json-false + :linkSupport t) + :documentSymbol (list + :dynamicRegistration :json-false + :hierarchicalDocumentSymbolSupport t + :symbolKind `(:valueSet + [,@(mapcar + #'car eglot--symbol-kind-names)])) + :documentHighlight `(:dynamicRegistration :json-false) + :codeAction (list + :dynamicRegistration :json-false + :codeActionLiteralSupport + '(:codeActionKind + (:valueSet + ["quickfix" + "refactor" "refactor.extract" + "refactor.inline" "refactor.rewrite" + "source" "source.organizeImports"])) + :isPreferredSupport t) + :formatting `(:dynamicRegistration :json-false) + :rangeFormatting `(:dynamicRegistration :json-false) + :rename `(:dynamicRegistration :json-false) + :publishDiagnostics (list :relatedInformation :json-false + ;; TODO: We can support :codeDescription after + ;; adding an appropriate UI to + ;; Flymake. + :codeDescriptionSupport :json-false + :tagSupport + `(:valueSet + [,@(mapcar + #'car eglot--tag-faces)]))) + :experimental eglot--{}))) (cl-defgeneric eglot-workspace-folders (server) "Return workspaceFolders for SERVER." (let ((project (eglot--project server))) (vconcat - (mapcar (lambda (dir) - (list :uri (eglot--path-to-uri dir) - :name (abbreviate-file-name dir))) - `(,(project-root project) ,@(project-external-roots project)))))) + (mapcar (lambda (dir) + (list :uri (eglot--path-to-uri dir) + :name (abbreviate-file-name dir))) + `(,(project-root project) ,@(project-external-roots project)))))) (defclass eglot-lsp-server (jsonrpc-process-connection) ((project-nickname - :documentation "Short nickname for the associated project." - :accessor eglot--project-nickname - :reader eglot-project-nickname) - (major-modes - :documentation "Major modes server is responsible for in a given project." - :accessor eglot--major-modes) - (language-id - :documentation "Language ID string for the mode." - :accessor eglot--language-id) - (capabilities - :documentation "JSON object containing server capabilities." - :accessor eglot--capabilities) - (server-info - :documentation "JSON object containing server info." - :accessor eglot--server-info) - (shutdown-requested - :documentation "Flag set when server is shutting down." - :accessor eglot--shutdown-requested) - (project - :documentation "Project associated with server." - :accessor eglot--project) - (spinner - :documentation "List (ID DOING-WHAT DONE-P) representing server progress." - :initform `(nil nil t) :accessor eglot--spinner) - (inhibit-autoreconnect - :initform t - :documentation "Generalized boolean inhibiting auto-reconnection if true." - :accessor eglot--inhibit-autoreconnect) - (file-watches - :documentation "Map ID to list of WATCHES for `didChangeWatchedFiles'." - :initform (make-hash-table :test #'equal) :accessor eglot--file-watches) - (managed-buffers - :documentation "List of buffers managed by server." - :accessor eglot--managed-buffers) - (saved-initargs - :documentation "Saved initargs for reconnection purposes." - :accessor eglot--saved-initargs) - (inferior-process - :documentation "Server subprocess started automatically." - :accessor eglot--inferior-process)) + :documentation "Short nickname for the associated project." + :accessor eglot--project-nickname + :reader eglot-project-nickname) + (major-modes + :documentation "Major modes server is responsible for in a given project." + :accessor eglot--major-modes) + (language-id + :documentation "Language ID string for the mode." + :accessor eglot--language-id) + (capabilities + :documentation "JSON object containing server capabilities." + :accessor eglot--capabilities) + (server-info + :documentation "JSON object containing server info." + :accessor eglot--server-info) + (shutdown-requested + :documentation "Flag set when server is shutting down." + :accessor eglot--shutdown-requested) + (project + :documentation "Project associated with server." + :accessor eglot--project) + (spinner + :documentation "List (ID DOING-WHAT DONE-P) representing server progress." + :initform `(nil nil t) :accessor eglot--spinner) + (inhibit-autoreconnect + :initform t + :documentation "Generalized boolean inhibiting auto-reconnection if true." + :accessor eglot--inhibit-autoreconnect) + (file-watches + :documentation "Map ID to list of WATCHES for `didChangeWatchedFiles'." + :initform (make-hash-table :test #'equal) :accessor eglot--file-watches) + (managed-buffers + :documentation "List of buffers managed by server." + :accessor eglot--managed-buffers) + (saved-initargs + :documentation "Saved initargs for reconnection purposes." + :accessor eglot--saved-initargs) + (inferior-process + :documentation "Server subprocess started automatically." + :accessor eglot--inferior-process)) :documentation "Represents a server. Wraps a process for LSP communication.") @@ -855,14 +859,14 @@ If PRESERVE-BUFFERS is non-nil (interactively, when called with a prefix argument), do not kill events and output buffers of SERVER." (interactive (list (eglot--read-server "Shutdown which server" - (eglot-current-server)) - t nil current-prefix-arg)) + (eglot-current-server)) + t nil current-prefix-arg)) (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 (or timeout 1.5)) - (jsonrpc-notify server :exit nil)) + (progn + (setf (eglot--shutdown-requested server) t) + (jsonrpc-request server :shutdown nil :timeout (or timeout 1.5)) + (jsonrpc-notify server :exit nil)) ;; Now ask jsonrpc.el to shut down the server. (jsonrpc-shutdown server (not preserve-buffers)) (unless preserve-buffers (kill-buffer (jsonrpc-events-buffer server))))) @@ -872,33 +876,33 @@ SERVER." PRESERVE-BUFFERS as in `eglot-shutdown', which see." (interactive (list current-prefix-arg)) (cl-loop for ss being the hash-values of eglot--servers-by-project - do (cl-loop for s in ss do (eglot-shutdown s nil preserve-buffers)))) + do (cl-loop for s in ss do (eglot-shutdown s nil preserve-buffers)))) (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)) (let (;; Avoid duplicate shutdowns (github#389) - (eglot-autoshutdown nil)) + (eglot-autoshutdown nil)) (eglot--when-live-buffer buffer (eglot--managed-mode-off)))) ;; Kill any expensive watches (maphash (lambda (_id watches) (mapcar #'file-notify-rm-watch watches)) - (eglot--file-watches server)) + (eglot--file-watches server)) ;; Kill any autostarted inferior processes (when-let (proc (eglot--inferior-process server)) (delete-process proc)) ;; 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))) + (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.")))) + 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." @@ -925,25 +929,25 @@ LANGUAGE-ID is determined from MODE's name. CONTACT-PROXY is the value of the corresponding `eglot-server-programs' entry." (cl-loop - for (modes . contact) in eglot-server-programs - for mode-symbols = (cons mode - (delete mode - (mapcar #'car - (mapcar #'eglot--ensure-list - (eglot--ensure-list modes))))) - thereis (cl-some - (lambda (spec) - (cl-destructuring-bind (probe &key language-id &allow-other-keys) + for (modes . contact) in eglot-server-programs + for mode-symbols = (cons mode + (delete mode + (mapcar #'car + (mapcar #'eglot--ensure-list + (eglot--ensure-list modes))))) + thereis (cl-some + (lambda (spec) + (cl-destructuring-bind (probe &key language-id &allow-other-keys) (eglot--ensure-list spec) - (and (provided-mode-derived-p mode probe) - (list + (and (provided-mode-derived-p mode probe) + (list mode-symbols (or language-id - (or (get mode 'eglot-language-id) - (get spec 'eglot-language-id) - (string-remove-suffix "-mode" (symbol-name mode)))) + (or (get mode 'eglot-language-id) + (get spec 'eglot-language-id) + (string-remove-suffix "-mode" (symbol-name mode)))) contact)))) - (if (or (symbolp modes) (keywordp (cadr modes))) + (if (or (symbolp modes) (keywordp (cadr modes))) (list modes) modes)))) (defun eglot--guess-contact (&optional interactive) @@ -952,76 +956,76 @@ Return (MANAGED-MODE PROJECT CLASS CONTACT LANG-ID). If INTERACTIVE is non-nil, maybe prompt user, else error as soon as something can't be guessed." (let* ((guessed-mode (if buffer-file-name major-mode)) - (main-mode - (cond - ((and interactive + (main-mode + (cond + ((and interactive (or (>= (prefix-numeric-value current-prefix-arg) 16) - (not guessed-mode))) - (intern - (completing-read - "[eglot] Start a server to manage buffers of what major mode? " - (mapcar #'symbol-name (eglot--all-major-modes)) nil t - (symbol-name guessed-mode) nil (symbol-name guessed-mode) nil))) - ((not guessed-mode) - (eglot--error "Can't guess mode to manage for `%s'" (current-buffer))) - (t guessed-mode))) - (triplet (eglot--lookup-mode main-mode)) - (managed-modes (car triplet)) - (language-id (or (cadr triplet) - (string-remove-suffix "-mode" (symbol-name guessed-mode)))) - (guess (caddr triplet)) - (guess (if (functionp guess) - (funcall guess interactive) - guess)) - (class (or (and (consp guess) (symbolp (car guess)) - (prog1 (unless current-prefix-arg (car guess)) - (setq guess (cdr guess)))) - 'eglot-lsp-server)) - (program (and (listp guess) - (stringp (car guess)) - ;; A second element might be the port of a (host, port) - ;; pair, but in that case it is not a string. - (or (null (cdr guess)) (stringp (cadr guess))) - (car guess))) - (base-prompt - (and interactive - "Enter program to execute (or :): ")) - (full-program-invocation - (and program - (cl-every #'stringp guess) - (combine-and-quote-strings guess))) - (prompt - (and base-prompt - (cond (current-prefix-arg base-prompt) - ((null guess) - (format "[eglot] Sorry, couldn't guess for `%s'!\n%s" - main-mode base-prompt)) - ((and program - (not (file-name-absolute-p program)) - (not (eglot--executable-find program t))) - (if full-program-invocation - (concat (format "[eglot] I guess you want to run `%s'" - full-program-invocation) - (format ", but I can't find `%s' in PATH!" - program) - "\n" base-prompt) - (eglot--error - (concat "`%s' not found in PATH, but can't form" - " an interactive prompt for to fix %s!") - program guess)))))) - (contact - (or (and prompt - (split-string-and-unquote + (not guessed-mode))) + (intern + (completing-read + "[eglot] Start a server to manage buffers of what major mode? " + (mapcar #'symbol-name (eglot--all-major-modes)) nil t + (symbol-name guessed-mode) nil (symbol-name guessed-mode) nil))) + ((not guessed-mode) + (eglot--error "Can't guess mode to manage for `%s'" (current-buffer))) + (t guessed-mode))) + (triplet (eglot--lookup-mode main-mode)) + (managed-modes (car triplet)) + (language-id (or (cadr triplet) + (string-remove-suffix "-mode" (symbol-name guessed-mode)))) + (guess (caddr triplet)) + (guess (if (functionp guess) + (funcall guess interactive) + guess)) + (class (or (and (consp guess) (symbolp (car guess)) + (prog1 (unless current-prefix-arg (car guess)) + (setq guess (cdr guess)))) + 'eglot-lsp-server)) + (program (and (listp guess) + (stringp (car guess)) + ;; A second element might be the port of a (host, port) + ;; pair, but in that case it is not a string. + (or (null (cdr guess)) (stringp (cadr guess))) + (car guess))) + (base-prompt + (and interactive + "Enter program to execute (or :): ")) + (full-program-invocation + (and program + (cl-every #'stringp guess) + (combine-and-quote-strings guess))) + (prompt + (and base-prompt + (cond (current-prefix-arg base-prompt) + ((null guess) + (format "[eglot] Sorry, couldn't guess for `%s'!\n%s" + main-mode base-prompt)) + ((and program + (not (file-name-absolute-p program)) + (not (eglot--executable-find program t))) + (if full-program-invocation + (concat (format "[eglot] I guess you want to run `%s'" + full-program-invocation) + (format ", but I can't find `%s' in PATH!" + program) + "\n" base-prompt) + (eglot--error + (concat "`%s' not found in PATH, but can't form" + " an interactive prompt for to fix %s!") + program guess)))))) + (contact + (or (and prompt + (split-string-and-unquote (read-shell-command - prompt - full-program-invocation - 'eglot-command-history))) + prompt + full-program-invocation + 'eglot-command-history))) guess))) (list managed-modes (eglot--current-project) class contact language-id))) (defvar eglot-lsp-context) (put 'eglot-lsp-context 'variable-documentation - "Dynamically non-nil when searching for projects in LSP context.") + "Dynamically non-nil when searching for projects in LSP context.") (defvar eglot--servers-by-xrefed-file (make-hash-table :test 'equal :weakness 'value)) @@ -1038,7 +1042,7 @@ suitable root directory for a given LSP server's purposes." ;;;###autoload (defun eglot (managed-major-mode project class contact language-id - &optional interactive) + &optional interactive) "Manage a project with a Language Server Protocol (LSP) server. The LSP server of CLASS is started (or contacted) via CONTACT. @@ -1074,11 +1078,11 @@ MANAGED-MAJOR-MODE, which matters to a minority of servers. INTERACTIVE is t if called interactively." (interactive (append (eglot--guess-contact t) '(t))) (let* ((current-server (eglot-current-server)) - (live-p (and current-server (jsonrpc-running-p 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) + interactive + (y-or-n-p "[eglot] Live process found, reconnect instead? ")) + (eglot-reconnect current-server interactive) (when live-p (ignore-errors (eglot-shutdown current-server))) (eglot--connect managed-major-mode project class contact language-id)))) @@ -1089,10 +1093,10 @@ INTERACTIVE is t if called interactively." (when (jsonrpc-running-p server) (ignore-errors (eglot-shutdown server interactive nil 'preserve-buffers))) (eglot--connect (eglot--major-modes server) - (eglot--project server) - (eieio-object-class-name server) - (eglot--saved-initargs server) - (eglot--language-id server)) + (eglot--project server) + (eieio-object-class-name server) + (eglot--saved-initargs server) + (eglot--language-id server)) (eglot--message "Reconnected!")) (defvar eglot--managed-mode) ; forward decl @@ -1102,12 +1106,12 @@ INTERACTIVE is t if called interactively." "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--when-live-buffer buffer - (unless eglot--managed-mode - (apply #'eglot--connect (eglot--guess-contact)))))) + ((maybe-connect + () + (remove-hook 'post-command-hook #'maybe-connect nil) + (eglot--when-live-buffer buffer + (unless eglot--managed-mode + (apply #'eglot--connect (eglot--guess-contact)))))) (when buffer-file-name (add-hook 'post-command-hook #'maybe-connect 'append nil))))) @@ -1117,8 +1121,8 @@ Use current server's or first available Eglot events buffer." (interactive (list (eglot-current-server))) (let ((buffer (if server (jsonrpc-events-buffer server) (cl-find "\\*EGLOT.*events\\*" - (buffer-list) - :key #'buffer-name :test #'string-match)))) + (buffer-list) + :key #'buffer-name :test #'string-match)))) (if buffer (display-buffer buffer) (eglot--error "Can't find an Eglot events buffer!")))) @@ -1150,16 +1154,16 @@ Each function is passed the server as an argument") (defun eglot--cmd (contact) "Helper for `eglot--connect'." (if (file-remote-p default-directory) - ;; TODO: this seems like a bug, although it’s everywhere. For - ;; some reason, for remote connections only, over a pipe, we - ;; need to turn off line buffering on the tty. - ;; - ;; Not only does this seem like there should be a better way, - ;; but it almost certainly doesn’t work on non-unix systems. - (list "sh" "-c" - (string-join (cons "stty raw > /dev/null;" - (mapcar #'shell-quote-argument contact)) - " ")) + ;; TODO: this seems like a bug, although it’s everywhere. For + ;; some reason, for remote connections only, over a pipe, we + ;; need to turn off line buffering on the tty. + ;; + ;; Not only does this seem like there should be a better way, + ;; but it almost certainly doesn’t work on non-unix systems. + (list "sh" "-c" + (string-join (cons "stty raw > /dev/null;" + (mapcar #'shell-quote-argument contact)) + " ")) contact)) (defvar-local eglot--cached-server nil @@ -1169,64 +1173,64 @@ Each function is passed the server as an argument") "Connect to MANAGED-MODES, LANGUAGE-ID, PROJECT, CLASS and CONTACT. This docstring appeases checkdoc, that's all." (let* ((default-directory (project-root project)) - (nickname (file-name-base (directory-file-name default-directory))) - (readable-name (format "EGLOT (%s/%s)" nickname managed-modes)) - autostart-inferior-process - server-info - (contact (if (functionp contact) (funcall contact) contact)) - (initargs - (cond ((keywordp (car contact)) contact) - ((integerp (cadr contact)) - (setq server-info (list (format "%s:%s" (car contact) - (cadr contact)))) - `(:process ,(lambda () - (apply #'open-network-stream - readable-name nil - (car contact) (cadr contact) - (cddr contact))))) - ((and (stringp (car contact)) (memq :autoport contact)) - (setq server-info (list "")) - `(:process ,(lambda () - (pcase-let ((`(,connection . ,inferior) + (nickname (file-name-base (directory-file-name default-directory))) + (readable-name (format "EGLOT (%s/%s)" nickname managed-modes)) + autostart-inferior-process + server-info + (contact (if (functionp contact) (funcall contact) contact)) + (initargs + (cond ((keywordp (car contact)) contact) + ((integerp (cadr contact)) + (setq server-info (list (format "%s:%s" (car contact) + (cadr contact)))) + `(:process ,(lambda () + (apply #'open-network-stream + readable-name nil + (car contact) (cadr contact) + (cddr contact))))) + ((and (stringp (car contact)) (memq :autoport contact)) + (setq server-info (list "")) + `(:process ,(lambda () + (pcase-let ((`(,connection . ,inferior) (eglot--inferior-bootstrap - readable-name - contact))) - (setq autostart-inferior-process inferior) - connection)))) - ((stringp (car contact)) - (let* ((probe (cl-position-if #'keywordp contact)) + readable-name + contact))) + (setq autostart-inferior-process inferior) + connection)))) + ((stringp (car contact)) + (let* ((probe (cl-position-if #'keywordp contact)) (more-initargs (and probe (cl-subseq contact probe))) (contact (cl-subseq contact 0 probe))) - `(:process + `(:process ,(lambda () (let ((default-directory default-directory)) (make-process - :name readable-name - :command (setq server-info (eglot--cmd contact)) - :connection-type 'pipe - :coding 'utf-8-emacs-unix - :noquery t - :stderr (get-buffer-create - (format "*%s stderr*" readable-name)) - :file-handler t))) + :name readable-name + :command (setq server-info (eglot--cmd contact)) + :connection-type 'pipe + :coding 'utf-8-emacs-unix + :noquery t + :stderr (get-buffer-create + (format "*%s stderr*" readable-name)) + :file-handler t))) ,@more-initargs))))) - (spread (lambda (fn) (lambda (server method params) - (let ((eglot--cached-server server)) - (apply fn server method (append params nil)))))) - (server - (apply - #'make-instance class - :name readable-name - :events-buffer-scrollback-size eglot-events-buffer-size - :notification-dispatcher (funcall spread #'eglot-handle-notification) - :request-dispatcher (funcall spread #'eglot-handle-request) - :on-shutdown #'eglot--on-shutdown - initargs)) - (cancelled nil) - (tag (make-symbol "connected-catch-tag"))) + (spread (lambda (fn) (lambda (server method params) + (let ((eglot--cached-server server)) + (apply fn server method (append params nil)))))) + (server + (apply + #'make-instance class + :name readable-name + :events-buffer-scrollback-size eglot-events-buffer-size + :notification-dispatcher (funcall spread #'eglot-handle-notification) + :request-dispatcher (funcall spread #'eglot-handle-request) + :on-shutdown #'eglot--on-shutdown + initargs)) + (cancelled nil) + (tag (make-symbol "connected-catch-tag"))) (when server-info (jsonrpc--debug server "Running language server: %s" - (string-join server-info " "))) + (string-join server-info " "))) (setf (eglot--saved-initargs server) initargs) (setf (eglot--project server) project) (setf (eglot--project-nickname server) nickname) @@ -1238,91 +1242,91 @@ This docstring appeases checkdoc, that's all." ;; maybe-sync-maybe-async semantics we use `jsonrpc-async-request' ;; and mimic most of `jsonrpc-request'. (unwind-protect - (condition-case _quit - (let ((retval - (catch tag - (jsonrpc-async-request - server - :initialize - (list :processId - (unless (or eglot-withhold-process-id - (file-remote-p default-directory) - (eq (jsonrpc-process-type server) - 'network)) - (emacs-pid)) - ;; Maybe turn trampy `/ssh:foo@bar:/path/to/baz.py' - ;; into `/path/to/baz.py', so LSP groks it. - :rootPath (file-local-name - (expand-file-name default-directory)) - :rootUri (eglot--path-to-uri default-directory) - :initializationOptions (eglot-initialization-options - server) - :capabilities (eglot-client-capabilities server) - :workspaceFolders (eglot-workspace-folders server)) - :success-fn - (eglot--lambda ((InitializeResult) capabilities serverInfo) - (unless cancelled - (push server - (gethash project eglot--servers-by-project)) - (setf (eglot--capabilities server) capabilities) - (setf (eglot--server-info server) serverInfo) - (jsonrpc-notify server :initialized eglot--{}) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - ;; No need to pass SERVER as an argument: it has - ;; been registered in `eglot--servers-by-project', - ;; so that it can be found (and cached) from - ;; `eglot--maybe-activate-editing-mode' in any - ;; managed buffer. - (eglot--maybe-activate-editing-mode))) - (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))))))) - (let ((default-directory (project-root project)) - (major-mode (car managed-modes))) - (hack-dir-local-variables-non-file-buffer) - (run-hook-with-args 'eglot-connect-hook server)) - (eglot--message - "Connected! Server `%s' now managing `%s' buffers \ + (condition-case _quit + (let ((retval + (catch tag + (jsonrpc-async-request + server + :initialize + (list :processId + (unless (or eglot-withhold-process-id + (file-remote-p default-directory) + (eq (jsonrpc-process-type server) + 'network)) + (emacs-pid)) + ;; Maybe turn trampy `/ssh:foo@bar:/path/to/baz.py' + ;; into `/path/to/baz.py', so LSP groks it. + :rootPath (file-local-name + (expand-file-name default-directory)) + :rootUri (eglot--path-to-uri default-directory) + :initializationOptions (eglot-initialization-options + server) + :capabilities (eglot-client-capabilities server) + :workspaceFolders (eglot-workspace-folders server)) + :success-fn + (eglot--lambda ((InitializeResult) capabilities serverInfo) + (unless cancelled + (push server + (gethash project eglot--servers-by-project)) + (setf (eglot--capabilities server) capabilities) + (setf (eglot--server-info server) serverInfo) + (jsonrpc-notify server :initialized eglot--{}) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + ;; No need to pass SERVER as an argument: it has + ;; been registered in `eglot--servers-by-project', + ;; so that it can be found (and cached) from + ;; `eglot--maybe-activate-editing-mode' in any + ;; managed buffer. + (eglot--maybe-activate-editing-mode))) + (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))))))) + (let ((default-directory (project-root project)) + (major-mode (car managed-modes))) + (hack-dir-local-variables-non-file-buffer) + (run-hook-with-args 'eglot-connect-hook server)) + (eglot--message + "Connected! Server `%s' now managing `%s' buffers \ in project `%s'." - (or (plist-get serverInfo :name) - (jsonrpc-name server)) - managed-modes - (eglot-project-nickname server)) - (when tag (throw tag t)))) - :timeout eglot-connect-timeout - :error-fn (eglot--lambda ((ResponseError) code message) + (or (plist-get serverInfo :name) + (jsonrpc-name server)) + managed-modes + (eglot-project-nickname server)) + (when tag (throw tag t)))) + :timeout eglot-connect-timeout + :error-fn (eglot--lambda ((ResponseError) code message) + (unless cancelled + (jsonrpc-shutdown server) + (let ((msg (format "%s: %s" code message))) + (if tag (throw tag `(error . ,msg)) + (eglot--error msg))))) + :timeout-fn (lambda () (unless cancelled (jsonrpc-shutdown server) - (let ((msg (format "%s: %s" code message))) + (let ((msg (format "Timed out after %s seconds" + eglot-connect-timeout))) (if tag (throw tag `(error . ,msg)) - (eglot--error msg))))) - :timeout-fn (lambda () - (unless cancelled - (jsonrpc-shutdown server) - (let ((msg (format "Timed out after %s seconds" - eglot-connect-timeout))) - (if tag (throw tag `(error . ,msg)) - (eglot--error msg)))))) - (cond ((numberp eglot-sync-connect) - (accept-process-output nil eglot-sync-connect)) - (eglot-sync-connect - (while t (accept-process-output - nil eglot-connect-timeout))))))) - (pcase retval - (`(error . ,msg) (eglot--error msg)) - (`nil (eglot--message "Waiting in background for server `%s'" - (jsonrpc-name server)) - nil) - (_ server))) - (quit (jsonrpc-shutdown server) (setq cancelled 'quit))) + (eglot--error msg)))))) + (cond ((numberp eglot-sync-connect) + (accept-process-output nil eglot-sync-connect)) + (eglot-sync-connect + (while t (accept-process-output + nil eglot-connect-timeout))))))) + (pcase retval + (`(error . ,msg) (eglot--error msg)) + (`nil (eglot--message "Waiting in background for server `%s'" + (jsonrpc-name server)) + nil) + (_ server))) + (quit (jsonrpc-shutdown server) (setq cancelled 'quit))) (setq tag nil)))) (defun eglot--inferior-bootstrap (name contact &optional connect-args) @@ -1332,47 +1336,47 @@ Name both based on NAME. CONNECT-ARGS are passed as additional arguments to `open-network-stream'." (let* ((port-probe (make-network-process :name "eglot-port-probe-dummy" - :server t - :host "localhost" - :service 0)) - (port-number (unwind-protect - (process-contact port-probe :service) - (delete-process port-probe))) - inferior connection) + :server t + :host "localhost" + :service 0)) + (port-number (unwind-protect + (process-contact port-probe :service) + (delete-process port-probe))) + inferior connection) (unwind-protect - (progn - (setq inferior - (make-process - :name (format "autostart-inferior-%s" name) - :stderr (format "*%s stderr*" name) - :noquery t - :command (cl-subst - (format "%s" port-number) :autoport contact))) - (setq connection - (cl-loop - repeat 10 for i from 1 - do (accept-process-output nil 0.5) - while (process-live-p inferior) - do (eglot--message - "Trying to connect to localhost and port %s (attempt %s)" - port-number i) - thereis (ignore-errors - (apply #'open-network-stream - (format "autoconnect-%s" name) - nil - "localhost" port-number connect-args)))) - (cons connection inferior)) + (progn + (setq inferior + (make-process + :name (format "autostart-inferior-%s" name) + :stderr (format "*%s stderr*" name) + :noquery t + :command (cl-subst + (format "%s" port-number) :autoport contact))) + (setq connection + (cl-loop + repeat 10 for i from 1 + do (accept-process-output nil 0.5) + while (process-live-p inferior) + do (eglot--message + "Trying to connect to localhost and port %s (attempt %s)" + port-number i) + thereis (ignore-errors + (apply #'open-network-stream + (format "autoconnect-%s" name) + nil + "localhost" port-number connect-args)))) + (cons connection inferior)) (cond ((and (process-live-p connection) - (process-live-p inferior)) - (eglot--message "Done, connected to %s!" port-number)) - (t - (when inferior (delete-process inferior)) - (when connection (delete-process connection)) - (eglot--error "Could not start and connect to server%s" - (if inferior - (format " started with %s" - (process-command inferior)) - "!"))))))) + (process-live-p inferior)) + (eglot--message "Done, connected to %s!" port-number)) + (t + (when inferior (delete-process inferior)) + (when connection (delete-process connection)) + (eglot--error "Could not start and connect to server%s" + (if inferior + (format " started with %s" + (process-command inferior)) + "!"))))))) ;;; Helpers (move these to API?) @@ -1407,17 +1411,17 @@ fully LSP-compliant servers, this should be set to "Calculate current COLUMN as defined by the LSP spec. LBP defaults to `line-beginning-position'." (/ (- (length (encode-coding-region (or lbp (line-beginning-position)) - ;; Fix github#860 - (min (point) (point-max)) 'utf-16 t)) - 2) - 2)) + ;; Fix github#860 + (min (point) (point-max)) 'utf-16 t)) + 2) + 2)) (defun eglot--pos-to-lsp-position (&optional pos) "Convert point POS to LSP position." (eglot--widening - (list :line (1- (line-number-at-pos pos t)) ; F!@&#$CKING OFF-BY-ONE - :character (progn (when pos (goto-char pos)) - (funcall eglot-current-column-function))))) + (list :line (1- (line-number-at-pos pos t)) ; F!@&#$CKING OFF-BY-ONE + :character (progn (when pos (goto-char pos)) + (funcall eglot-current-column-function))))) (defvar eglot-move-to-column-function #'eglot-move-to-lsp-abiding-column "Function to move to a column reported by the LSP server. @@ -1439,22 +1443,22 @@ be set to `eglot-move-to-lsp-abiding-column' (the default), and ;; `whitespace-mode', `prettify-symbols-mode', etc. (github#296, ;; github#297) (goto-char (min (+ (line-beginning-position) column) - (line-end-position)))) + (line-end-position)))) (defun eglot-move-to-lsp-abiding-column (column) "Move to COLUMN abiding by the LSP spec." (save-restriction (cl-loop - with lbp = (line-beginning-position) - initially - (narrow-to-region lbp (line-end-position)) - (move-to-column column) - for diff = (- column + with lbp = (line-beginning-position) + initially + (narrow-to-region lbp (line-end-position)) + (move-to-column column) + for diff = (- column (eglot-lsp-abiding-column lbp)) - until (zerop diff) - do (condition-case eob-err - (forward-char (/ (if (> diff 0) (1+ diff) (1- diff)) 2)) - (end-of-buffer (cl-return eob-err)))))) + until (zerop diff) + do (condition-case eob-err + (forward-char (/ (if (> diff 0) (1+ diff) (1- diff)) 2)) + (end-of-buffer (cl-return eob-err)))))) (defun eglot--lsp-position-to-point (pos-plist &optional marker) "Convert LSP position POS-PLIST to Emacs point. @@ -1464,14 +1468,14 @@ If optional MARKER, return a marker instead" (widen) (goto-char (point-min)) (forward-line (min most-positive-fixnum - (plist-get pos-plist :line))) + (plist-get pos-plist :line))) (unless (eobp) ;; if line was excessive leave point at eob (let ((tab-width 1) - (col (plist-get pos-plist :character))) + (col (plist-get pos-plist :character))) (unless (wholenump col) (eglot--warn - "Caution: LSP server sent invalid character position %s. Using 0 instead." - col) + "Caution: LSP server sent invalid character position %s. Using 0 instead." + col) (setq col 0)) (funcall eglot-move-to-column-function col))) (if marker (copy-marker (point-marker)) (point))))) @@ -1486,50 +1490,50 @@ If optional MARKER, return a marker instead" "URIfy PATH." (let ((truepath (file-truename path))) (concat "file://" - ;; Add a leading "/" for local MS Windows-style paths. - (if (and (eq system-type 'windows-nt) - (not (file-remote-p truepath))) - "/") - (url-hexify-string - ;; Again watch out for trampy paths. - (directory-file-name (file-local-name truepath)) - eglot--uri-path-allowed-chars)))) + ;; Add a leading "/" for local MS Windows-style paths. + (if (and (eq system-type 'windows-nt) + (not (file-remote-p truepath))) + "/") + (url-hexify-string + ;; Again watch out for trampy paths. + (directory-file-name (file-local-name truepath)) + eglot--uri-path-allowed-chars)))) (defun eglot--uri-to-path (uri) "Convert URI to file path, helped by `eglot--current-server'." (when (keywordp uri) (setq uri (substring (symbol-name uri) 1))) (let* ((server (eglot-current-server)) - (remote-prefix (and server (eglot--trampish-p server))) - (retval (url-unhex-string (url-filename (url-generic-parse-url uri)))) - ;; Remove the leading "/" for local MS Windows-style paths. - (normalized (if (and (not remote-prefix) - (eq system-type 'windows-nt) - (cl-plusp (length retval))) - (substring retval 1) - retval))) + (remote-prefix (and server (eglot--trampish-p server))) + (retval (url-unhex-string (url-filename (url-generic-parse-url uri)))) + ;; Remove the leading "/" for local MS Windows-style paths. + (normalized (if (and (not remote-prefix) + (eq system-type 'windows-nt) + (cl-plusp (length retval))) + (substring retval 1) + retval))) (concat remote-prefix normalized))) (defun eglot--snippet-expansion-fn () "Compute a function to expand snippets. Doubles as an indicator of snippet support." (and (boundp 'yas-minor-mode) - (symbol-value 'yas-minor-mode) - 'yas-expand-snippet)) + (symbol-value 'yas-minor-mode) + 'yas-expand-snippet)) (defun eglot--format-markup (markup) "Format MARKUP according to LSP's spec." (pcase-let ((`(,string ,mode) - (if (stringp markup) (list markup 'gfm-view-mode) - (list (plist-get markup :value) - (pcase (plist-get markup :kind) - ("markdown" 'gfm-view-mode) - ("plaintext" 'text-mode) - (_ major-mode)))))) + (if (stringp markup) (list markup 'gfm-view-mode) + (list (plist-get markup :value) + (pcase (plist-get markup :kind) + ("markdown" 'gfm-view-mode) + ("plaintext" 'text-mode) + (_ major-mode)))))) (with-temp-buffer (setq-local markdown-fontify-code-blocks-natively t) (insert string) (let ((inhibit-message t) - (message-log-max nil)) + (message-log-max nil)) (ignore-errors (delay-mode-hooks (funcall mode)))) (font-lock-ensure) (string-trim (buffer-string))))) @@ -1543,49 +1547,50 @@ You could add, for instance, the symbol `:documentHighlightProvider' to prevent automatic highlighting under cursor." :type '(set - :tag "Tick the ones you're not interested in" - (const :tag "Documentation on hover" :hoverProvider) - (const :tag "Code completion" :completionProvider) - (const :tag "Function signature help" :signatureHelpProvider) - (const :tag "Go to definition" :definitionProvider) - (const :tag "Go to type definition" :typeDefinitionProvider) - (const :tag "Go to implementation" :implementationProvider) - (const :tag "Go to declaration" :implementationProvider) - (const :tag "Find references" :referencesProvider) - (const :tag "Highlight symbols automatically" :documentHighlightProvider) - (const :tag "List symbols in buffer" :documentSymbolProvider) - (const :tag "List symbols in workspace" :workspaceSymbolProvider) - (const :tag "Execute code actions" :codeActionProvider) - (const :tag "Code lens" :codeLensProvider) - (const :tag "Format buffer" :documentFormattingProvider) - (const :tag "Format portion of buffer" :documentRangeFormattingProvider) - (const :tag "On-type formatting" :documentOnTypeFormattingProvider) - (const :tag "Rename symbol" :renameProvider) - (const :tag "Highlight links in document" :documentLinkProvider) - (const :tag "Decorate color references" :colorProvider) - (const :tag "Fold regions of buffer" :foldingRangeProvider) - (const :tag "Execute custom commands" :executeCommandProvider))) + :tag "Tick the ones you're not interested in" + (const :tag "Documentation on hover" :hoverProvider) + (const :tag "Code completion" :completionProvider) + (const :tag "Function signature help" :signatureHelpProvider) + (const :tag "Go to definition" :definitionProvider) + (const :tag "Go to type definition" :typeDefinitionProvider) + (const :tag "Go to implementation" :implementationProvider) + (const :tag "Go to declaration" :implementationProvider) + (const :tag "Find references" :referencesProvider) + (const :tag "Highlight symbols automatically" :documentHighlightProvider) + (const :tag "List symbols in buffer" :documentSymbolProvider) + (const :tag "List symbols in workspace" :workspaceSymbolProvider) + (const :tag "Execute code actions" :codeActionProvider) + (const :tag "Code lens" :codeLensProvider) + (const :tag "Inlay Hint" :inlayHintProvider) + (const :tag "Format buffer" :documentFormattingProvider) + (const :tag "Format portion of buffer" :documentRangeFormattingProvider) + (const :tag "On-type formatting" :documentOnTypeFormattingProvider) + (const :tag "Rename symbol" :renameProvider) + (const :tag "Highlight links in document" :documentLinkProvider) + (const :tag "Decorate color references" :colorProvider) + (const :tag "Fold regions of buffer" :foldingRangeProvider) + (const :tag "Execute custom commands" :executeCommandProvider))) (defun eglot--server-capable (&rest feats) "Determine if current server is capable of FEATS." (unless (cl-some (lambda (feat) (memq feat eglot-ignored-server-capabilities)) - feats) + feats) (cl-loop for caps = (eglot--capabilities (eglot--current-server-or-lose)) - then (cadr probe) - for (feat . more) on feats - for probe = (plist-member caps feat) - if (not probe) do (cl-return nil) - if (eq (cadr probe) :json-false) do (cl-return nil) - if (not (listp (cadr probe))) do (cl-return (if more nil (cadr probe))) - finally (cl-return (or (cadr probe) t))))) + then (cadr probe) + for (feat . more) on feats + for probe = (plist-member caps feat) + if (not probe) do (cl-return nil) + if (eq (cadr probe) :json-false) do (cl-return nil) + if (not (listp (cadr probe))) do (cl-return (if more nil (cadr probe))) + finally (cl-return (or (cadr probe) t))))) (defun eglot--range-region (range &optional markers) "Return region (BEG . END) that represents LSP RANGE. If optional MARKERS, make markers." (let* ((st (plist-get range :start)) - (beg (eglot--lsp-position-to-point st markers)) - (end (eglot--lsp-position-to-point (plist-get range :end) markers))) + (beg (eglot--lsp-position-to-point st markers)) + (end (eglot--lsp-position-to-point (plist-get range :end) markers))) (cons beg end))) (defun eglot--read-server (prompt &optional dont-if-just-the-one) @@ -1593,26 +1598,26 @@ If optional MARKERS, make markers." If DONT-IF-JUST-THE-ONE and there's only one server, don't prompt and just return it. PROMPT shouldn't end with a question mark." (let ((servers (cl-loop for servers - being hash-values of eglot--servers-by-project - append servers)) - (name (lambda (srv) - (format "%s %s" (eglot-project-nickname srv) - (eglot--major-modes srv))))) + being hash-values of eglot--servers-by-project + append servers)) + (name (lambda (srv) + (format "%s %s" (eglot-project-nickname srv) + (eglot--major-modes srv))))) (cond ((null servers) - (eglot--error "No servers!")) - ((or (cdr servers) (not dont-if-just-the-one)) - (let* ((default (when-let ((current (eglot-current-server))) - (funcall name current))) - (read (completing-read - (if default - (format "%s (default %s)? " prompt default) - (concat prompt "? ")) - (mapcar name servers) - nil t - nil nil - default))) - (cl-find read servers :key name :test #'equal))) - (t (car servers))))) + (eglot--error "No servers!")) + ((or (cdr servers) (not dont-if-just-the-one)) + (let* ((default (when-let ((current (eglot-current-server))) + (funcall name current))) + (read (completing-read + (if default + (format "%s (default %s)? " prompt default) + (concat prompt "? ")) + (mapcar name servers) + nil t + nil nil + default))) + (cl-find read servers :key name :test #'equal))) + (t (car servers))))) (defun eglot--trampish-p (server) "Tell if SERVER's project root is `file-remote-p'." @@ -1660,9 +1665,9 @@ For example, to keep your Company customization, add the symbol (defun eglot--stay-out-of-p (symbol) "Tell if Eglot should stay of of SYMBOL." (cl-find (symbol-name symbol) eglot-stay-out-of - :test (lambda (s thing) - (let ((re (if (symbolp thing) (symbol-name thing) thing))) - (string-match re s))))) + :test (lambda (s thing) + (let ((re (if (symbolp thing) (symbol-name thing) thing))) + (string-match re s))))) (defmacro eglot--setq-saving (symbol binding) `(unless (or (not (boundp ',symbol)) (eglot--stay-out-of-p ',symbol)) @@ -1681,65 +1686,65 @@ Use `eglot-managed-p' to determine if current buffer is managed.") "Mode for source buffers managed by some Eglot project." :init-value nil :lighter nil :keymap eglot-mode-map (cond - (eglot--managed-mode - (add-hook 'after-change-functions 'eglot--after-change nil t) - (add-hook 'before-change-functions 'eglot--before-change nil t) - (add-hook 'kill-buffer-hook #'eglot--managed-mode-off nil t) - ;; Prepend "didClose" to the hook after the "nonoff", so it will run first - (add-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose nil t) - (add-hook 'before-revert-hook 'eglot--signal-textDocument/didClose nil t) - (add-hook 'after-revert-hook 'eglot--after-revert-hook nil t) - (add-hook 'before-save-hook 'eglot--signal-textDocument/willSave nil t) - (add-hook 'after-save-hook 'eglot--signal-textDocument/didSave nil t) - (unless (eglot--stay-out-of-p 'xref) - (add-hook 'xref-backend-functions 'eglot-xref-backend nil t)) - (add-hook 'completion-at-point-functions #'eglot-completion-at-point nil t) - (add-hook 'change-major-mode-hook #'eglot--managed-mode-off nil t) - (add-hook 'post-self-insert-hook 'eglot--post-self-insert-hook nil t) - (add-hook 'pre-command-hook 'eglot--pre-command-hook nil t) - (eglot--setq-saving eldoc-documentation-functions - '(eglot-signature-eldoc-function - eglot-hover-eldoc-function)) - (eglot--setq-saving eldoc-documentation-strategy - #'eldoc-documentation-enthusiast) - (eglot--setq-saving xref-prompt-for-identifier nil) - (eglot--setq-saving flymake-diagnostic-functions '(eglot-flymake-backend)) - (eglot--setq-saving company-backends '(company-capf)) - (eglot--setq-saving company-tooltip-align-annotations t) - (unless (eglot--stay-out-of-p 'imenu) - (add-function :before-until (local 'imenu-create-index-function) - #'eglot-imenu)) - (unless (eglot--stay-out-of-p 'flymake) (flymake-mode 1)) - (unless (eglot--stay-out-of-p 'eldoc) (eldoc-mode 1)) - (cl-pushnew (current-buffer) (eglot--managed-buffers (eglot-current-server)))) - (t - (remove-hook 'after-change-functions 'eglot--after-change t) - (remove-hook 'before-change-functions 'eglot--before-change t) - (remove-hook 'kill-buffer-hook #'eglot--managed-mode-off t) - (remove-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose t) - (remove-hook 'before-revert-hook 'eglot--signal-textDocument/didClose t) - (remove-hook 'after-revert-hook 'eglot--after-revert-hook t) - (remove-hook 'before-save-hook 'eglot--signal-textDocument/willSave t) - (remove-hook 'after-save-hook 'eglot--signal-textDocument/didSave t) - (remove-hook 'xref-backend-functions 'eglot-xref-backend t) - (remove-hook 'completion-at-point-functions #'eglot-completion-at-point t) - (remove-hook 'change-major-mode-hook #'eglot--managed-mode-off t) - (remove-hook 'post-self-insert-hook 'eglot--post-self-insert-hook t) - (remove-hook 'pre-command-hook 'eglot--pre-command-hook t) - (cl-loop for (var . saved-binding) in eglot--saved-bindings - do (set (make-local-variable var) saved-binding)) - (remove-function (local 'imenu-create-index-function) #'eglot-imenu) - (when eglot--current-flymake-report-fn - (eglot--report-to-flymake nil) - (setq eglot--current-flymake-report-fn nil)) - (let ((server eglot--cached-server)) - (setq eglot--cached-server nil) - (when server - (setf (eglot--managed-buffers server) - (delq (current-buffer) (eglot--managed-buffers server))) - (when (and eglot-autoshutdown - (null (eglot--managed-buffers server))) - (eglot-shutdown server)))))) + (eglot--managed-mode + (add-hook 'after-change-functions 'eglot--after-change nil t) + (add-hook 'before-change-functions 'eglot--before-change nil t) + (add-hook 'kill-buffer-hook #'eglot--managed-mode-off nil t) + ;; Prepend "didClose" to the hook after the "nonoff", so it will run first + (add-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose nil t) + (add-hook 'before-revert-hook 'eglot--signal-textDocument/didClose nil t) + (add-hook 'after-revert-hook 'eglot--after-revert-hook nil t) + (add-hook 'before-save-hook 'eglot--signal-textDocument/willSave nil t) + (add-hook 'after-save-hook 'eglot--signal-textDocument/didSave nil t) + (unless (eglot--stay-out-of-p 'xref) + (add-hook 'xref-backend-functions 'eglot-xref-backend nil t)) + (add-hook 'completion-at-point-functions #'eglot-completion-at-point nil t) + (add-hook 'change-major-mode-hook #'eglot--managed-mode-off nil t) + (add-hook 'post-self-insert-hook 'eglot--post-self-insert-hook nil t) + (add-hook 'pre-command-hook 'eglot--pre-command-hook nil t) + (eglot--setq-saving eldoc-documentation-functions + '(eglot-signature-eldoc-function + eglot-hover-eldoc-function)) + (eglot--setq-saving eldoc-documentation-strategy + #'eldoc-documentation-enthusiast) + (eglot--setq-saving xref-prompt-for-identifier nil) + (eglot--setq-saving flymake-diagnostic-functions '(eglot-flymake-backend)) + (eglot--setq-saving company-backends '(company-capf)) + (eglot--setq-saving company-tooltip-align-annotations t) + (unless (eglot--stay-out-of-p 'imenu) + (add-function :before-until (local 'imenu-create-index-function) + #'eglot-imenu)) + (unless (eglot--stay-out-of-p 'flymake) (flymake-mode 1)) + (unless (eglot--stay-out-of-p 'eldoc) (eldoc-mode 1)) + (cl-pushnew (current-buffer) (eglot--managed-buffers (eglot-current-server)))) + (t + (remove-hook 'after-change-functions 'eglot--after-change t) + (remove-hook 'before-change-functions 'eglot--before-change t) + (remove-hook 'kill-buffer-hook #'eglot--managed-mode-off t) + (remove-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose t) + (remove-hook 'before-revert-hook 'eglot--signal-textDocument/didClose t) + (remove-hook 'after-revert-hook 'eglot--after-revert-hook t) + (remove-hook 'before-save-hook 'eglot--signal-textDocument/willSave t) + (remove-hook 'after-save-hook 'eglot--signal-textDocument/didSave t) + (remove-hook 'xref-backend-functions 'eglot-xref-backend t) + (remove-hook 'completion-at-point-functions #'eglot-completion-at-point t) + (remove-hook 'change-major-mode-hook #'eglot--managed-mode-off t) + (remove-hook 'post-self-insert-hook 'eglot--post-self-insert-hook t) + (remove-hook 'pre-command-hook 'eglot--pre-command-hook t) + (cl-loop for (var . saved-binding) in eglot--saved-bindings + do (set (make-local-variable var) saved-binding)) + (remove-function (local 'imenu-create-index-function) #'eglot-imenu) + (when eglot--current-flymake-report-fn + (eglot--report-to-flymake nil) + (setq eglot--current-flymake-report-fn nil)) + (let ((server eglot--cached-server)) + (setq eglot--cached-server nil) + (when server + (setf (eglot--managed-buffers server) + (delq (current-buffer) (eglot--managed-buffers server))) + (when (and eglot-autoshutdown + (null (eglot--managed-buffers server))) + (eglot-shutdown server)))))) ;; Note: the public hook runs before the internal eglot--managed-mode-hook. (run-hooks 'eglot-managed-mode-hook)) @@ -1750,20 +1755,20 @@ Use `eglot-managed-p' to determine if current buffer is managed.") (defun eglot-current-server () "Return logical Eglot server for current buffer, nil if none." (setq eglot--cached-server - (or eglot--cached-server - (cl-find major-mode - (gethash (eglot--current-project) eglot--servers-by-project) - :key #'eglot--major-modes - :test #'memq) - (and eglot-extend-to-xref - buffer-file-name - (gethash (expand-file-name buffer-file-name) - eglot--servers-by-xrefed-file))))) + (or eglot--cached-server + (cl-find major-mode + (gethash (eglot--current-project) eglot--servers-by-project) + :key #'eglot--major-modes + :test #'memq) + (and eglot-extend-to-xref + buffer-file-name + (gethash (expand-file-name buffer-file-name) + eglot--servers-by-xrefed-file))))) (defun eglot--current-server-or-lose () "Return current logical Eglot server connection or error." (or (eglot-current-server) - (jsonrpc-error "No current JSON-RPC connection"))) + (jsonrpc-error "No current JSON-RPC connection"))) (defvar-local eglot--diagnostics nil "Flymake diagnostics for this buffer.") @@ -1807,7 +1812,7 @@ If it is activated, also signal textDocument/didOpen." (let ((start (event-start event))) (with-selected-window (posn-window start) (save-excursion (goto-char (or (posn-point start) - (point))) + (point))) (call-interactively what) (force-mode-line-update t)))))) @@ -1816,131 +1821,138 @@ If it is activated, also signal textDocument/didOpen." (easy-menu-define eglot-menu nil "Eglot" `("Eglot" - ;; Commands for getting information and customization. - ["Read manual" eglot-manual] - ["Customize Eglot" (lambda () (interactive) (customize-group "eglot"))] - "--" - ;; xref like commands. - ["Find definitions" xref-find-definitions - :help "Find definitions of identifier at point" - :active (eglot--server-capable :definitionProvider)] - ["Find references" xref-find-references - :help "Find references to identifier at point" - :active (eglot--server-capable :referencesProvider)] - ["Find symbols in workspace (apropos)" xref-find-apropos - :help "Find symbols matching a query" - :active (eglot--server-capable :workspaceSymbolProvider)] - ["Find declaration" eglot-find-declaration - :help "Find declaration for identifier at point" - :active (eglot--server-capable :declarationProvider)] - ["Find implementation" eglot-find-implementation - :help "Find implementation for identifier at point" - :active (eglot--server-capable :implementationProvider)] - ["Find type definition" eglot-find-typeDefinition - :help "Find type definition for identifier at point" - :active (eglot--server-capable :typeDefinitionProvider)] - "--" - ;; LSP-related commands (mostly Eglot's own commands). - ["Rename symbol" eglot-rename - :active (eglot--server-capable :renameProvider)] - ["Format buffer" eglot-format-buffer - :active (eglot--server-capable :documentFormattingProvider)] - ["Format active region" eglot-format - :active (and (region-active-p) - (eglot--server-capable :documentRangeFormattingProvider))] - ["Show Flymake diagnostics for buffer" flymake-show-buffer-diagnostics] - ["Show Flymake diagnostics for project" flymake-show-project-diagnostics] - ["Show Eldoc documentation at point" eldoc-doc-buffer] - "--" - ["All possible code actions" eglot-code-actions - :active (eglot--server-capable :codeActionProvider)] - ["Organize imports" eglot-code-action-organize-imports - :visible (eglot--server-capable :codeActionProvider)] - ["Extract" eglot-code-action-extract - :visible (eglot--server-capable :codeActionProvider)] - ["Inline" eglot-code-action-inline - :visible (eglot--server-capable :codeActionProvider)] - ["Rewrite" eglot-code-action-rewrite - :visible (eglot--server-capable :codeActionProvider)] - ["Quickfix" eglot-code-action-quickfix - :visible (eglot--server-capable :codeActionProvider)])) + ;; Commands for getting information and customization. + ["Read manual" eglot-manual] + ["Customize Eglot" (lambda () (interactive) (customize-group "eglot"))] + "--" + ;; xref like commands. + ["Find definitions" xref-find-definitions + :help "Find definitions of identifier at point" + :active (eglot--server-capable :definitionProvider)] + ["Find references" xref-find-references + :help "Find references to identifier at point" + :active (eglot--server-capable :referencesProvider)] + ["Find symbols in workspace (apropos)" xref-find-apropos + :help "Find symbols matching a query" + :active (eglot--server-capable :workspaceSymbolProvider)] + ["Find declaration" eglot-find-declaration + :help "Find declaration for identifier at point" + :active (eglot--server-capable :declarationProvider)] + ["Find implementation" eglot-find-implementation + :help "Find implementation for identifier at point" + :active (eglot--server-capable :implementationProvider)] + ["Find type definition" eglot-find-typeDefinition + :help "Find type definition for identifier at point" + :active (eglot--server-capable :typeDefinitionProvider)] + "--" + ;; LSP-related commands (mostly Eglot's own commands). + ["Rename symbol" eglot-rename + :active (eglot--server-capable :renameProvider)] + ["Format buffer" eglot-format-buffer + :active (eglot--server-capable :documentFormattingProvider)] + ["Format active region" eglot-format + :active (and (region-active-p) + (eglot--server-capable :documentRangeFormattingProvider))] + ["Show Flymake diagnostics for buffer" flymake-show-buffer-diagnostics] + ["Show Flymake diagnostics for project" flymake-show-project-diagnostics] + ["Show Eldoc documentation at point" eldoc-doc-buffer] + "--" + ["All possible code actions" eglot-code-actions + :active (eglot--server-capable :codeActionProvider)] + ["Organize imports" eglot-code-action-organize-imports + :visible (eglot--server-capable :codeActionProvider)] + ["Extract" eglot-code-action-extract + :visible (eglot--server-capable :codeActionProvider)] + ["Inline" eglot-code-action-inline + :visible (eglot--server-capable :codeActionProvider)] + ["Rewrite" eglot-code-action-rewrite + :visible (eglot--server-capable :codeActionProvider)] + ["Quickfix" eglot-code-action-quickfix + :visible (eglot--server-capable :codeActionProvider)])) (easy-menu-define eglot-server-menu nil "Monitor server communication" '("Debugging the server communication" - ["Reconnect to server" eglot-reconnect] - ["Quit server" eglot-shutdown] - "--" - ["LSP events buffer" eglot-events-buffer] - ["Server stderr buffer" eglot-stderr-buffer] - ["Customize event buffer size" - (lambda () - (interactive) - (customize-variable 'eglot-events-buffer-size))])) + ["Reconnect to server" eglot-reconnect] + ["Quit server" eglot-shutdown] + "--" + ["LSP events buffer" eglot-events-buffer] + ["Server stderr buffer" eglot-stderr-buffer] + ["Customize event buffer size" + (lambda () + (interactive) + (customize-variable 'eglot-events-buffer-size))])) (defun eglot--mode-line-props (thing face defs &optional prepend) "Helper for function `eglot--mode-line-format'. Uses THING, FACE, DEFS and PREPEND." (cl-loop with map = (make-sparse-keymap) - for (elem . rest) on defs - for (key def help) = elem - do (define-key map `[mode-line ,key] (eglot--mouse-call def)) - concat (format "%s: %s" key help) into blurb - when rest concat "\n" into blurb - finally (return `(:propertize ,thing - face ,face - keymap ,map help-echo ,(concat prepend blurb) - mouse-face mode-line-highlight)))) + for (elem . rest) on defs + for (key def help) = elem + do (define-key map `[mode-line ,key] (eglot--mouse-call def)) + concat (format "%s: %s" key help) into blurb + when rest concat "\n" into blurb + finally (return `(:propertize ,thing + face ,face + keymap ,map help-echo ,(concat prepend blurb) + mouse-face mode-line-highlight)))) (defun eglot--mode-line-format () "Compose the Eglot's mode-line." (pcase-let* ((server (eglot-current-server)) - (nick (and server (eglot-project-nickname server))) - (pending (and server (hash-table-count - (jsonrpc--request-continuations server)))) - (`(,_id ,doing ,done-p ,_detail) (and server (eglot--spinner server))) - (last-error (and server (jsonrpc-last-error server)))) + (nick (and server (eglot-project-nickname server))) + (pending (and server (hash-table-count + (jsonrpc--request-continuations server)))) + (`(,_id ,doing ,done-p ,_detail) (and server (eglot--spinner server))) + (last-error (and server (jsonrpc-last-error server)))) (append - `(,(propertize - eglot-menu-string - 'face 'eglot-mode-line - 'mouse-face 'mode-line-highlight - 'help-echo "Eglot: Emacs LSP client\nmouse-1: Display minor mode menu" - 'keymap (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] eglot-menu) - map))) - (when nick - `(":" - ,(propertize - nick + `(,(propertize + eglot-menu-string 'face 'eglot-mode-line 'mouse-face 'mode-line-highlight - 'help-echo (format "Project '%s'\nmouse-1: LSP server control menu" nick) + 'help-echo "Eglot: Emacs LSP client\nmouse-1: Display minor mode menu" 'keymap (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] eglot-server-menu) - map)) - ,@(when last-error - `("/" ,(eglot--mode-line-props - "error" 'compilation-mode-line-fail - '((mouse-3 eglot-clear-status "Clear this status")) - (format "An error occurred: %s\n" (plist-get last-error - :message))))) - ,@(when (and doing (not done-p)) - `("/" ,(eglot--mode-line-props doing - 'compilation-mode-line-run '()))) - ,@(when (cl-plusp pending) - `("/" ,(eglot--mode-line-props - (format "%d" pending) 'warning - '((mouse-3 eglot-forget-pending-continuations - "Forget pending continuations")) - "Number of outgoing, \ + (define-key map [mode-line down-mouse-1] eglot-menu) + map))) + (when nick + `(":" + ,(propertize + nick + 'face 'eglot-mode-line + 'mouse-face 'mode-line-highlight + 'help-echo (format "Project '%s'\nmouse-1: LSP server control menu" nick) + 'keymap (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] eglot-server-menu) + map)) + ,@(when last-error + `("/" ,(eglot--mode-line-props + "error" 'compilation-mode-line-fail + '((mouse-3 eglot-clear-status "Clear this status")) + (format "An error occurred: %s\n" (plist-get last-error + :message))))) + ,@(when (and doing (not done-p)) + `("/" ,(eglot--mode-line-props doing + 'compilation-mode-line-run '()))) + ,@(when (cl-plusp pending) + `("/" ,(eglot--mode-line-props + (format "%d" pending) 'warning + '((mouse-3 eglot-forget-pending-continuations + "Forget pending continuations")) + "Number of outgoing, \ still unanswered LSP requests to the server\n")))))))) (add-to-list 'mode-line-misc-info - `(eglot--managed-mode (" [" eglot--mode-line-format "] "))) + `(eglot--managed-mode (" [" eglot--mode-line-format "] "))) ;;; Flymake customization ;;; +;; TODO: type hint and different signature hint? (and future proof generic hint?) +;;(put 'eglot-hint 'flymake-bitmap nil) +;;(put 'eglot-hint 'severity (warning-numeric-level :debug)) +;;(put 'eglot-hint 'flymake-type-name "hint") +;;(put 'eglot-hint 'face nil) +(put 'eglot-hint 'flymake-category 'flymake-note) + (put 'eglot-note 'flymake-category 'flymake-note) (put 'eglot-warning 'flymake-category 'flymake-warning) (put 'eglot-error 'flymake-category 'flymake-error) @@ -1949,14 +1961,14 @@ still unanswered LSP requests to the server\n")))))))) (defalias 'eglot--diag-data 'flymake-diagnostic-data) (cl-loop for i from 1 - for type in '(eglot-note eglot-warning eglot-error ) - do (put type 'flymake-overlay-control - `((mouse-face . highlight) - (priority . ,(+ 50 i)) - (keymap . ,(let ((map (make-sparse-keymap))) - (define-key map [mouse-1] - (eglot--mouse-call 'eglot-code-actions)) - map))))) + for type in '(eglot-note eglot-warning eglot-error ) + do (put type 'flymake-overlay-control + `((mouse-face . highlight) + (priority . ,(+ 50 i)) + (keymap . ,(let ((map (make-sparse-keymap))) + (define-key map [mouse-1] + (eglot--mouse-call 'eglot-code-actions)) + map))))) ;;; Protocol implementation (Requests, notifications, etc) @@ -1965,7 +1977,7 @@ still unanswered LSP requests to the server\n")))))))) (_server method &key &allow-other-keys) "Handle unknown notification." (unless (or (string-prefix-p "$" (format "%s" method)) - (not (memq 'disallow-unknown-methods eglot-strict-mode))) + (not (memq 'disallow-unknown-methods eglot-strict-mode))) (eglot--warn "Server sent unknown notification method `%s'" method))) (cl-defmethod eglot-handle-request @@ -1979,28 +1991,28 @@ still unanswered LSP requests to the server\n")))))))) "Execute COMMAND on SERVER with `:workspace/executeCommand'. COMMAND is a symbol naming the command." (jsonrpc-request server :workspace/executeCommand - `(:command ,(format "%s" command) :arguments ,arguments))) + `(:command ,(format "%s" command) :arguments ,arguments))) (cl-defmethod eglot-handle-notification (_server (_method (eql window/showMessage)) &key type message) "Handle notification window/showMessage." (eglot--message (propertize "Server reports (type=%s): %s" - 'face (if (<= type 1) 'error)) - type message)) + 'face (if (<= type 1) 'error)) + type message)) (cl-defmethod eglot-handle-request (_server (_method (eql window/showMessageRequest)) &key type message actions) "Handle server request window/showMessageRequest." (let* ((actions (append actions nil)) ;; gh#627 - (label (completing-read - (concat - (format (propertize "[eglot] Server reports (type=%s): %s" - 'face (if (<= type 1) 'error)) - type message) - "\nChoose an option: ") - (or (mapcar (lambda (obj) (plist-get obj :title)) actions) + (label (completing-read + (concat + (format (propertize "[eglot] Server reports (type=%s): %s" + 'face (if (<= type 1) 'error)) + type message) + "\nChoose an option: ") + (or (mapcar (lambda (obj) (plist-get obj :title)) actions) '("OK")) - nil t (plist-get (elt actions 0) :title)))) + nil t (plist-get (elt actions 0) :title)))) (if label `(:title ,label) :null))) (cl-defmethod eglot-handle-notification @@ -2013,85 +2025,85 @@ COMMAND is a symbol naming the command." (cl-defmethod eglot-handle-notification (_server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics - &allow-other-keys) ; FIXME: doesn't respect `eglot-strict-mode' + &allow-other-keys) ; FIXME: doesn't respect `eglot-strict-mode' "Handle notification publishDiagnostics." (cl-flet ((eglot--diag-type (sev) (cond ((null sev) 'eglot-error) - ((<= sev 1) 'eglot-error) - ((= sev 2) 'eglot-warning) - (t 'eglot-note))) - (mess (source code message) - (concat source (and code (format " [%s]" code)) ": " message))) + ((<= sev 1) 'eglot-error) + ((= sev 2) 'eglot-warning) + (t 'eglot-note))) + (mess (source code message) + (concat source (and code (format " [%s]" code)) ": " message))) (if-let ((buffer (find-buffer-visiting (eglot--uri-to-path uri)))) - (with-current-buffer buffer - (cl-loop - for diag-spec across diagnostics - collect (eglot--dbind ((Diagnostic) range code message severity source tags) - diag-spec - (setq message (mess source code message)) - (pcase-let - ((`(,beg . ,end) (eglot--range-region range))) - ;; Fallback to `flymake-diag-region' if server - ;; botched the range - (when (= beg end) - (if-let* ((st (plist-get range :start)) + (with-current-buffer buffer + (cl-loop + for diag-spec across diagnostics + collect (eglot--dbind ((Diagnostic) range code message severity source tags) + diag-spec + (setq message (mess source code message)) + (pcase-let + ((`(,beg . ,end) (eglot--range-region range))) + ;; Fallback to `flymake-diag-region' if server + ;; botched the range + (when (= beg end) + (if-let* ((st (plist-get range :start)) (diag-region - (flymake-diag-region - (current-buffer) (1+ (plist-get st :line)) - (plist-get st :character)))) - (setq beg (car diag-region) end (cdr diag-region)) - (eglot--widening + (flymake-diag-region + (current-buffer) (1+ (plist-get st :line)) + (plist-get st :character)))) + (setq beg (car diag-region) end (cdr diag-region)) + (eglot--widening (goto-char (point-min)) (setq beg - (line-beginning-position - (1+ (plist-get (plist-get range :start) :line)))) + (line-beginning-position + (1+ (plist-get (plist-get range :start) :line)))) (setq end - (line-end-position - (1+ (plist-get (plist-get range :end) :line))))))) - (eglot--make-diag + (line-end-position + (1+ (plist-get (plist-get range :end) :line))))))) + (eglot--make-diag (current-buffer) beg end (eglot--diag-type severity) message `((eglot-lsp-diag . ,diag-spec)) (when-let ((faces - (cl-loop for tag across tags - when (alist-get tag eglot--tag-faces) - collect it))) + (cl-loop for tag across tags + when (alist-get tag eglot--tag-faces) + collect it))) `((face . ,faces)))))) - into diags - finally (cond ((and + into diags + finally (cond ((and ;; only add to current report if Flymake ;; starts on idle-timer (github#958) (not (null flymake-no-changes-timeout)) eglot--current-flymake-report-fn) (eglot--report-to-flymake diags)) - (t - (setq eglot--diagnostics diags))))) + (t + (setq eglot--diagnostics diags))))) (cl-loop - with path = (expand-file-name (eglot--uri-to-path uri)) - for diag-spec across diagnostics - collect (eglot--dbind ((Diagnostic) code range message severity source) diag-spec - (setq message (mess source code message)) - (let* ((start (plist-get range :start)) - (line (1+ (plist-get start :line))) - (char (1+ (plist-get start :character)))) - (eglot--make-diag - path (cons line char) nil (eglot--diag-type severity) message))) - into diags - finally - (setq flymake-list-only-diagnostics - (assoc-delete-all path flymake-list-only-diagnostics #'string=)) - (push (cons path diags) flymake-list-only-diagnostics))))) + with path = (expand-file-name (eglot--uri-to-path uri)) + for diag-spec across diagnostics + collect (eglot--dbind ((Diagnostic) code range message severity source) diag-spec + (setq message (mess source code message)) + (let* ((start (plist-get range :start)) + (line (1+ (plist-get start :line))) + (char (1+ (plist-get start :character)))) + (eglot--make-diag + path (cons line char) nil (eglot--diag-type severity) message))) + into diags + finally + (setq flymake-list-only-diagnostics + (assoc-delete-all path flymake-list-only-diagnostics #'string=)) + (push (cons path diags) flymake-list-only-diagnostics))))) (cl-defun eglot--register-unregister (server things how) "Helper for `registerCapability'. THINGS are either registrations or unregisterations (sic)." (cl-loop - for thing in (cl-coerce things 'list) - do (eglot--dbind ((Registration) id method registerOptions) thing - (apply (cl-ecase how - (register 'eglot-register-capability) - (unregister 'eglot-unregister-capability)) - server (intern method) id registerOptions)))) + for thing in (cl-coerce things 'list) + do (eglot--dbind ((Registration) id method registerOptions) thing + (apply (cl-ecase how + (register 'eglot-register-capability) + (unregister 'eglot-unregister-capability)) + server (intern method) id registerOptions)))) (cl-defmethod eglot-handle-request (server (_method (eql client/registerCapability)) &key registrations) @@ -2100,7 +2112,7 @@ THINGS are either registrations or unregisterations (sic)." (cl-defmethod eglot-handle-request (server (_method (eql client/unregisterCapability)) - &key unregisterations) ;; XXX: "unregisterations" (sic) + &key unregisterations) ;; XXX: "unregisterations" (sic) "Handle server request client/unregisterCapability." (eglot--register-unregister server unregisterations 'unregister)) @@ -2118,31 +2130,31 @@ THINGS are either registrations or unregisterations (sic)." (defun eglot--TextDocumentIdentifier () "Compute TextDocumentIdentifier object for current buffer." `(:uri ,(eglot--path-to-uri (or buffer-file-name - (ignore-errors - (buffer-file-name - (buffer-base-buffer))))))) + (ignore-errors + (buffer-file-name + (buffer-base-buffer))))))) (defvar-local eglot--versioned-identifier 0) (defun eglot--VersionedTextDocumentIdentifier () "Compute VersionedTextDocumentIdentifier object for current buffer." (append (eglot--TextDocumentIdentifier) - `(:version ,eglot--versioned-identifier))) + `(:version ,eglot--versioned-identifier))) (defun eglot--TextDocumentItem () "Compute TextDocumentItem object for current buffer." (append - (eglot--VersionedTextDocumentIdentifier) - (list :languageId - (eglot--language-id (eglot--current-server-or-lose)) - :text - (eglot--widening - (buffer-substring-no-properties (point-min) (point-max)))))) + (eglot--VersionedTextDocumentIdentifier) + (list :languageId + (eglot--language-id (eglot--current-server-or-lose)) + :text + (eglot--widening + (buffer-substring-no-properties (point-min) (point-max)))))) (defun eglot--TextDocumentPositionParams () "Compute TextDocumentPositionParams." (list :textDocument (eglot--TextDocumentIdentifier) - :position (eglot--pos-to-lsp-position))) + :position (eglot--pos-to-lsp-position))) (defvar-local eglot--last-inserted-char nil "If non-nil, value of the last inserted character in buffer.") @@ -2152,12 +2164,12 @@ THINGS are either registrations or unregisterations (sic)." (setq eglot--last-inserted-char last-input-event) (let ((ot-provider (eglot--server-capable :documentOnTypeFormattingProvider))) (when (and ot-provider - (ignore-errors ; github#906, some LS's send empty strings - (or (eq last-input-event - (seq-first (plist-get ot-provider :firstTriggerCharacter))) - (cl-find last-input-event - (plist-get ot-provider :moreTriggerCharacter) - :key #'seq-first)))) + (ignore-errors ; github#906, some LS's send empty strings + (or (eq last-input-event + (seq-first (plist-get ot-provider :firstTriggerCharacter))) + (cl-find last-input-event + (plist-get ot-provider :moreTriggerCharacter) + :key #'seq-first)))) (eglot-format (point) nil last-input-event)))) (defvar eglot--workspace-symbols-cache (make-hash-table :test #'equal) @@ -2170,14 +2182,14 @@ THINGS are either registrations or unregisterations (sic)." (defun eglot--CompletionParams () (append - (eglot--TextDocumentPositionParams) - `(:context - ,(if-let (trigger (and (characterp eglot--last-inserted-char) - (cl-find eglot--last-inserted-char - (eglot--server-capable :completionProvider - :triggerCharacters) - :key (lambda (str) (aref str 0)) - :test #'char-equal))) + (eglot--TextDocumentPositionParams) + `(:context + ,(if-let (trigger (and (characterp eglot--last-inserted-char) + (cl-find eglot--last-inserted-char + (eglot--server-capable :completionProvider + :triggerCharacters) + :key (lambda (str) (aref str 0)) + :test #'char-equal))) `(:triggerKind 2 :triggerCharacter ,trigger) `(:triggerKind 1))))) (defvar-local eglot--recent-changes nil @@ -2198,63 +2210,63 @@ THINGS are either registrations or unregisterations (sic)." ;; deleted/added). Also record markers of BEG and END ;; (github#259) (push `(,(eglot--pos-to-lsp-position beg) - ,(eglot--pos-to-lsp-position end) - (,beg . ,(copy-marker beg nil)) - (,end . ,(copy-marker end t))) - eglot--recent-changes))) + ,(eglot--pos-to-lsp-position end) + (,beg . ,(copy-marker beg nil)) + (,end . ,(copy-marker end t))) + eglot--recent-changes))) (defun eglot--after-change (beg end pre-change-length) "Hook onto `after-change-functions'. Records BEG, END and PRE-CHANGE-LENGTH locally." (cl-incf eglot--versioned-identifier) (pcase (and (listp eglot--recent-changes) - (car eglot--recent-changes)) + (car eglot--recent-changes)) (`(,lsp-beg ,lsp-end - (,b-beg . ,b-beg-marker) - (,b-end . ,b-end-marker)) - ;; github#259 and github#367: With `capitalize-word' or somesuch, - ;; `before-change-functions' always records the whole word's - ;; `b-beg' and `b-end'. Similarly, when coalescing two lines - ;; into one, `fill-paragraph' they mark the end of the first line - ;; up to the end of the second line. In both situations, args - ;; received here contradict that information: `beg' and `end' - ;; will differ by 1 and will likely only encompass the letter - ;; that was capitalized or, in the sentence-joining situation, - ;; the replacement of the newline with a space. That's we keep - ;; markers _and_ positions so we're able to detect and correct - ;; this. We ignore `beg', `len' and `pre-change-len' and send - ;; "fuller" information about the region from the markers. I've - ;; also experimented with doing this unconditionally but it seems - ;; to break when newlines are added. - (if (and (= b-end b-end-marker) (= b-beg b-beg-marker) - (or (/= beg b-beg) (/= end b-end))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,(- b-end-marker b-beg-marker) - ,(buffer-substring-no-properties b-beg-marker - b-end-marker))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,pre-change-length - ,(buffer-substring-no-properties beg end))))) + (,b-beg . ,b-beg-marker) + (,b-end . ,b-end-marker)) + ;; github#259 and github#367: With `capitalize-word' or somesuch, + ;; `before-change-functions' always records the whole word's + ;; `b-beg' and `b-end'. Similarly, when coalescing two lines + ;; into one, `fill-paragraph' they mark the end of the first line + ;; up to the end of the second line. In both situations, args + ;; received here contradict that information: `beg' and `end' + ;; will differ by 1 and will likely only encompass the letter + ;; that was capitalized or, in the sentence-joining situation, + ;; the replacement of the newline with a space. That's we keep + ;; markers _and_ positions so we're able to detect and correct + ;; this. We ignore `beg', `len' and `pre-change-len' and send + ;; "fuller" information about the region from the markers. I've + ;; also experimented with doing this unconditionally but it seems + ;; to break when newlines are added. + (if (and (= b-end b-end-marker) (= b-beg b-beg-marker) + (or (/= beg b-beg) (/= end b-end))) + (setcar eglot--recent-changes + `(,lsp-beg ,lsp-end ,(- b-end-marker b-beg-marker) + ,(buffer-substring-no-properties b-beg-marker + b-end-marker))) + (setcar eglot--recent-changes + `(,lsp-beg ,lsp-end ,pre-change-length + ,(buffer-substring-no-properties beg end))))) (_ (setf eglot--recent-changes :emacs-messup))) (when eglot--change-idle-timer (cancel-timer eglot--change-idle-timer)) (let ((buf (current-buffer))) (setq eglot--change-idle-timer - (run-with-idle-timer - eglot-send-changes-idle-time - nil (lambda () (eglot--when-live-buffer buf - (when eglot--managed-mode - (eglot--signal-textDocument/didChange) - (setq eglot--change-idle-timer nil)))))))) + (run-with-idle-timer + eglot-send-changes-idle-time + nil (lambda () (eglot--when-live-buffer buf + (when eglot--managed-mode + (eglot--signal-textDocument/didChange) + (setq eglot--change-idle-timer nil)))))))) ;; HACK! Launching 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 `jsonrpc-connection-ready-p'. (advice-add #'jsonrpc-request :before - (cl-function (lambda (_proc _method _params &key - deferred &allow-other-keys) - (when (and eglot--managed-mode deferred) - (eglot--signal-textDocument/didChange)))) - '((name . eglot--signal-textDocument/didChange))) + (cl-function (lambda (_proc _method _params &key + deferred &allow-other-keys) + (when (and eglot--managed-mode deferred) + (eglot--signal-textDocument/didChange)))) + '((name . eglot--signal-textDocument/didChange))) (defvar-local eglot-workspace-configuration () "Configure LSP servers specifically for a given project. @@ -2291,8 +2303,8 @@ format described above.") (defun eglot-show-workspace-configuration (&optional server) "Dump `eglot-workspace-configuration' as JSON for debugging." (interactive (list (and (eglot-current-server) - (eglot--read-server "Server configuration" - (eglot-current-server))))) + (eglot--read-server "Server configuration" + (eglot-current-server))))) (let ((conf (eglot--workspace-configuration-plist server))) (with-current-buffer (get-buffer-create "*EGLOT workspace configuration*") (erase-buffer) @@ -2305,83 +2317,83 @@ format described above.") (defun eglot--workspace-configuration (server) (if (functionp eglot-workspace-configuration) - (funcall eglot-workspace-configuration server) + (funcall eglot-workspace-configuration server) eglot-workspace-configuration)) (defun eglot--workspace-configuration-plist (server) "Returns `eglot-workspace-configuration' suitable for serialization." (let ((val (eglot--workspace-configuration server))) (or (and (consp (car val)) - (cl-loop for (section . v) in val - collect (if (keywordp section) section - (intern (format ":%s" section))) - collect v)) - val))) + (cl-loop for (section . v) in val + collect (if (keywordp section) section + (intern (format ":%s" section))) + collect v)) + val))) (defun eglot-signal-didChangeConfiguration (server) "Send a `:workspace/didChangeConfiguration' signal to SERVER. When called interactively, use the currently active server" (interactive (list (eglot--current-server-or-lose))) (jsonrpc-notify - server :workspace/didChangeConfiguration - (list - :settings - (or (eglot--workspace-configuration-plist server) + server :workspace/didChangeConfiguration + (list + :settings + (or (eglot--workspace-configuration-plist server) eglot--{})))) (cl-defmethod eglot-handle-request (server (_method (eql workspace/configuration)) &key items) "Handle server request workspace/configuration." (apply #'vector - (mapcar - (eglot--lambda ((ConfigurationItem) scopeUri section) - (with-temp-buffer - (let* ((uri-path (eglot--uri-to-path scopeUri)) - (default-directory - (if (and (not (string-empty-p uri-path)) - (file-directory-p uri-path)) - (file-name-as-directory uri-path) - (project-root (eglot--project server))))) - (setq-local major-mode (car (eglot--major-modes server))) - (hack-dir-local-variables-non-file-buffer) - (cl-loop for (wsection o) - on (eglot--workspace-configuration-plist server) - by #'cddr - when (string= - (if (keywordp wsection) - (substring (symbol-name wsection) 1) - wsection) - section) - return o)))) - items))) + (mapcar + (eglot--lambda ((ConfigurationItem) scopeUri section) + (with-temp-buffer + (let* ((uri-path (eglot--uri-to-path scopeUri)) + (default-directory + (if (and (not (string-empty-p uri-path)) + (file-directory-p uri-path)) + (file-name-as-directory uri-path) + (project-root (eglot--project server))))) + (setq-local major-mode (car (eglot--major-modes server))) + (hack-dir-local-variables-non-file-buffer) + (cl-loop for (wsection o) + on (eglot--workspace-configuration-plist server) + by #'cddr + when (string= + (if (keywordp wsection) + (substring (symbol-name wsection) 1) + wsection) + section) + return o)))) + items))) (defun eglot--signal-textDocument/didChange () "Send textDocument/didChange to server." (when eglot--recent-changes (let* ((server (eglot--current-server-or-lose)) - (sync-capability (eglot--server-capable :textDocumentSync)) - (sync-kind (if (numberp sync-capability) sync-capability - (plist-get sync-capability :change))) - (full-sync-p (or (eq sync-kind 1) - (eq :emacs-messup eglot--recent-changes)))) + (sync-capability (eglot--server-capable :textDocumentSync)) + (sync-kind (if (numberp sync-capability) sync-capability + (plist-get sync-capability :change))) + (full-sync-p (or (eq sync-kind 1) + (eq :emacs-messup eglot--recent-changes)))) (jsonrpc-notify - server :textDocument/didChange - (list - :textDocument (eglot--VersionedTextDocumentIdentifier) - :contentChanges - (if full-sync-p + server :textDocument/didChange + (list + :textDocument (eglot--VersionedTextDocumentIdentifier) + :contentChanges + (if full-sync-p (vector `(:text ,(eglot--widening - (buffer-substring-no-properties (point-min) - (point-max))))) - (cl-loop for (beg end len text) in (reverse eglot--recent-changes) - ;; github#259: `capitalize-word' and commands based - ;; on `casify_region' will cause multiple duplicate - ;; empty entries in `eglot--before-change' calls - ;; without an `eglot--after-change' reciprocal. - ;; Weed them out here. - when (numberp len) - vconcat `[,(list :range `(:start ,beg :end ,end) - :rangeLength len :text text)])))) + (buffer-substring-no-properties (point-min) + (point-max))))) + (cl-loop for (beg end len text) in (reverse eglot--recent-changes) + ;; github#259: `capitalize-word' and commands based + ;; on `casify_region' will cause multiple duplicate + ;; empty entries in `eglot--before-change' calls + ;; without an `eglot--after-change' reciprocal. + ;; Weed them out here. + when (numberp len) + vconcat `[,(list :range `(:start ,beg :end ,end) + :rangeLength len :text text)])))) (setq eglot--recent-changes nil) (setf (eglot--spinner server) (list nil :textDocument/didChange t)) (jsonrpc--call-deferred server)))) @@ -2390,39 +2402,129 @@ When called interactively, use the currently active server" "Send textDocument/didOpen to server." (setq eglot--recent-changes nil eglot--versioned-identifier 0) (jsonrpc-notify - (eglot--current-server-or-lose) - :textDocument/didOpen `(:textDocument ,(eglot--TextDocumentItem)))) + (eglot--current-server-or-lose) + :textDocument/didOpen `(:textDocument ,(eglot--TextDocumentItem)))) (defun eglot--signal-textDocument/didClose () "Send textDocument/didClose to server." (with-demoted-errors - "[eglot] error sending textDocument/didClose: %s" + "[eglot] error sending textDocument/didClose: %s" (jsonrpc-notify - (eglot--current-server-or-lose) - :textDocument/didClose `(:textDocument ,(eglot--TextDocumentIdentifier))))) + (eglot--current-server-or-lose) + :textDocument/didClose `(:textDocument ,(eglot--TextDocumentIdentifier))))) (defun eglot--signal-textDocument/willSave () "Send textDocument/willSave to server." (let ((server (eglot--current-server-or-lose)) - (params `(:reason 1 :textDocument ,(eglot--TextDocumentIdentifier)))) + (params `(:reason 1 :textDocument ,(eglot--TextDocumentIdentifier)))) (when (eglot--server-capable :textDocumentSync :willSave) (jsonrpc-notify server :textDocument/willSave params)) (when (eglot--server-capable :textDocumentSync :willSaveWaitUntil) (ignore-errors (eglot--apply-text-edits - (jsonrpc-request server :textDocument/willSaveWaitUntil params - :timeout 0.5)))))) + (jsonrpc-request server :textDocument/willSaveWaitUntil params + :timeout 0.5)))))) (defun eglot--signal-textDocument/didSave () "Send textDocument/didSave to server." (eglot--signal-textDocument/didChange) (jsonrpc-notify - (eglot--current-server-or-lose) - :textDocument/didSave - (list - ;; TODO: Handle TextDocumentSaveRegistrationOptions to control this. - :text (buffer-substring-no-properties (point-min) (point-max)) - :textDocument (eglot--TextDocumentIdentifier)))) + (eglot--current-server-or-lose) + :textDocument/didSave + (list + ;; TODO: Handle TextDocumentSaveRegistrationOptions to control this. + :text (buffer-substring-no-properties (point-min) (point-max)) + :textDocument (eglot--TextDocumentIdentifier)))) + +(defun eglot--inlay-hint-handler (buffer hints report-fn) + (print report-fn) + ;; Make overlays for them. + (let (diags nil) + (seq-doseq (value hints) + (cl-loop for val being the elements of + (if (stringp (plist-get value :label)) + (list (plist-get value :label)) + (plist-get value :label)) + do + (eglot--widening + (let ( + (line (plist-get (plist-get value :position) :line)) + (col (plist-get (plist-get value :position) :character)) + (source (if (stringp (plist-get value :label)) + (plist-get (plist-get (plist-get value :data) :text_document) :uri) + (plist-get (plist-get (plist-get (car value) :label) :location) :uri))) + (text + (propertize + (concat + (when (plist-get value :paddingLeft) " ") + (if (stringp val) val (plist-get val :value)) + (when (plist-get value :paddingRight) " ")) + 'face 'eglot-inlay-hint) + ) + ) + (print "source") + (print source) + (with-current-buffer buffer + (print (plist-get value :position)) + (print (eglot--lsp-position-to-point (plist-get value :position))) + (print (eglot--uri-to-path source)) + (push (eglot--make-diag + (expand-file-name (eglot--uri-to-path source)) + ;; FIXME: wrong coordinates? + ;; TODO: check diag correctly updates + (cons (1+ line) (1+ col)) + ;;(eglot--lsp-position-to-point (plist-get value :position)) + nil + 'eglot-inlay-hint + text + nil + `((before-string . ,text) + )) + diags) + ) + ) + ) + ) + ) + (funcall report-fn diags) + ) + ) + +(defun eglot-get-inlay-hints (report-fn buffer) + ;; (let ((lens-table (make-hash-table))) + ;; ;; Get the inlay hint objects. + ;; (mapc (lambda (inlayHint) + ;; (when (and (eglot--server-capable + ;; :inlayHintProvider :resolveProvider) + ;; (not (plist-member inlayHint :command))) + ;; (setq inlayHint + ;; (jsonrpc-request (eglot--current-server-or-lose) + ;; :inlayHint/resolve inlayHint))) + ;; (let ((line (thread-first inlayHint + ;; (plist-get :position) + ;; (plist-get :line)))) + ;; (puthash line + ;; (append (gethash line lens-table) (list inlayHint)) + ;; lens-table))) + ;; (jsonrpc-request + ;; (eglot--current-server-or-lose) + ;; :textDocument/inlayHint + ;; (list :textDocument (eglot--TextDocumentIdentifier) :range (list :start (list :line 0 :character 0) :end (list :line (count-lines (point-min) (point-max)) :character 0))) + ;; :deferred :textDocument/inlayHint)) + ;; lens-table + ;; ) + (print "toto") +(print (eglot--TextDocumentIdentifier)) + (jsonrpc-async-request + (eglot--current-server-or-lose) + :textDocument/inlayHint + (list + :textDocument (eglot--TextDocumentIdentifier) + :range (list :start (list :line 0 :character 0) :end (list :line (count-lines (point-min) (point-max)) :character 0))) + :deferred t + :success-fn (lambda (hints) (eglot--inlay-hint-handler buffer hints report-fn)) + ) + ) (defun eglot-flymake-backend (report-fn &rest _more) "A Flymake backend for Eglot. @@ -2431,22 +2533,76 @@ publishes diagnostics. Between calls to this function, REPORT-FN may be called multiple times (respecting the protocol of `flymake-backend-functions')." (cond (eglot--managed-mode - (setq eglot--current-flymake-report-fn report-fn) - (eglot--report-to-flymake eglot--diagnostics)) - (t - (funcall report-fn nil)))) + (setq eglot--current-flymake-report-fn report-fn) + (print "more") + (print _more) + (print "buffer") + (print (current-buffer)) + + (when (eglot--server-capable :inlayHintProvider) + (print eglot--current-flymake-report-fn) + (eglot-get-inlay-hints eglot--current-flymake-report-fn (current-buffer)) + ) + ;; (when (eglot--server-capable :inlayHintProvider) + ;; (let ((source (current-buffer)) + ;; (hints (eglot-get-inlay-hints))) + ;; ;; Make overlays for them. + ;; (maphash + ;; (lambda (line values) + ;; (cl-loop for value in values + ;; do + ;; (print value) + ;; (cl-loop for val being the elements of + ;; (if (stringp (plist-get value :label)) + ;; (list (plist-get value :label)) + ;; (plist-get value :label)) + ;; do + ;; (print val) + ;; (eglot--widening + ;; (let ((col (plist-get (plist-get value :position) :character)) + ;; (text + ;; (propertize + ;; (concat + ;; (when (plist-get value :paddingLeft) " ") + ;; (if (stringp val) val (plist-get val :value)) + ;; (when (plist-get value :paddingRight) " ")) + ;; 'face 'eglot-inlay-hint) + ;; ) + ;; ) + ;; (print text) + ;; (push (eglot--make-diag + ;; source + ;; (cons (+ line 1) (+ col 1)) + ;; nil + ;; 'eglot-inlay-hint + ;; text + ;; nil + ;; `((before-string . ,text) + ;; )) + ;; eglot--diagnostics) + ;; ) + ;; ) + ;; ) + ;; ) + ;; ) + ;; hints) + ;; )) + (eglot--report-to-flymake eglot--diagnostics)) + (t + (funcall report-fn diags) + ))) (defun eglot--report-to-flymake (diags) "Internal helper for `eglot-flymake-backend'." (save-restriction (widen) (funcall eglot--current-flymake-report-fn diags - ;; If the buffer hasn't changed since last - ;; call to the report function, flymake won't - ;; delete old diagnostics. Using :region - ;; keyword forces flymake to delete - ;; them (github#159). - :region (cons (point-min) (point-max)))) + ;; If the buffer hasn't changed since last + ;; call to the report function, flymake won't + ;; delete old diagnostics. Using :region + ;; keyword forces flymake to delete + ;; them (github#159). + :region (cons (point-min) (point-max)))) (setq eglot--diagnostics diags)) (defun eglot-xref-backend () "Eglot xref backend." 'eglot) @@ -2462,11 +2618,11 @@ may be called multiple times (respecting the protocol of (declare (indent 1) (debug (sexp &rest form))) (let ((collected (cl-gensym "collected"))) `(unwind-protect - (let (,collected) - (cl-flet ((,collector (xref) (push xref ,collected))) - ,@body) - (setq ,collected (nreverse ,collected)) - (sort ,collected eglot-xref-lessp-function)) + (let (,collected) + (cl-flet ((,collector (xref) (push xref ,collected))) + ,@body) + (setq ,collected (nreverse ,collected)) + (sort ,collected eglot-xref-lessp-function)) (maphash (lambda (_uri buf) (kill-buffer buf)) eglot--temp-location-buffers) (clrhash eglot--temp-location-buffers)))) @@ -2474,36 +2630,36 @@ may be called multiple times (respecting the protocol of "Like `xref-make-match' but with LSP's NAME, URI and RANGE. Try to visit the target file for a richer summary line." (pcase-let* - ((file (eglot--uri-to-path uri)) - (visiting (or (find-buffer-visiting file) - (gethash uri eglot--temp-location-buffers))) - (collect (lambda () - (eglot--widening + ((file (eglot--uri-to-path uri)) + (visiting (or (find-buffer-visiting file) + (gethash uri eglot--temp-location-buffers))) + (collect (lambda () + (eglot--widening (pcase-let* ((`(,beg . ,end) (eglot--range-region range)) - (bol (progn (goto-char beg) (line-beginning-position))) - (substring (buffer-substring bol (line-end-position))) - (hi-beg (- beg bol)) - (hi-end (- (min (line-end-position) end) bol))) + (bol (progn (goto-char beg) (line-beginning-position))) + (substring (buffer-substring bol (line-end-position))) + (hi-beg (- beg bol)) + (hi-end (- (min (line-end-position) end) bol))) (add-face-text-property hi-beg hi-end 'xref-match - t substring) + t substring) (list substring (line-number-at-pos (point) t) - (eglot-current-column) (- end beg)))))) - (`(,summary ,line ,column ,length) + (eglot-current-column) (- end beg)))))) + (`(,summary ,line ,column ,length) (cond - (visiting (with-current-buffer visiting (funcall collect))) - ((file-readable-p file) (with-current-buffer - (puthash uri (generate-new-buffer " *temp*") - eglot--temp-location-buffers) - (insert-file-contents file) - (funcall collect))) - (t ;; fall back to the "dumb strategy" - (let* ((start (cl-getf range :start)) - (line (1+ (cl-getf start :line))) - (start-pos (cl-getf start :character)) - (end-pos (cl-getf (cl-getf range :end) :character))) - (list name line start-pos (- end-pos start-pos))))))) + (visiting (with-current-buffer visiting (funcall collect))) + ((file-readable-p file) (with-current-buffer + (puthash uri (generate-new-buffer " *temp*") + eglot--temp-location-buffers) + (insert-file-contents file) + (funcall collect))) + (t ;; fall back to the "dumb strategy" + (let* ((start (cl-getf range :start)) + (line (1+ (cl-getf start :line))) + (start-pos (cl-getf start :character)) + (end-pos (cl-getf (cl-getf range :end) :character))) + (list name line start-pos (- end-pos start-pos))))))) (setf (gethash (expand-file-name file) eglot--servers-by-xrefed-file) - (eglot--current-server-or-lose)) + (eglot--current-server-or-lose)) (xref-make-match summary (xref-make-file-location file line column) length))) (defun eglot--workspace-symbols (pat &optional buffer) @@ -2513,42 +2669,42 @@ If BUFFER, switch to it before." (unless (eglot--server-capable :workspaceSymbolProvider) (eglot--error "This LSP server isn't a :workspaceSymbolProvider")) (mapcar - (lambda (wss) - (eglot--dbind ((WorkspaceSymbol) name containerName kind) wss - (propertize - (format "%s%s %s" - (if (zerop (length containerName)) "" - (concat (propertize containerName 'face 'shadow) " ")) - name - (propertize (alist-get kind eglot--symbol-kind-names "Unknown") - 'face 'shadow)) - 'eglot--lsp-workspaceSymbol wss))) - (jsonrpc-request (eglot--current-server-or-lose) :workspace/symbol - `(:query ,pat))))) + (lambda (wss) + (eglot--dbind ((WorkspaceSymbol) name containerName kind) wss + (propertize + (format "%s%s %s" + (if (zerop (length containerName)) "" + (concat (propertize containerName 'face 'shadow) " ")) + name + (propertize (alist-get kind eglot--symbol-kind-names "Unknown") + 'face 'shadow)) + 'eglot--lsp-workspaceSymbol wss))) + (jsonrpc-request (eglot--current-server-or-lose) :workspace/symbol + `(:query ,pat))))) (cl-defmethod xref-backend-identifier-completion-table ((_backend (eql eglot))) "Yet another tricky connection between LSP and Elisp completion semantics." (let ((buf (current-buffer)) (cache eglot--workspace-symbols-cache)) (cl-labels ((refresh (pat) (eglot--workspace-symbols pat buf)) - (lookup-1 (pat) ;; check cache, else refresh - (let ((probe (gethash pat cache :missing))) - (if (eq probe :missing) (puthash pat (refresh pat) cache) - probe))) - (lookup (pat) - (let ((res (lookup-1 pat)) - (def (and (string= pat "") (gethash :default cache)))) - (append def res nil))) - (score (c) - (cl-getf (get-text-property - 0 'eglot--lsp-workspaceSymbol c) - :score 0))) + (lookup-1 (pat) ;; check cache, else refresh + (let ((probe (gethash pat cache :missing))) + (if (eq probe :missing) (puthash pat (refresh pat) cache) + probe))) + (lookup (pat) + (let ((res (lookup-1 pat)) + (def (and (string= pat "") (gethash :default cache)))) + (append def res nil))) + (score (c) + (cl-getf (get-text-property + 0 'eglot--lsp-workspaceSymbol c) + :score 0))) (lambda (string _pred action) (pcase action (`metadata `(metadata - (cycle-sort-function - . ,(lambda (completions) - (cl-sort completions #'> :key #'score))) - (category . eglot-indirection-joy))) + (cycle-sort-function + . ,(lambda (completions) + (cl-sort completions #'> :key #'score))) + (category . eglot-indirection-joy))) (`(eglot--lsp-tryc . ,point) `(eglot--lsp-tryc . (,string . ,point))) (`(eglot--lsp-allc . ,_point) `(eglot--lsp-allc . ,(lookup string))) (_ nil)))))) @@ -2561,18 +2717,18 @@ If BUFFER, switch to it before." ;; Like mess? Ask minibuffer.el about improper lists. (when (equal (car v) string) (throw 'found (car v))) (setq v (cdr v)))) - eglot--workspace-symbols-cache))) + eglot--workspace-symbols-cache))) (add-to-list 'completion-category-overrides - '(eglot-indirection-joy (styles . (eglot--lsp-backend-style)))) + '(eglot-indirection-joy (styles . (eglot--lsp-backend-style)))) (cl-defmethod xref-backend-identifier-at-point ((_backend (eql eglot))) (let ((attempt - (and (xref--prompt-p this-command) - (puthash :default - (ignore-errors - (eglot--workspace-symbols (symbol-name (symbol-at-point)))) - eglot--workspace-symbols-cache)))) + (and (xref--prompt-p this-command) + (puthash :default + (ignore-errors + (eglot--workspace-symbols (symbol-name (symbol-at-point)))) + eglot--workspace-symbols-cache)))) (if attempt (car attempt) "LSP identifier at point"))) (defvar eglot--lsp-xref-refs nil @@ -2581,37 +2737,37 @@ If BUFFER, switch to it before." (cl-defun eglot--lsp-xrefs-for-method (method &key extra-params capability) "Make `xref''s for METHOD, EXTRA-PARAMS, check CAPABILITY." (unless (eglot--server-capable - (or capability - (intern + (or capability + (intern (format ":%sProvider" - (cadr (split-string (symbol-name method) - "/")))))) + (cadr (split-string (symbol-name method) + "/")))))) (eglot--error "Sorry, this server doesn't do %s" method)) (let ((response - (jsonrpc-request - (eglot--current-server-or-lose) - method (append (eglot--TextDocumentPositionParams) extra-params)))) + (jsonrpc-request + (eglot--current-server-or-lose) + method (append (eglot--TextDocumentPositionParams) extra-params)))) (eglot--collecting-xrefs (collect) (mapc - (lambda (loc-or-loc-link) - (let ((sym-name (symbol-name (symbol-at-point)))) - (eglot--dcase loc-or-loc-link - (((LocationLink) targetUri targetSelectionRange) - (collect (eglot--xref-make-match sym-name - targetUri targetSelectionRange))) - (((Location) uri range) - (collect (eglot--xref-make-match sym-name - uri range)))))) - (if (vectorp response) response (and response (list response))))))) + (lambda (loc-or-loc-link) + (let ((sym-name (symbol-name (symbol-at-point)))) + (eglot--dcase loc-or-loc-link + (((LocationLink) targetUri targetSelectionRange) + (collect (eglot--xref-make-match sym-name + targetUri targetSelectionRange))) + (((Location) uri range) + (collect (eglot--xref-make-match sym-name + uri range)))))) + (if (vectorp response) response (and response (list response))))))) (cl-defun eglot--lsp-xref-helper (method &key extra-params capability ) "Helper for `eglot-find-declaration' & friends." (let ((eglot--lsp-xref-refs (eglot--lsp-xrefs-for-method - method - :extra-params extra-params - :capability capability))) + method + :extra-params extra-params + :capability capability))) (if eglot--lsp-xref-refs - (xref-find-references "LSP identifier at point.") + (xref-find-references "LSP identifier at point.") (eglot--message "%s returned no references" method)))) (defun eglot-find-declaration () @@ -2632,28 +2788,28 @@ If BUFFER, switch to it before." (cl-defmethod xref-backend-definitions ((_backend (eql eglot)) id) (let ((probe (eglot--recover-workspace-symbol-meta id))) (if probe - (eglot--dbind ((WorkspaceSymbol) name location) - (get-text-property 0 'eglot--lsp-workspaceSymbol probe) - (eglot--dbind ((Location) uri range) location - (list (eglot--xref-make-match name uri range)))) - (eglot--lsp-xrefs-for-method :textDocument/definition)))) + (eglot--dbind ((WorkspaceSymbol) name location) + (get-text-property 0 'eglot--lsp-workspaceSymbol probe) + (eglot--dbind ((Location) uri range) location + (list (eglot--xref-make-match name uri range)))) + (eglot--lsp-xrefs-for-method :textDocument/definition)))) (cl-defmethod xref-backend-references ((_backend (eql eglot)) _identifier) (or - eglot--lsp-xref-refs - (eglot--lsp-xrefs-for-method - :textDocument/references :extra-params `(:context (:includeDeclaration t))))) + eglot--lsp-xref-refs + (eglot--lsp-xrefs-for-method + :textDocument/references :extra-params `(:context (:includeDeclaration t))))) (cl-defmethod xref-backend-apropos ((_backend (eql eglot)) pattern) (when (eglot--server-capable :workspaceSymbolProvider) (eglot--collecting-xrefs (collect) (mapc - (eglot--lambda ((SymbolInformation) name location) - (eglot--dbind ((Location) uri range) location - (collect (eglot--xref-make-match name uri range)))) - (jsonrpc-request (eglot--current-server-or-lose) - :workspace/symbol - `(:query ,pattern)))))) + (eglot--lambda ((SymbolInformation) name location) + (eglot--dbind ((Location) uri range) location + (collect (eglot--xref-make-match name uri range)))) + (jsonrpc-request (eglot--current-server-or-lose) + :workspace/symbol + `(:query ,pattern)))))) (defun eglot-format-buffer () "Format contents of current buffer." @@ -2670,304 +2826,304 @@ If non-nil, ON-TYPE-FORMAT is a character just inserted at BEG for which LSP on-type-formatting should be requested." (interactive (and (region-active-p) (list (region-beginning) (region-end)))) (pcase-let ((`(,method ,cap ,args) - (cond - ((and beg on-type-format) - `(:textDocument/onTypeFormatting - :documentOnTypeFormattingProvider - ,`(:position ,(eglot--pos-to-lsp-position beg) - :ch ,(string on-type-format)))) - ((and beg end) - `(:textDocument/rangeFormatting - :documentRangeFormattingProvider - (:range ,(list :start (eglot--pos-to-lsp-position beg) + (cond + ((and beg on-type-format) + `(:textDocument/onTypeFormatting + :documentOnTypeFormattingProvider + ,`(:position ,(eglot--pos-to-lsp-position beg) + :ch ,(string on-type-format)))) + ((and beg end) + `(:textDocument/rangeFormatting + :documentRangeFormattingProvider + (:range ,(list :start (eglot--pos-to-lsp-position beg) :end (eglot--pos-to-lsp-position end))))) - (t - '(:textDocument/formatting :documentFormattingProvider nil))))) + (t + '(:textDocument/formatting :documentFormattingProvider nil))))) (unless (eglot--server-capable cap) (eglot--error "Server can't format!")) (eglot--apply-text-edits - (jsonrpc-request - (eglot--current-server-or-lose) - method - (cl-list* - :textDocument (eglot--TextDocumentIdentifier) - :options (list :tabSize tab-width - :insertSpaces (if indent-tabs-mode :json-false t) - :insertFinalNewline (if require-final-newline t :json-false) - :trimFinalNewlines (if delete-trailing-lines t :json-false)) - args) - :deferred method)))) + (jsonrpc-request + (eglot--current-server-or-lose) + method + (cl-list* + :textDocument (eglot--TextDocumentIdentifier) + :options (list :tabSize tab-width + :insertSpaces (if indent-tabs-mode :json-false t) + :insertFinalNewline (if require-final-newline t :json-false) + :trimFinalNewlines (if delete-trailing-lines t :json-false)) + args) + :deferred method)))) (defun eglot-completion-at-point () "Eglot's `completion-at-point' function." ;; Commit logs for this function help understand what's going on. (when-let (completion-capability (eglot--server-capable :completionProvider)) (let* ((server (eglot--current-server-or-lose)) - (sort-completions - (lambda (completions) - (cl-sort completions - #'string-lessp - :key (lambda (c) - (or (plist-get - (get-text-property 0 'eglot--lsp-item c) - :sortText) - ""))))) - (metadata `(metadata (category . eglot) - (display-sort-function . ,sort-completions))) - resp items (cached-proxies :none) - (proxies - (lambda () - (if (listp cached-proxies) cached-proxies - (setq resp - (jsonrpc-request server - :textDocument/completion - (eglot--CompletionParams) - :deferred :textDocument/completion - :cancel-on-input t)) - (setq items (append - (if (vectorp resp) resp (plist-get resp :items)) - nil)) - (setq cached-proxies - (mapcar - (jsonrpc-lambda - (&rest item &key label insertText insertTextFormat - &allow-other-keys) - (let ((proxy + (sort-completions + (lambda (completions) + (cl-sort completions + #'string-lessp + :key (lambda (c) + (or (plist-get + (get-text-property 0 'eglot--lsp-item c) + :sortText) + ""))))) + (metadata `(metadata (category . eglot) + (display-sort-function . ,sort-completions))) + resp items (cached-proxies :none) + (proxies + (lambda () + (if (listp cached-proxies) cached-proxies + (setq resp + (jsonrpc-request server + :textDocument/completion + (eglot--CompletionParams) + :deferred :textDocument/completion + :cancel-on-input t)) + (setq items (append + (if (vectorp resp) resp (plist-get resp :items)) + nil)) + (setq cached-proxies + (mapcar + (jsonrpc-lambda + (&rest item &key label insertText insertTextFormat + &allow-other-keys) + (let ((proxy (cond ((and (eql insertTextFormat 2) - (eglot--snippet-expansion-fn)) - (string-trim-left label)) - ((and insertText - (not (string-empty-p insertText))) - insertText) - (t - (string-trim-left label))))) - (unless (zerop (length proxy)) - (put-text-property 0 1 'eglot--lsp-item item proxy)) - proxy)) - items))))) - (resolved (make-hash-table)) - (resolve-maybe - ;; Maybe completion/resolve JSON object `lsp-comp' into - ;; another JSON object, if at all possible. Otherwise, - ;; just return lsp-comp. - (lambda (lsp-comp) - (or (gethash lsp-comp resolved) + (eglot--snippet-expansion-fn)) + (string-trim-left label)) + ((and insertText + (not (string-empty-p insertText))) + insertText) + (t + (string-trim-left label))))) + (unless (zerop (length proxy)) + (put-text-property 0 1 'eglot--lsp-item item proxy)) + proxy)) + items))))) + (resolved (make-hash-table)) + (resolve-maybe + ;; Maybe completion/resolve JSON object `lsp-comp' into + ;; another JSON object, if at all possible. Otherwise, + ;; just return lsp-comp. + (lambda (lsp-comp) + (or (gethash lsp-comp resolved) (setf (gethash lsp-comp resolved) - (if (and (eglot--server-capable :completionProvider - :resolveProvider) - (plist-get lsp-comp :data)) - (jsonrpc-request server :completionItem/resolve - lsp-comp :cancel-on-input t) - lsp-comp))))) - (bounds (bounds-of-thing-at-point 'symbol))) + (if (and (eglot--server-capable :completionProvider + :resolveProvider) + (plist-get lsp-comp :data)) + (jsonrpc-request server :completionItem/resolve + lsp-comp :cancel-on-input t) + lsp-comp))))) + (bounds (bounds-of-thing-at-point 'symbol))) (list - (or (car bounds) (point)) - (or (cdr bounds) (point)) - (lambda (probe pred action) - (cond - ((eq action 'metadata) metadata) ; metadata - ((eq action 'lambda) ; test-completion - (test-completion probe (funcall proxies))) - ((eq (car-safe action) 'boundaries) nil) ; boundaries - ((null action) ; try-completion - (try-completion probe (funcall proxies))) - ((eq action t) ; all-completions - (all-completions - "" - (funcall proxies) - (lambda (proxy) - (let* ((item (get-text-property 0 'eglot--lsp-item proxy)) - (filterText (plist-get item :filterText))) - (and (or (null pred) (funcall pred proxy)) - (string-prefix-p - probe (or filterText proxy) completion-ignore-case)))))))) - :annotation-function - (lambda (proxy) - (eglot--dbind ((CompletionItem) detail kind) - (get-text-property 0 'eglot--lsp-item proxy) - (let* ((detail (and (stringp detail) - (not (string= detail "")) - detail)) - (annotation - (or detail - (cdr (assoc kind eglot--kind-names))))) - (when annotation - (concat " " - (propertize annotation - 'face 'font-lock-function-name-face)))))) - :company-kind - ;; Associate each lsp-item with a lsp-kind symbol. - (lambda (proxy) - (when-let* ((lsp-item (get-text-property 0 'eglot--lsp-item proxy)) - (kind (alist-get (plist-get lsp-item :kind) - eglot--kind-names))) - (intern (downcase kind)))) - :company-deprecated - (lambda (proxy) - (when-let ((lsp-item (get-text-property 0 'eglot--lsp-item proxy))) - (or (seq-contains-p (plist-get lsp-item :tags) - 1) - (eq t (plist-get lsp-item :deprecated))))) - :company-docsig - ;; FIXME: autoImportText is specific to the pyright language server - (lambda (proxy) - (when-let* ((lsp-comp (get-text-property 0 'eglot--lsp-item proxy)) - (data (plist-get (funcall resolve-maybe lsp-comp) :data)) - (import-text (plist-get data :autoImportText))) - import-text)) - :company-doc-buffer - (lambda (proxy) - (let* ((documentation - (let ((lsp-comp (get-text-property 0 'eglot--lsp-item proxy))) - (plist-get (funcall resolve-maybe lsp-comp) :documentation))) - (formatted (and documentation - (eglot--format-markup documentation)))) - (when formatted - (with-current-buffer (get-buffer-create " *eglot doc*") - (erase-buffer) - (insert formatted) - (current-buffer))))) - :company-require-match 'never - :company-prefix-length - (save-excursion - (when (car bounds) (goto-char (car bounds))) - (when (listp completion-capability) - (looking-back - (regexp-opt - (cl-coerce (cl-getf completion-capability :triggerCharacters) 'list)) - (line-beginning-position)))) - :exit-function - (lambda (proxy status) - (when (memq status '(finished exact)) - ;; To assist in using this whole `completion-at-point' - ;; function inside `completion-in-region', ensure the exit - ;; function runs in the buffer where the completion was - ;; triggered from. This should probably be in Emacs itself. - ;; (github#505) - (with-current-buffer (if (minibufferp) - (window-buffer (minibuffer-selected-window)) - (current-buffer)) - (eglot--dbind ((CompletionItem) insertTextFormat - insertText textEdit additionalTextEdits label) - (funcall + (or (car bounds) (point)) + (or (cdr bounds) (point)) + (lambda (probe pred action) + (cond + ((eq action 'metadata) metadata) ; metadata + ((eq action 'lambda) ; test-completion + (test-completion probe (funcall proxies))) + ((eq (car-safe action) 'boundaries) nil) ; boundaries + ((null action) ; try-completion + (try-completion probe (funcall proxies))) + ((eq action t) ; all-completions + (all-completions + "" + (funcall proxies) + (lambda (proxy) + (let* ((item (get-text-property 0 'eglot--lsp-item proxy)) + (filterText (plist-get item :filterText))) + (and (or (null pred) (funcall pred proxy)) + (string-prefix-p + probe (or filterText proxy) completion-ignore-case)))))))) + :annotation-function + (lambda (proxy) + (eglot--dbind ((CompletionItem) detail kind) + (get-text-property 0 'eglot--lsp-item proxy) + (let* ((detail (and (stringp detail) + (not (string= detail "")) + detail)) + (annotation + (or detail + (cdr (assoc kind eglot--kind-names))))) + (when annotation + (concat " " + (propertize annotation + 'face 'font-lock-function-name-face)))))) + :company-kind + ;; Associate each lsp-item with a lsp-kind symbol. + (lambda (proxy) + (when-let* ((lsp-item (get-text-property 0 'eglot--lsp-item proxy)) + (kind (alist-get (plist-get lsp-item :kind) + eglot--kind-names))) + (intern (downcase kind)))) + :company-deprecated + (lambda (proxy) + (when-let ((lsp-item (get-text-property 0 'eglot--lsp-item proxy))) + (or (seq-contains-p (plist-get lsp-item :tags) + 1) + (eq t (plist-get lsp-item :deprecated))))) + :company-docsig + ;; FIXME: autoImportText is specific to the pyright language server + (lambda (proxy) + (when-let* ((lsp-comp (get-text-property 0 'eglot--lsp-item proxy)) + (data (plist-get (funcall resolve-maybe lsp-comp) :data)) + (import-text (plist-get data :autoImportText))) + import-text)) + :company-doc-buffer + (lambda (proxy) + (let* ((documentation + (let ((lsp-comp (get-text-property 0 'eglot--lsp-item proxy))) + (plist-get (funcall resolve-maybe lsp-comp) :documentation))) + (formatted (and documentation + (eglot--format-markup documentation)))) + (when formatted + (with-current-buffer (get-buffer-create " *eglot doc*") + (erase-buffer) + (insert formatted) + (current-buffer))))) + :company-require-match 'never + :company-prefix-length + (save-excursion + (when (car bounds) (goto-char (car bounds))) + (when (listp completion-capability) + (looking-back + (regexp-opt + (cl-coerce (cl-getf completion-capability :triggerCharacters) 'list)) + (line-beginning-position)))) + :exit-function + (lambda (proxy status) + (when (memq status '(finished exact)) + ;; To assist in using this whole `completion-at-point' + ;; function inside `completion-in-region', ensure the exit + ;; function runs in the buffer where the completion was + ;; triggered from. This should probably be in Emacs itself. + ;; (github#505) + (with-current-buffer (if (minibufferp) + (window-buffer (minibuffer-selected-window)) + (current-buffer)) + (eglot--dbind ((CompletionItem) insertTextFormat + insertText textEdit additionalTextEdits label) + (funcall resolve-maybe (or (get-text-property 0 'eglot--lsp-item proxy) - ;; When selecting from the *Completions* - ;; buffer, `proxy' won't have any properties. - ;; A lookup should fix that (github#148) - (get-text-property - 0 'eglot--lsp-item - (cl-find proxy (funcall proxies) :test #'string=)))) - (let ((snippet-fn (and (eql insertTextFormat 2) - (eglot--snippet-expansion-fn)))) - (cond (textEdit - ;; Undo (yes, undo) the newly inserted completion. - ;; If before completion the buffer was "foo.b" and - ;; now is "foo.bar", `proxy' will be "bar". We - ;; want to delete only "ar" (`proxy' minus the - ;; symbol whose bounds we've calculated before) - ;; (github#160). - (delete-region (+ (- (point) (length proxy)) - (if bounds - (- (cdr bounds) (car bounds)) - 0)) - (point)) - (eglot--dbind ((TextEdit) range newText) textEdit - (pcase-let ((`(,beg . ,end) - (eglot--range-region range))) - (delete-region beg end) - (goto-char beg) - (funcall (or snippet-fn #'insert) newText)))) - (snippet-fn - ;; A snippet should be inserted, but using plain - ;; `insertText'. This requires us to delete the - ;; whole completion, since `insertText' is the full - ;; completion's text. - (delete-region (- (point) (length proxy)) (point)) - (funcall snippet-fn (or insertText label)))) - (when (cl-plusp (length additionalTextEdits)) - (eglot--apply-text-edits additionalTextEdits))) - (eglot--signal-textDocument/didChange) - (eldoc))))))))) + ;; When selecting from the *Completions* + ;; buffer, `proxy' won't have any properties. + ;; A lookup should fix that (github#148) + (get-text-property + 0 'eglot--lsp-item + (cl-find proxy (funcall proxies) :test #'string=)))) + (let ((snippet-fn (and (eql insertTextFormat 2) + (eglot--snippet-expansion-fn)))) + (cond (textEdit + ;; Undo (yes, undo) the newly inserted completion. + ;; If before completion the buffer was "foo.b" and + ;; now is "foo.bar", `proxy' will be "bar". We + ;; want to delete only "ar" (`proxy' minus the + ;; symbol whose bounds we've calculated before) + ;; (github#160). + (delete-region (+ (- (point) (length proxy)) + (if bounds + (- (cdr bounds) (car bounds)) + 0)) + (point)) + (eglot--dbind ((TextEdit) range newText) textEdit + (pcase-let ((`(,beg . ,end) + (eglot--range-region range))) + (delete-region beg end) + (goto-char beg) + (funcall (or snippet-fn #'insert) newText)))) + (snippet-fn + ;; A snippet should be inserted, but using plain + ;; `insertText'. This requires us to delete the + ;; whole completion, since `insertText' is the full + ;; completion's text. + (delete-region (- (point) (length proxy)) (point)) + (funcall snippet-fn (or insertText label)))) + (when (cl-plusp (length additionalTextEdits)) + (eglot--apply-text-edits additionalTextEdits))) + (eglot--signal-textDocument/didChange) + (eldoc))))))))) (defun eglot--hover-info (contents &optional _range) (mapconcat #'eglot--format-markup - (if (vectorp contents) contents (list contents)) "\n")) - + (if (vectorp contents) contents (list contents)) "\n")) + (defun eglot--sig-info (sigs active-sig sig-help-active-param) (cl-loop - for (sig . moresigs) on (append sigs nil) for i from 0 - concat - (eglot--dbind ((SignatureInformation) label documentation parameters activeParameter) sig - (with-temp-buffer - (save-excursion (insert label)) - (let ((active-param (or activeParameter sig-help-active-param)) - params-start params-end) - ;; Ad-hoc attempt to parse label as () - (when (looking-at "\\([^(]+\\)(\\([^)]+\\))") - (setq params-start (match-beginning 2) params-end (match-end 2)) - (add-face-text-property (match-beginning 1) (match-end 1) - 'font-lock-function-name-face)) - (when (eql i active-sig) - ;; Decide whether to add one-line-summary to signature line - (when (and (stringp documentation) - (string-match "[[:space:]]*\\([^.\r\n]+[.]?\\)" - documentation)) - (setq documentation (match-string 1 documentation)) - (unless (string-prefix-p (string-trim documentation) label) - (goto-char (point-max)) - (insert ": " (eglot--format-markup documentation)))) - ;; Decide what to do with the active parameter... - (when (and (eql i active-sig) active-param - (< -1 active-param (length parameters))) - (eglot--dbind ((ParameterInformation) label documentation) - (aref parameters active-param) - ;; ...perhaps highlight it in the formals list - (when params-start - (goto-char params-start) - (pcase-let - ((`(,beg ,end) + for (sig . moresigs) on (append sigs nil) for i from 0 + concat + (eglot--dbind ((SignatureInformation) label documentation parameters activeParameter) sig + (with-temp-buffer + (save-excursion (insert label)) + (let ((active-param (or activeParameter sig-help-active-param)) + params-start params-end) + ;; Ad-hoc attempt to parse label as () + (when (looking-at "\\([^(]+\\)(\\([^)]+\\))") + (setq params-start (match-beginning 2) params-end (match-end 2)) + (add-face-text-property (match-beginning 1) (match-end 1) + 'font-lock-function-name-face)) + (when (eql i active-sig) + ;; Decide whether to add one-line-summary to signature line + (when (and (stringp documentation) + (string-match "[[:space:]]*\\([^.\r\n]+[.]?\\)" + documentation)) + (setq documentation (match-string 1 documentation)) + (unless (string-prefix-p (string-trim documentation) label) + (goto-char (point-max)) + (insert ": " (eglot--format-markup documentation)))) + ;; Decide what to do with the active parameter... + (when (and (eql i active-sig) active-param + (< -1 active-param (length parameters))) + (eglot--dbind ((ParameterInformation) label documentation) + (aref parameters active-param) + ;; ...perhaps highlight it in the formals list + (when params-start + (goto-char params-start) + (pcase-let + ((`(,beg ,end) (if (stringp label) - (let ((case-fold-search nil)) - (and (re-search-forward - (concat "\\<" (regexp-quote label) "\\>") - params-end t) - (list (match-beginning 0) (match-end 0)))) + (let ((case-fold-search nil)) + (and (re-search-forward + (concat "\\<" (regexp-quote label) "\\>") + params-end t) + (list (match-beginning 0) (match-end 0)))) (mapcar #'1+ (append label nil))))) - (if (and beg end) - (add-face-text-property + (if (and beg end) + (add-face-text-property beg end 'eldoc-highlight-function-argument)))) - ;; ...and/or maybe add its doc on a line by its own. - (when documentation - (goto-char (point-max)) - (insert "\n" - (propertize - (if (stringp label) - label - (apply #'buffer-substring (mapcar #'1+ label))) - 'face 'eldoc-highlight-function-argument) - ": " (eglot--format-markup documentation)))))) - (buffer-string)))) - when moresigs concat "\n")) + ;; ...and/or maybe add its doc on a line by its own. + (when documentation + (goto-char (point-max)) + (insert "\n" + (propertize + (if (stringp label) + label + (apply #'buffer-substring (mapcar #'1+ label))) + 'face 'eldoc-highlight-function-argument) + ": " (eglot--format-markup documentation)))))) + (buffer-string)))) + when moresigs concat "\n")) (defun eglot-signature-eldoc-function (cb) "A member of `eldoc-documentation-functions', for signatures." (when (eglot--server-capable :signatureHelpProvider) (let ((buf (current-buffer))) (jsonrpc-async-request - (eglot--current-server-or-lose) - :textDocument/signatureHelp (eglot--TextDocumentPositionParams) - :success-fn - (eglot--lambda ((SignatureHelp) - signatures activeSignature activeParameter) - (eglot--when-buffer-window buf - (funcall cb - (unless (seq-empty-p signatures) - (eglot--sig-info signatures - activeSignature - activeParameter))))) - :deferred :textDocument/signatureHelp)) + (eglot--current-server-or-lose) + :textDocument/signatureHelp (eglot--TextDocumentPositionParams) + :success-fn + (eglot--lambda ((SignatureHelp) + signatures activeSignature activeParameter) + (eglot--when-buffer-window buf + (funcall cb + (unless (seq-empty-p signatures) + (eglot--sig-info signatures + activeSignature + activeParameter))))) + :deferred :textDocument/signatureHelp)) t)) (defun eglot-hover-eldoc-function (cb) @@ -2975,14 +3131,14 @@ for which LSP on-type-formatting should be requested." (when (eglot--server-capable :hoverProvider) (let ((buf (current-buffer))) (jsonrpc-async-request - (eglot--current-server-or-lose) - :textDocument/hover (eglot--TextDocumentPositionParams) - :success-fn (eglot--lambda ((Hover) contents range) - (eglot--when-buffer-window buf - (let ((info (unless (seq-empty-p contents) - (eglot--hover-info contents range)))) - (funcall cb info :buffer t)))) - :deferred :textDocument/hover)) + (eglot--current-server-or-lose) + :textDocument/hover (eglot--TextDocumentPositionParams) + :success-fn (eglot--lambda ((Hover) contents range) + (eglot--when-buffer-window buf + (let ((info (unless (seq-empty-p contents) + (eglot--hover-info contents range)))) + (funcall cb info :buffer t)))) + :deferred :textDocument/hover)) (eglot--highlight-piggyback cb) t)) @@ -2995,83 +3151,83 @@ for which LSP on-type-formatting should be requested." (let ((buf (current-buffer))) (when (eglot--server-capable :documentHighlightProvider) (jsonrpc-async-request - (eglot--current-server-or-lose) - :textDocument/documentHighlight (eglot--TextDocumentPositionParams) - :success-fn - (lambda (highlights) - (mapc #'delete-overlay eglot--highlights) - (setq eglot--highlights - (eglot--when-buffer-window buf - (mapcar - (eglot--lambda ((DocumentHighlight) range) - (pcase-let ((`(,beg . ,end) - (eglot--range-region range))) - (let ((ov (make-overlay beg end))) - (overlay-put ov 'face 'eglot-highlight-symbol-face) - (overlay-put ov 'modification-hooks - `(,(lambda (o &rest _) (delete-overlay o)))) - ov))) - highlights)))) - :deferred :textDocument/documentHighlight) + (eglot--current-server-or-lose) + :textDocument/documentHighlight (eglot--TextDocumentPositionParams) + :success-fn + (lambda (highlights) + (mapc #'delete-overlay eglot--highlights) + (setq eglot--highlights + (eglot--when-buffer-window buf + (mapcar + (eglot--lambda ((DocumentHighlight) range) + (pcase-let ((`(,beg . ,end) + (eglot--range-region range))) + (let ((ov (make-overlay beg end))) + (overlay-put ov 'face 'eglot-highlight-symbol-face) + (overlay-put ov 'modification-hooks + `(,(lambda (o &rest _) (delete-overlay o)))) + ov))) + highlights)))) + :deferred :textDocument/documentHighlight) nil))) (defun eglot-imenu () "Eglot's `imenu-create-index-function'. Returns a list as described in docstring of `imenu--index-alist'." (cl-labels - ((unfurl (obj) - (eglot--dcase obj - (((SymbolInformation)) (list obj)) - (((DocumentSymbol) name children) - (cons obj - (mapcar - (lambda (c) - (plist-put - c :containerName - (let ((existing (plist-get c :containerName))) - (if existing (format "%s::%s" name existing) - name)))) - (mapcan #'unfurl children))))))) + ((unfurl (obj) + (eglot--dcase obj + (((SymbolInformation)) (list obj)) + (((DocumentSymbol) name children) + (cons obj + (mapcar + (lambda (c) + (plist-put + c :containerName + (let ((existing (plist-get c :containerName))) + (if existing (format "%s::%s" name existing) + name)))) + (mapcan #'unfurl children))))))) (mapcar - (pcase-lambda (`(,kind . ,objs)) - (cons - (alist-get kind eglot--symbol-kind-names "Unknown") - (mapcan (pcase-lambda (`(,container . ,objs)) - (let ((elems (mapcar - (lambda (obj) - (cons (plist-get obj :name) - (car (eglot--range-region + (pcase-lambda (`(,kind . ,objs)) + (cons + (alist-get kind eglot--symbol-kind-names "Unknown") + (mapcan (pcase-lambda (`(,container . ,objs)) + (let ((elems (mapcar + (lambda (obj) + (cons (plist-get obj :name) + (car (eglot--range-region (eglot--dcase obj (((SymbolInformation) location) - (plist-get location :range)) + (plist-get location :range)) (((DocumentSymbol) selectionRange) - selectionRange)))))) - objs))) - (if container (list (cons container elems)) elems))) - (seq-group-by - (lambda (e) (plist-get e :containerName)) objs)))) - (seq-group-by - (lambda (obj) (plist-get obj :kind)) - (mapcan #'unfurl - (jsonrpc-request (eglot--current-server-or-lose) - :textDocument/documentSymbol - `(:textDocument - ,(eglot--TextDocumentIdentifier)) - :cancel-on-input non-essential)))))) + selectionRange)))))) + objs))) + (if container (list (cons container elems)) elems))) + (seq-group-by + (lambda (e) (plist-get e :containerName)) objs)))) + (seq-group-by + (lambda (obj) (plist-get obj :kind)) + (mapcan #'unfurl + (jsonrpc-request (eglot--current-server-or-lose) + :textDocument/documentSymbol + `(:textDocument + ,(eglot--TextDocumentIdentifier)) + :cancel-on-input non-essential)))))) (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, you have %d" - (current-buffer) version eglot--versioned-identifier)) + (current-buffer) version eglot--versioned-identifier)) (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)) + (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 @@ -3091,19 +3247,19 @@ Returns a list as described in docstring of `imenu--index-alist'." ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=32237 ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=32278 (let ((inhibit-modification-hooks t) - (length (- end beg)) - (beg (marker-position beg)) - (end (marker-position end))) + (length (- end beg)) + (beg (marker-position beg)) + (end (marker-position end))) (run-hook-with-args 'before-change-functions - beg end) + beg end) (replace-buffer-contents temp) (run-hook-with-args 'after-change-functions - beg (+ beg (length newText)) - length)))) + beg (+ beg (length newText)) + length)))) (progress-reporter-update reporter (cl-incf done))))))) - (mapcar (eglot--lambda ((TextEdit) range newText) - (cons newText (eglot--range-region range 'markers))) - (reverse edits))) + (mapcar (eglot--lambda ((TextEdit) range newText) + (cons newText (eglot--range-region range 'markers))) + (reverse edits))) (undo-amalgamate-change-group change-group) (progress-reporter-done reporter)))) @@ -3111,45 +3267,45 @@ Returns a list as described in docstring of `imenu--index-alist'." "Apply the workspace edit WEDIT. If CONFIRM, ask user first." (eglot--dbind ((WorkspaceEdit) changes documentChanges) wedit (let ((prepared - (mapcar (eglot--lambda ((TextDocumentEdit) textDocument edits) - (eglot--dbind ((VersionedTextDocumentIdentifier) uri version) - textDocument - (list (eglot--uri-to-path uri) edits version))) - documentChanges))) + (mapcar (eglot--lambda ((TextDocumentEdit) textDocument edits) + (eglot--dbind ((VersionedTextDocumentIdentifier) uri version) + textDocument + (list (eglot--uri-to-path uri) edits version))) + documentChanges))) (unless (and changes documentChanges) ;; We don't want double edits, and some servers send both ;; changes and documentChanges. This unless ensures that we ;; prefer documentChanges over changes. (cl-loop for (uri edits) on changes by #'cddr - do (push (list (eglot--uri-to-path uri) edits) prepared))) + do (push (list (eglot--uri-to-path uri) edits) prepared))) (if (or confirm - (cl-notevery #'find-buffer-visiting - (mapcar #'car prepared))) - (unless (y-or-n-p - (format "[eglot] Server wants to edit:\n %s\n Proceed? " - (mapconcat #'identity (mapcar #'car prepared) "\n "))) - (jsonrpc-error "User cancelled server edit"))) + (cl-notevery #'find-buffer-visiting + (mapcar #'car prepared))) + (unless (y-or-n-p + (format "[eglot] Server wants to edit:\n %s\n Proceed? " + (mapconcat #'identity (mapcar #'car prepared) "\n "))) + (jsonrpc-error "User cancelled server edit"))) (cl-loop for edit in prepared - for (path edits version) = edit - do (with-current-buffer (find-file-noselect path) - (eglot--apply-text-edits edits version)) - finally (eldoc) (eglot--message "Edit successful!"))))) + for (path edits version) = edit + do (with-current-buffer (find-file-noselect path) + (eglot--apply-text-edits edits version)) + finally (eldoc) (eglot--message "Edit successful!"))))) (defun eglot-rename (newname) "Rename the current symbol to NEWNAME." (interactive - (list (read-from-minibuffer - (format "Rename `%s' to: " (or (thing-at-point 'symbol t) + (list (read-from-minibuffer + (format "Rename `%s' to: " (or (thing-at-point 'symbol t) "unknown symbol")) - nil nil nil nil - (symbol-name (symbol-at-point))))) + nil nil nil nil + (symbol-name (symbol-at-point))))) (unless (eglot--server-capable :renameProvider) (eglot--error "Server can't rename!")) (eglot--apply-workspace-edit - (jsonrpc-request (eglot--current-server-or-lose) - :textDocument/rename `(,@(eglot--TextDocumentPositionParams) - :newName ,newname)) - current-prefix-arg)) + (jsonrpc-request (eglot--current-server-or-lose) + :textDocument/rename `(,@(eglot--TextDocumentPositionParams) + :newName ,newname)) + current-prefix-arg)) (defun eglot--region-bounds () "Region bounds if active, else bounds of things at point." @@ -3165,71 +3321,71 @@ Interactively, default BEG and END to region's bounds else BEG is point and END is nil, which results in a request for code actions at point. With prefix argument, prompt for ACTION-KIND." (interactive - `(,@(eglot--region-bounds) - ,(and current-prefix-arg - (completing-read "[eglot] Action kind: " - '("quickfix" "refactor.extract" "refactor.inline" - "refactor.rewrite" "source.organizeImports"))) - t)) + `(,@(eglot--region-bounds) + ,(and current-prefix-arg + (completing-read "[eglot] Action kind: " + '("quickfix" "refactor.extract" "refactor.inline" + "refactor.rewrite" "source.organizeImports"))) + t)) (unless (or (not interactive) - (eglot--server-capable :codeActionProvider)) + (eglot--server-capable :codeActionProvider)) (eglot--error "Server can't execute code actions!")) (let* ((server (eglot--current-server-or-lose)) - (actions - (jsonrpc-request - server - :textDocument/codeAction - (list :textDocument (eglot--TextDocumentIdentifier) - :range (list :start (eglot--pos-to-lsp-position beg) - :end (eglot--pos-to-lsp-position end)) - :context - `(:diagnostics + (actions + (jsonrpc-request + server + :textDocument/codeAction + (list :textDocument (eglot--TextDocumentIdentifier) + :range (list :start (eglot--pos-to-lsp-position beg) + :end (eglot--pos-to-lsp-position end)) + :context + `(:diagnostics [,@(cl-loop for diag in (flymake-diagnostics beg end) - when (cdr (assoc 'eglot-lsp-diag - (eglot--diag-data diag))) - collect it)] + when (cdr (assoc 'eglot-lsp-diag + (eglot--diag-data diag))) + collect it)] ,@(when action-kind `(:only [,action-kind])))) - :deferred t)) - ;; Redo filtering, in case the `:only' didn't go through. - (actions (cl-loop for a across actions - when (or (not action-kind) - (equal action-kind (plist-get a :kind))) - collect a))) + :deferred t)) + ;; Redo filtering, in case the `:only' didn't go through. + (actions (cl-loop for a across actions + when (or (not action-kind) + (equal action-kind (plist-get a :kind))) + collect a))) (if interactive - (eglot--read-execute-code-action actions server action-kind) + (eglot--read-execute-code-action actions server action-kind) actions))) (defun eglot--read-execute-code-action (actions server &optional action-kind) "Helper for interactive calls to `eglot-code-actions'" (let* ((menu-items - (or (cl-loop for a in actions - collect (cons (plist-get a :title) a)) - (apply #'eglot--error - (if action-kind `("No \"%s\" code actions here" ,action-kind) - `("No code actions here"))))) - (preferred-action (cl-find-if - (lambda (menu-item) - (plist-get (cdr menu-item) :isPreferred)) - menu-items)) - (default-action (car (or preferred-action (car menu-items)))) - (chosen (if (and action-kind (null (cadr menu-items))) - (cdr (car menu-items)) - (if (listp last-nonmenu-event) - (x-popup-menu last-nonmenu-event `("Eglot code actions:" + (or (cl-loop for a in actions + collect (cons (plist-get a :title) a)) + (apply #'eglot--error + (if action-kind `("No \"%s\" code actions here" ,action-kind) + `("No code actions here"))))) + (preferred-action (cl-find-if + (lambda (menu-item) + (plist-get (cdr menu-item) :isPreferred)) + menu-items)) + (default-action (car (or preferred-action (car menu-items)))) + (chosen (if (and action-kind (null (cadr menu-items))) + (cdr (car menu-items)) + (if (listp last-nonmenu-event) + (x-popup-menu last-nonmenu-event `("Eglot code actions:" ("dummy" ,@menu-items))) - (cdr (assoc (completing-read - (format "[eglot] Pick an action (default %s): " - default-action) - menu-items nil t nil nil default-action) - menu-items)))))) + (cdr (assoc (completing-read + (format "[eglot] Pick an action (default %s): " + default-action) + menu-items nil t nil nil default-action) + menu-items)))))) (eglot--dcase chosen (((Command) command arguments) - (eglot-execute-command server (intern command) arguments)) + (eglot-execute-command server (intern command) arguments)) (((CodeAction) edit command) - (when edit (eglot--apply-workspace-edit edit)) - (when command - (eglot--dbind ((Command) command arguments) command - (eglot-execute-command server (intern command) arguments))))))) + (when edit (eglot--apply-workspace-edit edit)) + (when command + (eglot--dbind ((Command) command arguments) command + (eglot-execute-command server (intern command) arguments))))))) (defmacro eglot--code-action (name kind) "Define NAME to execute KIND code action." @@ -3252,40 +3408,40 @@ at point. With prefix argument, prompt for ACTION-KIND." "Handle dynamic registration of workspace/didChangeWatchedFiles." (eglot-unregister-capability server method id) (let* (success - (globs (mapcar - (eglot--lambda ((FileSystemWatcher) globPattern) - (eglot--glob-compile globPattern t t)) - watchers)) - (dirs-to-watch - (delete-dups (mapcar #'file-name-directory - (project-files - (eglot--project server)))))) + (globs (mapcar + (eglot--lambda ((FileSystemWatcher) globPattern) + (eglot--glob-compile globPattern t t)) + watchers)) + (dirs-to-watch + (delete-dups (mapcar #'file-name-directory + (project-files + (eglot--project server)))))) (cl-labels - ((handle-event - (event) - (pcase-let ((`(,desc ,action ,file ,file1) event)) - (cond + ((handle-event + (event) + (pcase-let ((`(,desc ,action ,file ,file1) event)) + (cond ((and (memq action '(created changed deleted)) - (cl-find file globs :test (lambda (f g) (funcall g f)))) - (jsonrpc-notify - server :workspace/didChangeWatchedFiles - `(:changes ,(vector `(:uri ,(eglot--path-to-uri file) - :type ,(cl-case action - (created 1) - (changed 2) - (deleted 3))))))) + (cl-find file globs :test (lambda (f g) (funcall g f)))) + (jsonrpc-notify + server :workspace/didChangeWatchedFiles + `(:changes ,(vector `(:uri ,(eglot--path-to-uri file) + :type ,(cl-case action + (created 1) + (changed 2) + (deleted 3))))))) ((eq action 'renamed) - (handle-event `(,desc 'deleted ,file)) - (handle-event `(,desc 'created ,file1))))))) + (handle-event `(,desc 'deleted ,file)) + (handle-event `(,desc 'created ,file1))))))) (unwind-protect - (progn - (dolist (dir dirs-to-watch) - (push (file-notify-add-watch dir '(change) #'handle-event) - (gethash id (eglot--file-watches server)))) - (setq - success - `(:message ,(format "OK, watching %s directories in %s watchers" - (length dirs-to-watch) (length watchers))))) + (progn + (dolist (dir dirs-to-watch) + (push (file-notify-add-watch dir '(change) #'handle-event) + (gethash id (eglot--file-watches server)))) + (setq + success + `(:message ,(format "OK, watching %s directories in %s watchers" + (length dirs-to-watch) (length watchers))))) (unless success (eglot-unregister-capability server method id)))))) @@ -3304,34 +3460,34 @@ at point. With prefix argument, prompt for ACTION-KIND." (with-temp-buffer (save-excursion (insert glob)) (cl-loop - with grammar = '((:** "\\*\\*/?" eglot--glob-emit-**) - (:* "\\*" eglot--glob-emit-*) - (:? "\\?" eglot--glob-emit-?) - (:{} "{[^][*{}]+}" eglot--glob-emit-{}) - (:range "\\[\\^?[^][/,*{}]+\\]" eglot--glob-emit-range) - (:literal "[^][,*?{}]+" eglot--glob-emit-self)) - until (eobp) - collect (cl-loop - for (_token regexp emitter) in grammar - thereis (and (re-search-forward (concat "\\=" regexp) nil t) - (list (cl-gensym "state-") emitter (match-string 0))) - finally (error "Glob '%s' invalid at %s" (buffer-string) (point)))))) + with grammar = '((:** "\\*\\*/?" eglot--glob-emit-**) + (:* "\\*" eglot--glob-emit-*) + (:? "\\?" eglot--glob-emit-?) + (:{} "{[^][*{}]+}" eglot--glob-emit-{}) + (:range "\\[\\^?[^][/,*{}]+\\]" eglot--glob-emit-range) + (:literal "[^][,*?{}]+" eglot--glob-emit-self)) + until (eobp) + collect (cl-loop + for (_token regexp emitter) in grammar + thereis (and (re-search-forward (concat "\\=" regexp) nil t) + (list (cl-gensym "state-") emitter (match-string 0))) + finally (error "Glob '%s' invalid at %s" (buffer-string) (point)))))) (defun eglot--glob-compile (glob &optional byte-compile noerror) "Convert GLOB into Elisp function. Maybe BYTE-COMPILE it. If NOERROR, return predicate, else erroring function." (let* ((states (eglot--glob-parse glob)) - (body `(with-current-buffer (get-buffer-create " *eglot-glob-matcher*") - (erase-buffer) - (save-excursion (insert string)) - (cl-labels ,(cl-loop for (this that) on states - for (self emit text) = this - for next = (or (car that) 'eobp) - collect (funcall emit text self next)) - (or (,(caar states)) - (error "Glob done but more unmatched text: '%s'" - (buffer-substring (point) (point-max))))))) - (form `(lambda (string) ,(if noerror `(ignore-errors ,body) body)))) + (body `(with-current-buffer (get-buffer-create " *eglot-glob-matcher*") + (erase-buffer) + (save-excursion (insert string)) + (cl-labels ,(cl-loop for (this that) on states + for (self emit text) = this + for next = (or (car that) 'eobp) + collect (funcall emit text self next)) + (or (,(caar states)) + (error "Glob done but more unmatched text: '%s'" + (buffer-substring (point) (point-max))))))) + (form `(lambda (string) ,(if noerror `(ignore-errors ,body) body)))) (if byte-compile (byte-compile form) form))) (defun eglot--glob-emit-self (text self next) @@ -3339,11 +3495,11 @@ If NOERROR, return predicate, else erroring function." (defun eglot--glob-emit-** (_ self next) `(,self () (or (ignore-errors (save-excursion (,next))) - (and (re-search-forward "\\=/?[^/]+/?") (,self))))) + (and (re-search-forward "\\=/?[^/]+/?") (,self))))) (defun eglot--glob-emit-* (_ self next) `(,self () (re-search-forward "\\=[^/]") - (or (ignore-errors (save-excursion (,next))) (,self)))) + (or (ignore-errors (save-excursion (,next))) (,self)))) (defun eglot--glob-emit-? (_ self next) `(,self () (re-search-forward "\\=[^/]") (,next))) @@ -3351,9 +3507,9 @@ If NOERROR, return predicate, else erroring function." (defun eglot--glob-emit-{} (arg self next) (let ((alternatives (split-string (substring arg 1 (1- (length arg))) ","))) `(,self () - (or (re-search-forward ,(concat "\\=" (regexp-opt alternatives)) nil t) - (error "Failed matching any of %s" ',alternatives)) - (,next)))) + (or (re-search-forward ,(concat "\\=" (regexp-opt alternatives)) nil t) + (error "Failed matching any of %s" ',alternatives)) + (,next)))) (defun eglot--glob-emit-range (arg self next) (when (eq ?! (aref arg 1)) (aset arg 1 ?^)) @@ -3366,32 +3522,115 @@ If NOERROR, return predicate, else erroring function." "" "Eglot mode for listing server connections \\{eglot-list-connections-mode-map}" (setq-local tabulated-list-format - `[("Language server" 16) ("Project name" 16) ("Modes handled" 16)]) + `[("Language server" 16) ("Project name" 16) ("Modes handled" 16)]) (tabulated-list-init-header)) (defun eglot-list-connections () "List currently active Eglot connections." (interactive) (with-current-buffer - (get-buffer-create "*EGLOT connections*") + (get-buffer-create "*EGLOT connections*") (let ((inhibit-read-only t)) (erase-buffer) (eglot-list-connections-mode) (setq-local tabulated-list-entries - (mapcar - (lambda (server) - (list server - `[,(or (plist-get (eglot--server-info server) :name) - (jsonrpc-name server)) - ,(eglot-project-nickname server) - ,(mapconcat #'symbol-name - (eglot--major-modes server) - ", ")])) - (cl-reduce #'append - (hash-table-values eglot--servers-by-project)))) + (mapcar + (lambda (server) + (list server + `[,(or (plist-get (eglot--server-info server) :name) + (jsonrpc-name server)) + ,(eglot-project-nickname server) + ,(mapconcat #'symbol-name + (eglot--major-modes server) + ", ")])) + (cl-reduce #'append + (hash-table-values eglot--servers-by-project)))) (revert-buffer) (pop-to-buffer (current-buffer))))) +(defface eglot-inlay-hint + '((t (:inherit shadow :height 0.8))) + "Face used for inlay hint overlays.") + +;; (define-minor-mode eglot--inlay-mode +;; "Mode for displaying inlay hint." +;; :lighter " inlay" +;; ) + +;; (defun eglot--update-hints() +;; "Refresh inlay hints from LSP server." +;; (mapc #'delete-overlay (overlays-in (point-min) (point-max))) +;; (let ((read-only-p buffer-read-only) +;; overlays) +;; (condition-case err +;; (let ((lens-table (make-hash-table))) +;; ;; Get the inlay hint objects. +;; (mapc (lambda (inlayHint) +;; (when (and (eglot--server-capable +;; :inlayHintProvider :resolveProvider) +;; (not (plist-member inlayHint :command))) +;; (setq inlayHint +;; (jsonrpc-request (eglot--current-server-or-lose) +;; :inlayHint/resolve inlayHint))) +;; (let ((line (thread-first inlayHint +;; (plist-get :position) +;; (plist-get :line)))) +;; (puthash line +;; (append (gethash line lens-table) (list inlayHint)) +;; lens-table))) +;; (jsonrpc-request +;; (eglot--current-server-or-lose) +;; :textDocument/inlayHint +;; (list :textDocument (eglot--TextDocumentIdentifier) :range (list :start (list :line 0 :character 0) :end (list :line (count-lines (point-min) (point-max)) :character 0))) +;; :deferred :textDocument/inlayHint)) + +;; ;; Make overlays for them. +;; (maphash +;; (lambda (line values) +;; ;; TODO: manage InlayHintLabelPart[] +;; (eglot--widening +;; (let ((c (plist-get (plist-get (car values) :position) :character)) +;; (label-text (propertize (if (and (plist-member (car values) :label) (stringp (plist-get (car values) :label))) (plist-get (car values) :label) ""))) +;; (text label-text 'mouse-face 'highlight) +;; ) +;; (goto-char (point-min)) +;; (forward-line line) +;; (eglot-move-to-column c) +;; (let ((ov (make-overlay (point) (point)))) +;; (push ov overlays) +;; (overlay-put ov 'eglot-inlay-hint values) +;; (overlay-put ov 'before-string (propertize text 'face 'eglot-inlay-hint)) +;; )))) +;; lens-table) +;; ) +;; (error +;; (mapc #'delete-overlay overlays) +;; (setq buffer-read-only read-only-p) +;; (eglot--inlay-mode -1) +;; (signal (car err) (cdr err)))))) + +;; (defun eglot-inlay-hint () +;; "Ask the server for inlay hint and show them in the current buffer." +;; (interactive) +;; (unless (eglot--server-capable :inlayHintProvider) +;; (error "Server does not support inlay hint.")) + +;; ;; Setup minor mode which will clean them up and provide keybindings. +;; (eglot--inlay-mode 1) +;; (eglot--update-hints) +;; (add-hook 'after-save-hook #'eglot--update-hints nil t) + +;; (cl-labels +;; ((cleanup +;; () +;; (remove-hook 'eglot--inlay-mode-hook #'cleanup t) +;; (remove-hook 'after-save-hook 'eglot--update-hints t) +;; (unless eglot--inlay-mode +;; (mapc #'delete-overlay overlays) +;; (setq buffer-read-only read-only-p)))) +;; (add-hook 'eglot--inlay-mode-hook #'cleanup nil t)) +;; ) + ;;; Hacks ;;; @@ -3408,7 +3647,7 @@ If NOERROR, return predicate, else erroring function." ;;; (make-obsolete-variable 'eglot--managed-mode-hook - 'eglot-managed-mode-hook "1.6") + 'eglot-managed-mode-hook "1.6") (provide 'eglot) @@ -3430,10 +3669,10 @@ If NOERROR, return predicate, else erroring function." ;; accordingly. tryc/allc names made akward/recognizable on purpose. (add-to-list 'completion-styles-alist - '(eglot--lsp-backend-style - eglot--lsp-backend-style-try-completion - eglot--lsp-backend-style-all-completions - "Ad-hoc completion style provided by the completion table.")) + '(eglot--lsp-backend-style + eglot--lsp-backend-style-try-completion + eglot--lsp-backend-style-all-completions + "Ad-hoc completion style provided by the completion table.")) (defun eglot--lsp-backend-style-call (op string table pred point) (when (functionp table) -- 2.34.1