Eglot: rework semtok code (bug#79374)

* lisp/progmodes/eglot.el (eglot-semantic-tokens-faces)
(eglot-semantic-tokens-modifier-faces): Move up to defcustom section.
(eglot--semtok-request-full-on-idle, eglot-handle-request)
(eglot--semtok-build-face-map, eglot--semtok-initialize)
(eglot-semantic-tokens-mode): Move into semantic tokens section.
(eglot--semtok-font-lock): Rename from
eglot--semtok-fontify-tokens.
(eglot-semantic-tokens-mode): Use eglot--semtok-font-lock.
(eglot--semtok-ingest-delta-response): Rename from
eglot--semtok-ingest-full/delta-response
(eglot--semtok-request): Use new function.

lisp/progmodes/eglot.el

@@ -141,8 +141,6 @@
 (defvar company-tooltip-align-annotations)
 (defvar tramp-ssh-controlmaster-options)
 (defvar tramp-use-ssh-controlmaster-options)
-(defvar eglot-semantic-tokens-faces)
-(defvar eglot-semantic-tokens-modifier-faces)
 
 
 ;;; Obsolete aliases
@@ -631,6 +629,71 @@ Note additionally:
                    (string :tag "Specify your own")))
   :package-version '(Eglot . "1.19"))
 
+(defcustom eglot-semantic-tokens-faces
+  '(("namespace" . font-lock-keyword-face)
+    ("type" . font-lock-type-face)
+    ("class" . font-lock-type-face)
+    ("enum" . font-lock-type-face)
+    ("interface" . font-lock-type-face)
+    ("struct" . font-lock-type-face)
+    ("typeParameter" . font-lock-type-face)
+    ("parameter" . font-lock-variable-name-face)
+    ("variable" . font-lock-variable-name-face)
+    ("property" . font-lock-property-use-face)
+    ("enumMember" . font-lock-constant-face)
+    ("event" . font-lock-variable-name-face)
+    ("function" . font-lock-function-name-face)
+    ("method" . font-lock-function-name-face)
+    ("macro" . font-lock-preprocessor-face)
+    ("keyword" . font-lock-keyword-face)
+    ("modifier" . font-lock-function-name-face)
+    ("comment" . font-lock-comment-face)
+    ("string" . font-lock-string-face)
+    ("number" . font-lock-constant-face)
+    ("regexp" . font-lock-string-face)
+    ("operator" . font-lock-function-name-face)
+    ("decorator" . font-lock-type-face))
+  "Alist of faces to use to highlight semantic tokens.
+Each element is a cons cell whose car is a token type name and cdr is
+the face to use."
+  :type `(alist :key-type (string :tag "Token name")
+                :value-type (choice (face :tag "Face")
+                                    (plist :tag "Face Attributes"
+                                           :key-type
+                                           (choice
+                                            ,@(mapcar
+                                               (lambda (cell)
+                                                 `(const :tag ,(capitalize
+                                                                (cdr cell))
+                                                         ,(car cell)))
+                                               face-attribute-name-alist))))))
+
+(defcustom eglot-semantic-tokens-modifier-faces
+  '(("declaration" . font-lock-function-name-face)
+    ("definition" . font-lock-function-name-face)
+    ("readonly" . font-lock-constant-face)
+    ("static" . font-lock-keyword-face)
+    ("deprecated" . eglot-diagnostic-tag-deprecated-face)
+    ("abstract" . font-lock-keyword-face)
+    ("async" . font-lock-preprocessor-face)
+    ("modification" . font-lock-function-name-face)
+    ("documentation" . font-lock-doc-face)
+    ("defaultLibrary" . font-lock-builtin-face))
+  "List of face to use to highlight tokens with modifiers.
+Each element is a cons cell whose car is a modifier name and cdr is
+the face to use."
+  :type `(alist :key-type (string :tag "Token name")
+                :value-type (choice (face :tag "Face")
+                                    (plist :tag "Face Attributes"
+                                           :key-type
+                                           (choice
+                                            ,@(mapcar
+                                               (lambda (cell)
+                                                 `(const :tag ,(capitalize
+                                                                (cdr cell))
+                                                         ,(car cell)))
+                                               face-attribute-name-alist))))))
+
 (defvar eglot-withhold-process-id nil
   "If non-nil, Eglot will not send the Emacs process id to the language server.
 This can be useful when using docker to run a language server.")
@@ -4531,75 +4594,95 @@ If NOERROR, return predicate, else erroring function."
 
 
 ;;; Semantic tokens
-
+(defun eglot--semtok-font-lock (limit)
-(defcustom eglot-semantic-tokens-faces
+  "Apply face property for tokens from point until LIMIT.
-  '(("namespace" . font-lock-keyword-face)
+Intended for `font-lock-add-keywords'."
-    ("type" . font-lock-type-face)
+  (with-slots ((faces semtok-faces)
-    ("class" . font-lock-type-face)
+               (modifier-faces semtok-modifier-faces)
-    ("enum" . font-lock-type-face)
+               (modifier-cache semtok-modifier-cache))
-    ("interface" . font-lock-type-face)
+      (eglot-current-server)
-    ("struct" . font-lock-type-face)
+    (let (beg (end (point)) tok)
-    ("typeParameter" . font-lock-type-face)
+      (while (and (< end limit)
-    ("parameter" . font-lock-variable-name-face)
+                  (setq beg (text-property-not-all end limit 'eglot-semantic-token nil))
-    ("variable" . font-lock-variable-name-face)
+                  (setq end (next-single-property-change beg 'eglot-semantic-token nil limit))
-    ("property" . font-lock-property-use-face)
+                  (setq tok (get-text-property beg 'eglot-semantic-token)))
-    ("enumMember" . font-lock-constant-face)
+        (when-let* ((face (aref faces (car tok))))
-    ("event" . font-lock-variable-name-face)
+          (add-face-text-property beg end face))
-    ("function" . font-lock-function-name-face)
+        (let* ((code (cdr tok))
-    ("method" . font-lock-function-name-face)
+               (faces (gethash code modifier-cache 'not-found)))
-    ("macro" . font-lock-preprocessor-face)
+          (when (eq faces 'not-found)
-    ("keyword" . font-lock-keyword-face)
+            (setq faces (cl-loop for j from 0 below (length modifier-faces)
-    ("modifier" . font-lock-function-name-face)
+                                 if (> (logand code (ash 1 j)) 0)
-    ("comment" . font-lock-comment-face)
+                                 if (aref modifier-faces j)
-    ("string" . font-lock-string-face)
+                                 collect (aref modifier-faces j)))
-    ("number" . font-lock-constant-face)
+            (puthash code faces modifier-cache))
-    ("regexp" . font-lock-string-face)
+          (dolist (face faces) (add-face-text-property beg end face)))))
-    ("operator" . font-lock-function-name-face)
+    nil))
-    ("decorator" . font-lock-type-face))
-  "Alist of faces to use to highlight semantic tokens.
-Each element is a cons cell whose car is a token type name and cdr is
-the face to use."
-  :type `(alist :key-type (string :tag "Token name")
-                :value-type (choice (face :tag "Face")
-                                    (plist :tag "Face Attributes"
-                                           :key-type
-                                           (choice
-                                            ,@(mapcar
-                                               (lambda (cell)
-                                                 `(const :tag ,(capitalize
-                                                                (cdr cell))
-                                                         ,(car cell)))
-                                               face-attribute-name-alist))))))
-
-(defcustom eglot-semantic-tokens-modifier-faces
-  '(("declaration" . font-lock-function-name-face)
-    ("definition" . font-lock-function-name-face)
-    ("readonly" . font-lock-constant-face)
-    ("static" . font-lock-keyword-face)
-    ("deprecated" . eglot-diagnostic-tag-deprecated-face)
-    ("abstract" . font-lock-keyword-face)
-    ("async" . font-lock-preprocessor-face)
-    ("modification" . font-lock-function-name-face)
-    ("documentation" . font-lock-doc-face)
-    ("defaultLibrary" . font-lock-builtin-face))
-  "List of face to use to highlight tokens with modifiers.
-Each element is a cons cell whose car is a modifier name and cdr is
-the face to use."
-  :type `(alist :key-type (string :tag "Token name")
-                :value-type (choice (face :tag "Face")
-                                    (plist :tag "Face Attributes"
-                                           :key-type
-                                           (choice
-                                            ,@(mapcar
-                                               (lambda (cell)
-                                                 `(const :tag ,(capitalize
-                                                                (cdr cell))
-                                                         ,(car cell)))
-                                               face-attribute-name-alist))))))
 
 (defvar-local eglot--semtok-idle-timer nil
   "Idle timer to request full semantic tokens.")
 
+(defun eglot--semtok-request-full-on-idle ()
+  "Make a full semantic tokens request after an idle timer."
+  (let* ((buf (current-buffer))
+         (fun (lambda ()
+                (eglot--when-live-buffer buf (eglot--semtok-request)))))
+    (when eglot--semtok-idle-timer (cancel-timer eglot--semtok-idle-timer))
+    (setq eglot--semtok-idle-timer (run-with-idle-timer (* 3 eglot-send-changes-idle-time) nil fun))))
+
+(cl-defmethod eglot-handle-request
+  (server (_method (eql workspace/semanticTokens/refresh)))
+  "Handle a semanticTokens/refresh request from SERVER."
+  (dolist (buffer (eglot--managed-buffers server))
+    (eglot--when-live-buffer buffer
+      (cl-incf eglot--versioned-identifier)
+      (font-lock-flush))))
+
+(defun eglot--semtok-build-face-map (identifiers faces category varname)
+  "Build map of FACES for IDENTIFIERS using CATEGORY and VARNAME."
+  (vconcat
+   (mapcar (lambda (id)
+             (let ((maybe-face (cdr (assoc id faces))))
+               (when (not maybe-face)
+                 (eglot--warn "No face has been associated to the %s `%s': consider adding a corresponding definition to %s"
+                                 category id varname))
+               maybe-face))
+           identifiers)))
+
+(defun eglot--semtok-initialize (server)
+  "Initialize SERVER for semantic tokens."
+  (cl-destructuring-bind (&key tokenTypes tokenModifiers &allow-other-keys)
+      (plist-get (plist-get (eglot--capabilities server)
+                            :semanticTokensProvider)
+                 :legend)
+    (oset server semtok-faces
+          (eglot--semtok-build-face-map
+           tokenTypes eglot-semantic-tokens-faces
+           "semantic token" "eglot-semantic-tokens-faces"))
+    (oset server semtok-modifier-faces
+          (eglot--semtok-build-face-map
+           tokenModifiers eglot-semantic-tokens-modifier-faces
+           "semantic token modifier" "eglot-semantic-tokens-modifier-faces"))))
+
+(define-minor-mode eglot-semantic-tokens-mode
+  "Minor mode for fontifying buffer with LSP server's semantic tokens."
+  :global nil
+  (when eglot-semantic-tokens-mode
+    (if (not (eglot-server-capable :semanticTokensProvider))
+        (eglot-semantic-tokens-mode -1)
+      (with-silent-modifications
+        (save-restriction
+          (widen)
+          (remove-list-of-text-properties
+           (point-min) (point-max) '(eglot--semtok-propertized))))
+      (jit-lock-register #'eglot--semtok-propertize)
+      (font-lock-add-keywords nil '((eglot--semtok-font-lock)) 'append)
+      (font-lock-flush)))
+  (unless eglot-semantic-tokens-mode
+    (jit-lock-unregister #'eglot--semtok-propertize)
+    (font-lock-remove-keywords nil '((eglot--semtok-font-lock)))
+    (font-lock-flush)))
+
 (defvar-local eglot--semtok-cache nil
   "Cache of the last response from the server.")
 
@@ -4631,7 +4714,7 @@ the face to use."
      finally do (push (substring old-data old-token-index old-token-count) substrings))
     (apply #'vconcat (nreverse substrings))))
 
-(defun eglot--semtok-ingest-full/delta-response (response)
+(defun eglot--semtok-ingest-delta-response (response)
   "Handle RESPONSE to semanticTokens/full/delta request."
   (if-let* ((edits (plist-get response :edits)))
       (progn
@@ -4668,7 +4751,7 @@ the face to use."
              (and (plist-get response :resultId) (plist-get response :data)
                   (not (plist-get eglot--semtok-cache :region)))))
       (setq method :textDocument/semanticTokens/full/delta)
-      (setq response-handler #'eglot--semtok-ingest-full/delta-response)
+      (setq response-handler #'eglot--semtok-ingest-delta-response)
       (setq params
             (plist-put params :previousResultId
                        (plist-get (plist-get eglot--semtok-cache :response) :resultId))))
@@ -4745,91 +4828,6 @@ Also request new tokens from the server, if necessary."
                                         (aref data (+ i 4))))))
            (put-text-property beg end 'eglot--semtok-propertized eglot--versioned-identifier)))))))
 
-(defun eglot--semtok-fontify-tokens (limit)
-  "Apply face property for tokens from point until LIMIT."
-  (with-slots ((faces semtok-faces)
-               (modifier-faces semtok-modifier-faces)
-               (modifier-cache semtok-modifier-cache))
-      (eglot-current-server)
-    (let (beg (end (point)) tok)
-      (while (and (< end limit)
-                  (setq beg (text-property-not-all end limit 'eglot-semantic-token nil))
-                  (setq end (next-single-property-change beg 'eglot-semantic-token nil limit))
-                  (setq tok (get-text-property beg 'eglot-semantic-token)))
-        (when-let* ((face (aref faces (car tok))))
-          (add-face-text-property beg end face))
-        (let* ((code (cdr tok))
-               (faces (gethash code modifier-cache 'not-found)))
-          (when (eq faces 'not-found)
-            (setq faces (cl-loop for j from 0 below (length modifier-faces)
-                                 if (> (logand code (ash 1 j)) 0)
-                                 if (aref modifier-faces j)
-                                 collect (aref modifier-faces j)))
-            (puthash code faces modifier-cache))
-          (dolist (face faces) (add-face-text-property beg end face)))))
-    nil))
-
-(defun eglot--semtok-request-full-on-idle ()
-  "Make a full semantic tokens request after an idle timer."
-  (let* ((buf (current-buffer))
-         (fun (lambda ()
-                (eglot--when-live-buffer buf (eglot--semtok-request)))))
-    (when eglot--semtok-idle-timer (cancel-timer eglot--semtok-idle-timer))
-    (setq eglot--semtok-idle-timer (run-with-idle-timer (* 3 eglot-send-changes-idle-time) nil fun))))
-
-(cl-defmethod eglot-handle-request
-  (server (_method (eql workspace/semanticTokens/refresh)))
-  "Handle a semanticTokens/refresh request from SERVER."
-  (dolist (buffer (eglot--managed-buffers server))
-    (eglot--when-live-buffer buffer
-      (cl-incf eglot--versioned-identifier)
-      (font-lock-flush))))
-
-(defun eglot--semtok-build-face-map (identifiers faces category varname)
-  "Build map of FACES for IDENTIFIERS using CATEGORY and VARNAME."
-  (vconcat
-   (mapcar (lambda (id)
-             (let ((maybe-face (cdr (assoc id faces))))
-               (when (not maybe-face)
-                 (eglot--warn "No face has been associated to the %s `%s': consider adding a corresponding definition to %s"
-                                 category id varname))
-               maybe-face))
-           identifiers)))
-
-(defun eglot--semtok-initialize (server)
-  "Initialize SERVER for semantic tokens."
-  (cl-destructuring-bind (&key tokenTypes tokenModifiers &allow-other-keys)
-      (plist-get (plist-get (eglot--capabilities server)
-                            :semanticTokensProvider)
-                 :legend)
-    (oset server semtok-faces
-          (eglot--semtok-build-face-map
-           tokenTypes eglot-semantic-tokens-faces
-           "semantic token" "eglot-semantic-tokens-faces"))
-    (oset server semtok-modifier-faces
-          (eglot--semtok-build-face-map
-           tokenModifiers eglot-semantic-tokens-modifier-faces
-           "semantic token modifier" "eglot-semantic-tokens-modifier-faces"))))
-
-(define-minor-mode eglot-semantic-tokens-mode
-  "Minor mode for fontifying buffer with LSP server's semantic tokens."
-  :global nil
-  (when eglot-semantic-tokens-mode
-    (if (not (eglot-server-capable :semanticTokensProvider))
-        (eglot-semantic-tokens-mode -1)
-      (with-silent-modifications
-        (save-restriction
-          (widen)
-          (remove-list-of-text-properties
-           (point-min) (point-max) '(eglot--semtok-propertized))))
-      (jit-lock-register #'eglot--semtok-propertize)
-      (font-lock-add-keywords nil '((eglot--semtok-fontify-tokens)) 'append)
-      (font-lock-flush)))
-  (unless eglot-semantic-tokens-mode
-    (jit-lock-unregister #'eglot--semtok-propertize)
-    (font-lock-remove-keywords nil '((eglot--semtok-fontify-tokens)))
-    (font-lock-flush)))
-
 
 ;;; Call and type hierarchies
 (require 'button)