mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-30 09:00:31 -08:00
Code Issues Projects Releases Wiki Activity

Eglot: tweak some semtok functions to be more debug-friendly

Browse source 
* lisp/progmodes/eglot.el (eglot--semtok-request): Return value
records return reason.
(eglot--semtok-font-lock-1): Return number of painted tokens and
exit locus.
(eglot--semtok-decode-token): Rename
from eglot--semtok-token-faces.  Rework.
(eglot--semtok-font-lock-1): Use eglot--semtok-decode-token.
This commit is contained in:
João Távora 2025-11-13 20:56:50 +00:00
parent 2f196548f5
commit 6126ab8d82
1 changed files with 23 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

40
lisp/progmodes/eglot.el
View file

@ -4589,26 +4589,27 @@ If NOERROR, return predicate, else erroring function."
(eglot--semtok-define-things) (eglot--semtok-define-things)
(defun eglot--semtok-token-faces (tok) (defun eglot--semtok-decode-token (tok)
"Decode TOK. Return (NAMES . FACES). Filter FACES via user options."
(with-slots (semtok-cache capabilities) (with-slots (semtok-cache capabilities)
(eglot--current-server-or-lose) (eglot--current-server-or-lose)
(let ((probe (gethash tok semtok-cache :missing)) (let ((probe (gethash tok semtok-cache :missing)))
tname)
(if (eq probe :missing) (if (eq probe :missing)
(puthash (puthash
tok tok
(eglot--dbind ((SemanticTokensLegend) tokenTypes tokenModifiers) (eglot--dbind ((SemanticTokensLegend) tokenTypes tokenModifiers)
(plist-get (plist-get capabilities :semanticTokensProvider) :legend) (plist-get (plist-get capabilities :semanticTokensProvider) :legend)
(setq tname (aref tokenTypes (car tok)))
(when (member tname eglot-semantic-token-types)
(cl-loop (cl-loop
with tname = (aref tokenTypes (car tok))
for j from 0 for m across tokenModifiers for j from 0 for m across tokenModifiers
unless (or (zerop (logand (cdr tok) (ash 1 j))) when (cl-plusp (logand (cdr tok) (ash 1 j)))
(not (member m eglot-semantic-token-modifiers))) collect m into names
collect (intern (format "eglot-semantic-%s-face" m)) into mfaces and when (member m eglot-semantic-token-modifiers)
finally (cl-return collect (intern (format "eglot-semantic-%s-face" m)) into faces
(cons (intern (format "eglot-semantic-%s-face" tname)) finally
mfaces))))) (when (member tname eglot-semantic-token-types)
(push (intern (format "eglot-semantic-%s-face" tname)) faces))
(cl-return (cons (cons tname names) faces))))
semtok-cache) semtok-cache)
probe)))) probe))))
@ -4697,7 +4698,7 @@ If NOERROR, return predicate, else erroring function."
;; trivial/fast edits. Even though it's fairly cheap to send ;; trivial/fast edits. Even though it's fairly cheap to send
;; multiple delta requests, it's nicer to just send just one. ;; multiple delta requests, it's nicer to just send just one.
(when (cdr eglot--semtok-inflight) (when (cdr eglot--semtok-inflight)
(cl-return-from eglot--semtok-request)) (cl-return-from eglot--semtok-request 'skipped))
(req :textDocument/semanticTokens/full/delta (point-min) (point-max) (req :textDocument/semanticTokens/full/delta (point-min) (point-max)
(list :textDocument (eglot--TextDocumentIdentifier) (list :textDocument (eglot--TextDocumentIdentifier)
:previousResultId (cache-get :response :resultId)) :previousResultId (cache-get :response :resultId))
@ -4708,7 +4709,7 @@ If NOERROR, return predicate, else erroring function."
(eglot--semtok-apply-delta-edits (eglot--semtok-apply-delta-edits
(cache-get :response :data) (cache-get :response :data)
edits))) edits)))
;; server sent full response instead, so just record that. ;; (trace-values "Server send full response instead")
response)))) response))))
((eglot-server-capable :semanticTokensProvider :range) ((eglot-server-capable :semanticTokensProvider :range)
(req :textDocument/semanticTokens/range beg end (req :textDocument/semanticTokens/range beg end
@ -4753,20 +4754,21 @@ lock machinery calls us again."
unless (< (point) beg) do unless (< (point) beg) do
(setq column (+ column (aref data (+ i 1)))) (setq column (+ column (aref data (+ i 1))))
(funcall eglot-move-to-linepos-function column) (funcall eglot-move-to-linepos-function column)
(when (> (point) end) (cl-return napplied)) (when (> (point) end) (cl-return (cons napplied 'early)))
(setq p-beg (point)) (setq p-beg (point))
(funcall eglot-move-to-linepos-function (+ column (aref data (+ i 2)))) (funcall eglot-move-to-linepos-function (+ column (aref data (+ i 2))))
(setq p-end (point)) (setq p-end (point))
(let* ((tok (cons (aref data (+ i 3)) (let* ((tok (cons (aref data (+ i 3))
(aref data (+ i 4)))) (aref data (+ i 4))))
(faces (eglot--semtok-token-faces tok))) (decoded (eglot--semtok-decode-token tok)))
;; The `eglot--semtok-token' prop doesn't serve much purpose: ;; The `eglot--semtok-token' prop doesn't serve much purpose:
;; just for debug... ;; just for debug...
(put-text-property p-beg p-end 'eglot--semtok-token tok) (put-text-property p-beg p-end 'eglot--semtok-names (car decoded))
(put-text-property p-beg p-end 'eglot--semtok-faces faces) (put-text-property p-beg p-end 'eglot--semtok-faces (cdr decoded))
(dolist (f faces) (dolist (f (cdr decoded))
(add-face-text-property p-beg p-end f))) (add-face-text-property p-beg p-end f)))
count 1 into napplied)))) count 1 into napplied
finally (cl-return (cons napplied 'normal))))))
(defun eglot--semtok-font-lock-2 (beg end) (defun eglot--semtok-font-lock-2 (beg end)
;; JT@2025-11-11: FIXME: I wish I didn't need this kludge but the ;; JT@2025-11-11: FIXME: I wish I didn't need this kludge but the