;;; lsp-semantic-tokens.el --- Semantic tokens -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020 emacs-lsp maintainers
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;;  Semantic tokens
;;  https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens
;;
;;; Code:

(require 'lsp-mode)
(require 'dash)

(defgroup lsp-semantic-tokens nil
  "LSP support for semantic-tokens."
  :prefix "lsp-semantic-tokens-"
  :group 'lsp-mode
  :tag "LSP Semantic tokens")

(define-obsolete-variable-alias 'lsp-semantic-highlighting-warn-on-missing-face 'lsp-semantic-tokens-warn-on-missing-face "lsp-mode 8.0.0")

(defcustom lsp-semantic-tokens-warn-on-missing-face nil
  "Warning on missing face for token type/modifier.
When non-nil, this option will emit a warning any time a token
or modifier type returned by a language server has no face associated with it."
  :group 'lsp-semantic-tokens
  :type 'boolean)

(defcustom lsp-semantic-tokens-apply-modifiers t
  "Whether semantic tokens should take token modifiers into account."
  :group 'lsp-semantic-tokens
  :type 'boolean)

(defcustom lsp-semantic-tokens-allow-ranged-requests t
  "Whether to use ranged semantic token requests when available.

Note that even when this is set to t, delta requests will
be preferred whenever possible, unless
`lsp-semantic-tokens-allow-delta-requests' is false."
  :group 'lsp-semantic-tokens
  :type 'boolean)

(defcustom lsp-semantic-tokens-allow-delta-requests t
  "Whether to use semantic token delta requests when available.

When supported by the language server, delta requests are always
preferred over both full and ranged token requests."
  :group 'lsp-semantic-tokens
  :type 'boolean)

(defcustom lsp-semantic-tokens-honor-refresh-requests nil
  "Whether to honor semanticTokens/refresh requests.

When set to nil, refresh requests will be silently discarded.
When set to t, semantic tokens will be re-requested for all buffers
associated with the requesting language server."
  :group 'lsp-semantic-tokens
  :type 'boolean)

(defcustom lsp-semantic-tokens-enable-multiline-token-support t
  "When set to nil, tokens will be truncated after end-of-line."
  :group 'lsp-semantic-tokens
  :type 'boolean)

(defface lsp-face-semhl-constant
  '((t :inherit font-lock-constant-face))
  "Face used for semantic highlighting scopes matching constant scopes."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-variable
  '((t :inherit font-lock-variable-name-face))
  "Face used for semantic highlighting scopes matching variable.*.
Unless overridden by a more specific face association."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-function
  '((t :inherit font-lock-function-name-face))
  "Face used for semantic highlighting scopes matching entity.name.function.*.
Unless overridden by a more specific face association."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-method
  '((t :inherit lsp-face-semhl-function))
  "Face used for semantic highlighting scopes matching entity.name.method.*.
Unless overridden by a more specific face association."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-namespace
  '((t :inherit font-lock-type-face :weight bold))
  "Face used for semantic highlighting scopes matching entity.name.namespace.*.
Unless overridden by a more specific face association."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-comment
  '((t (:inherit font-lock-comment-face)))
  "Face used for comments."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-keyword
  '((t (:inherit font-lock-keyword-face)))
  "Face used for keywords."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-string
  '((t (:inherit font-lock-string-face)))
  "Face used for keywords."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-number
  '((t (:inherit font-lock-constant-face)))
  "Face used for numbers."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-regexp
  '((t (:inherit font-lock-string-face :slant italic)))
  "Face used for regexps."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-operator
  '((t (:inherit font-lock-function-name-face)))
  "Face used for operators."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-namespace
  '((t (:inherit font-lock-keyword-face)))
  "Face used for namespaces."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-type
  '((t (:inherit font-lock-type-face)))
  "Face used for types."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-struct
  '((t (:inherit font-lock-type-face)))
  "Face used for structs."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-class
  '((t (:inherit font-lock-type-face)))
  "Face used for classes."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-interface
  '((t (:inherit font-lock-type-face)))
  "Face used for interfaces."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-enum
  '((t (:inherit font-lock-type-face)))
  "Face used for enums."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-type-parameter
  '((t (:inherit font-lock-type-face)))
  "Face used for type parameters."
  :group 'lsp-semantic-tokens)

;; function face already defined, move here when support
;; for theia highlighting gets removed
(defface lsp-face-semhl-member
  '((t (:inherit font-lock-variable-name-face)))
  "Face used for members."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-property
  '((t (:inherit font-lock-variable-name-face)))
  "Face used for properties."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-event
  '((t (:inherit font-lock-variable-name-face)))
  "Face used for event properties."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-macro
  '((t (:inherit font-lock-preprocessor-face)))
  "Face used for macros."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-variable
  '((t (:inherit font-lock-variable-name-face)))
  "Face used for variables."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-parameter
  '((t (:inherit font-lock-variable-name-face)))
  "Face used for parameters."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-label
  '((t (:inherit font-lock-comment-face)))
  "Face used for labels."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-deprecated
  '((t :strike-through t))
  "Face used for semantic highlighting scopes matching constant scopes."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-definition
  '((t :inherit font-lock-function-name-face :weight bold))
  "Face used for definition modifier."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-implementation
  '((t :inherit font-lock-function-name-face :weight bold))
  "Face used for implementation modifier."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-default-library
  '((t :inherit font-lock-builtin-face))
  "Face used for defaultLibrary modifier."
  :group 'lsp-semantic-tokens)

(defface lsp-face-semhl-static
  '((t :inherit font-lock-keyword-face))
  "Face used for static modifier."
  :group 'lsp-semantic-tokens)

(defvar-local lsp-semantic-token-faces
  '(("comment" . lsp-face-semhl-comment)
    ("keyword" . lsp-face-semhl-keyword)
    ("string" . lsp-face-semhl-string)
    ("number" . lsp-face-semhl-number)
    ("regexp" . lsp-face-semhl-regexp)
    ("operator" . lsp-face-semhl-operator)
    ("namespace" . lsp-face-semhl-namespace)
    ("type" . lsp-face-semhl-type)
    ("struct" . lsp-face-semhl-struct)
    ("class" . lsp-face-semhl-class)
    ("interface" . lsp-face-semhl-interface)
    ("enum" . lsp-face-semhl-enum)
    ("typeParameter" . lsp-face-semhl-type-parameter)
    ("function" . lsp-face-semhl-function)
    ("method" . lsp-face-semhl-method)
    ("member" . lsp-face-semhl-member)
    ("property" . lsp-face-semhl-property)
    ("event" . lsp-face-semhl-event)
    ("macro" . lsp-face-semhl-macro)
    ("variable" . lsp-face-semhl-variable)
    ("parameter" . lsp-face-semhl-parameter)
    ("label" . lsp-face-semhl-label)
    ("enumConstant" . lsp-face-semhl-constant)
    ("enumMember" . lsp-face-semhl-constant)
    ("dependent" . lsp-face-semhl-type)
    ("concept" . lsp-face-semhl-interface))
  "Faces to use for semantic tokens.")

(defvar-local lsp-semantic-token-modifier-faces
  '(("declaration" . lsp-face-semhl-interface)
    ("definition" . lsp-face-semhl-definition)
    ("implementation" . lsp-face-semhl-implementation)
    ("readonly" . lsp-face-semhl-constant)
    ("static" . lsp-face-semhl-static)
    ("deprecated" . lsp-face-semhl-deprecated)
    ("abstract" . lsp-face-semhl-keyword)
    ("async" . lsp-face-semhl-macro)
    ("modification" . lsp-face-semhl-operator)
    ("documentation" . lsp-face-semhl-comment)
    ("defaultLibrary" . lsp-face-semhl-default-library))
  "Semantic tokens modifier faces.
Faces to use for semantic token modifiers if
`lsp-semantic-tokens-apply-modifiers' is non-nil.")

(defun lsp--semantic-tokens-capabilities ()
  `((semanticTokens
     . ((dynamicRegistration . t)
        (requests . ((range . t) (full . t)))
        (tokenModifiers . ,(if lsp-semantic-tokens-apply-modifiers
                               (apply 'vector (mapcar #'car (lsp-semantic-tokens--modifier-faces-for (lsp--workspace-client lsp--cur-workspace))))
                             []))
        (overlappingTokenSupport . t)
        (multilineTokenSupport . ,(if lsp-semantic-tokens-enable-multiline-token-support t json-false))
        (tokenTypes . ,(apply 'vector (mapcar #'car (lsp-semantic-tokens--type-faces-for (lsp--workspace-client lsp--cur-workspace)))))
        (formats . ["relative"])))))

(defvar lsp--semantic-tokens-pending-full-token-requests '()
  "Buffers which should have their semantic tokens refreshed on idle.

This is an alist of the form ((buffer_i . fontify_immediately_i) ...); entries
with fontify_immediately set to t will immediately refontify once their
token request is answered.")

;; NOTE: doesn't keep track of outstanding requests, so might still produce large latency outliers
;; if the language server doesn't process all outstanding token requests within one lsp-idle-delay
(defcustom lsp-semantic-tokens-max-concurrent-idle-requests 1
  "Maximum number of on-idle token requests to be dispatched simultaneously."
  :group 'lsp-semantic-tokens
  :type 'integer)

(defvar lsp--semantic-tokens-idle-timer nil)

(defun lsp--semantic-tokens-process-pending-requests ()
  (let ((fuel lsp-semantic-tokens-max-concurrent-idle-requests))
    (while (and lsp--semantic-tokens-pending-full-token-requests (> fuel 0))
      (-let (((buffer . fontify-immediately) (pop lsp--semantic-tokens-pending-full-token-requests)))
        (when (buffer-live-p buffer)
          (setq fuel (1- fuel))
          (with-current-buffer buffer
            (lsp--semantic-tokens-request nil fontify-immediately))))))
  (unless lsp--semantic-tokens-pending-full-token-requests
    (cancel-timer lsp--semantic-tokens-idle-timer)
    (setq lsp--semantic-tokens-idle-timer nil)))

(defun lsp--semantic-tokens-sort-pending-requests (pending-requests)
  ;; service currently visible buffers first, otherwise prefer immediate-fontification requests
  (-sort (lambda (entry-a entry-b)
           (let ((a-hidden (eq nil (get-buffer-window (car entry-a))))
                 (b-hidden (eq nil (get-buffer-window (car entry-b)))))
             (cond ((and b-hidden (not a-hidden)) t)   ; sort a before b
                   ((and a-hidden (not b-hidden)) nil) ; sort b before a
                   ((and (not (cdr entry-a)) (cdr entry-b)) nil) ; otherwise sort b before a only if b is immediate and a is not
                   (t t))))
         (--filter (buffer-live-p (car it)) pending-requests)))

(defun lsp--semantic-tokens-request-full-token-set-when-idle (buffer fontify-immediately)
  "Request full token set after an idle timeout of `lsp-idle-delay'.

If FONTIFY-IMMEDIATELY is non-nil, fontification will be performed immediately
 once the corresponding response is received."
  (let ((do-fontify-immediately (or fontify-immediately
                                    (cdr (assoc buffer lsp--semantic-tokens-pending-full-token-requests)))))
    (setq lsp--semantic-tokens-pending-full-token-requests
          (lsp--semantic-tokens-sort-pending-requests
           (cons (cons buffer do-fontify-immediately)
                 (--remove (eq buffer (car it)) lsp--semantic-tokens-pending-full-token-requests)))))
  (unless lsp--semantic-tokens-idle-timer
    (setq lsp--semantic-tokens-idle-timer
          (run-with-idle-timer lsp-idle-delay t #'lsp--semantic-tokens-process-pending-requests))))

(defun lsp--semantic-tokens-refresh-if-enabled (buffer)
  (when (buffer-local-value 'lsp-semantic-tokens-mode buffer)
    (lsp--semantic-tokens-request-full-token-set-when-idle buffer t)))

(defvar-local lsp--semantic-tokens-cache nil
  "Previously returned token set.

When non-nil, `lsp--semantic-tokens-cache' should adhere to the
following lsp-interface:
`(_SemanticTokensCache
  (:_documentVersion)
  (:response :_region :_truncated))'.")

(defsubst lsp--semantic-tokens-putcache (k v)
  "Set key K of `lsp--semantic-tokens-cache' to V."
  (setq lsp--semantic-tokens-cache
        (plist-put lsp--semantic-tokens-cache k v)))

(defvar-local lsp--semantic-tokens-teardown nil)

(defun lsp--semantic-tokens-ingest-range-response (response)
  "Handle RESPONSE to semanticTokens/range request."
  (lsp--semantic-tokens-putcache :response response)
  (cl-assert (plist-get lsp--semantic-tokens-cache :_region))
  (lsp--semantic-tokens-request-full-token-set-when-idle (current-buffer) nil))

(defun lsp--semantic-tokens-ingest-full-response (response)
  "Handle RESPONSE to semanticTokens/full request."
  (lsp--semantic-tokens-putcache :response response)
  (cl-assert (not (plist-get lsp--semantic-tokens-cache :_region))))

(defsubst lsp--semantic-tokens-apply-delta-edits (old-data edits)
  "Apply EDITS obtained from full/delta request to OLD-DATA."
  (let* ((old-token-count (length old-data))
         (old-token-index 0)
         (substrings))
    (cl-loop
     for edit across edits
     do
     (when (< old-token-index (lsp-get edit :start))
       (push (substring old-data old-token-index (lsp-get edit :start)) substrings))
     (push (lsp-get edit :data) substrings)
     (setq old-token-index (+ (lsp-get edit :start) (lsp-get edit :deleteCount)))
     finally do (push (substring old-data old-token-index old-token-count) substrings))
    (apply #'vconcat (nreverse substrings))))

(defun lsp--semantic-tokens-ingest-full/delta-response (response)
  "Handle RESPONSE to semanticTokens/full/delta request."
  (if (lsp-get response :edits)
      (let ((old-data (--> lsp--semantic-tokens-cache (plist-get it :response) (lsp-get it :data))))
        (cl-assert (not (plist-get lsp--semantic-tokens-cache :_region)))
        (when old-data
          (lsp--semantic-tokens-putcache
           :response (lsp-put response
                              :data (lsp--semantic-tokens-apply-delta-edits
                                     old-data (lsp-get response :edits))))))
    ;; server decided to send full response instead
    (lsp--semantic-tokens-ingest-full-response response)))


(defun lsp--semantic-tokens-request (region fontify-immediately)
  "Send semantic tokens request to the language server.

A full/delta request will be sent if delta requests are supported by
the language server, allowed via `lsp-semantic-tokens-allow-delta-requests',
and if a full set of tokens had previously been received.
Otherwise, a ranged request will be dispatched if REGION is non-nil,
ranged requests are supported by the language server, and allowed via
`lsp-semantic-tokens-allow-delta-requests'. In all other cases, a full
tokens request will be dispatched.

If FONTIFY-IMMEDIATELY is non-nil, fontification will be performed immediately
 upon receiving the response."
  (let ((request-type "textDocument/semanticTokens/full")
        (request `(:textDocument ,(lsp--text-document-identifier)))
        (response-handler nil)
        (final-region nil))
    (cond
     ((and lsp-semantic-tokens-allow-delta-requests
           (lsp-feature? "textDocument/semanticTokensFull/Delta")
           (--> lsp--semantic-tokens-cache
                (plist-get it :response)
                (and (lsp-get it :resultId) (lsp-get it :data)
                     (not (plist-get lsp--semantic-tokens-cache :_region)))))
      (setq request-type "textDocument/semanticTokens/full/delta")
      (setq response-handler #'lsp--semantic-tokens-ingest-full/delta-response)
      (setq request
            (plist-put request :previousResultId
                       (lsp-get (plist-get lsp--semantic-tokens-cache :response) :resultId))))
     ((and lsp-semantic-tokens-allow-ranged-requests region
           (lsp-feature? "textDocument/semanticTokensRangeProvider"))
      (setq request-type "textDocument/semanticTokens/range")
      (setq final-region region)
      (setq request
            (plist-put request :range (lsp--region-to-range (car final-region) (cdr final-region))))
      (setq response-handler #'lsp--semantic-tokens-ingest-range-response))
     (t (setq response-handler #'lsp--semantic-tokens-ingest-full-response)))
    (lsp-request-async
     request-type request
     (lambda (response)
       (lsp--semantic-tokens-putcache :_documentVersion lsp--cur-version)
       (lsp--semantic-tokens-putcache :_region final-region)
       (funcall response-handler response)
       (when (or fontify-immediately (plist-get lsp--semantic-tokens-cache :_truncated)) (font-lock-flush)))
     :error-handler ;; buffer is not captured in `error-handler', it is in `callback'
     (let ((buf (current-buffer)))
       (lambda (&rest _)
         (when (buffer-live-p buf)
           (lsp--semantic-tokens-request-full-token-set-when-idle buf t))))
     :mode 'tick
     :cancel-token (format "semantic-tokens-%s" (lsp--buffer-uri)))))


;;;###autoload
(defvar-local semantic-token-modifier-cache (make-hash-table)
  "A cache of modifier values to the selected fonts.
This allows whole-bitmap lookup instead of checking each bit. The
expectation is that usage of modifiers will tend to cluster, so
we will not have the full range of possible usages, hence a
tractable hash map.

This is set as buffer-local. It should probably be shared in a
given workspace/language-server combination.

This cache should be flushed every time any modifier
configuration changes.")

(defun lsp-semantic-tokens--fontify (old-fontify-region beg-orig end-orig &optional loudly)
  "Apply fonts to retrieved semantic tokens.
OLD-FONTIFY-REGION is the underlying region fontification function,
e.g., `font-lock-fontify-region'.
BEG-ORIG and END-ORIG deliminate the requested fontification region and maybe
modified by OLD-FONTIFY-REGION.
LOUDLY will be forwarded to OLD-FONTIFY-REGION as-is."
  ;; TODO: support multiple language servers per buffer?
  (let ((faces (seq-some #'lsp--workspace-semantic-tokens-faces lsp--buffer-workspaces))
        (modifier-faces
         (when lsp-semantic-tokens-apply-modifiers
           (seq-some #'lsp--workspace-semantic-tokens-modifier-faces lsp--buffer-workspaces)))
        old-bounds
        beg end)
    (cond
     ((or (eq nil faces)
          (eq nil lsp--semantic-tokens-cache)
          (eq nil (plist-get lsp--semantic-tokens-cache :response)))
      ;; default to non-semantic highlighting until first response has arrived
      (funcall old-fontify-region beg-orig end-orig loudly))
     ((not (= lsp--cur-version (plist-get lsp--semantic-tokens-cache :_documentVersion)))
      ;; delay fontification until we have fresh tokens
      '(jit-lock-bounds 0 . 0))
     (t
      (setq old-bounds (funcall old-fontify-region beg-orig end-orig loudly))
      ;; this is to prevent flickering when semantic token highlighting
      ;; is layered on top of, e.g., tree-sitter-hl, or clojure-mode's syntax highlighting.
      (setq beg (min beg-orig (cadr old-bounds))
            end (max end-orig (cddr old-bounds)))
      ;; if we're using the response to a ranged request, we'll only be able to fontify within
      ;; that range (and hence shouldn't clear any highlights outside of that range)
      (let ((token-region (plist-get lsp--semantic-tokens-cache :_region)))
        (if token-region
            (progn
              (lsp--semantic-tokens-putcache :_truncated (or (< beg (car token-region))
                                                             (> end (cdr token-region))))
              (setq beg (max beg (car token-region)))
              (setq end (min end (cdr token-region))))
          (lsp--semantic-tokens-putcache :_truncated nil)))
      (-let* ((inhibit-field-text-motion t)
              (data (lsp-get (plist-get lsp--semantic-tokens-cache :response) :data))
              (i0 0)
              (i-max (1- (length data)))
              (current-line 1)
              (line-delta)
              (column 0)
              (face)
              (line-start-pos)
              (line-min)
              (line-max-inclusive)
              (text-property-beg)
              (text-property-end))
        (save-mark-and-excursion
          (save-restriction
            (widen)
            (goto-char beg)
            (goto-char (line-beginning-position))
            (setq line-min (line-number-at-pos))
            (with-silent-modifications
              (goto-char end)
              (goto-char (line-end-position))
              (setq line-max-inclusive (line-number-at-pos))
              (forward-line (- line-min line-max-inclusive))
              (let ((skip-lines (- line-min current-line)))
                (while (and (<= i0 i-max) (< (aref data i0) skip-lines))
                  (setq skip-lines (- skip-lines (aref data i0)))
                  (setq i0 (+ i0 5)))
                (setq current-line (- line-min skip-lines)))
              (forward-line (- current-line line-min))
              (setq line-start-pos (point))
              (cl-loop
               for i from i0 to i-max by 5 do
               (setq line-delta (aref data i))
               (unless (= line-delta 0)
                 (forward-line line-delta)
                 (setq line-start-pos (point))
                 (setq column 0)
                 (setq current-line (+ current-line line-delta)))
               (setq column (+ column (aref data (1+ i))))
               (setq face (aref faces (aref data (+ i 3))))
               (setq text-property-beg (+ line-start-pos column))
               (setq text-property-end
                     (min (if lsp-semantic-tokens-enable-multiline-token-support
                              (point-max) (line-end-position))
                      (+ text-property-beg (aref data (+ i 2)))))
               (when face
                 (put-text-property text-property-beg text-property-end 'face face))
               ;; Deal with modifiers. We cache common combinations of
               ;; modifiers, storing the faces they resolve to.
               (let* ((modifier-code (aref data (+ i 4)))
                      (faces-to-apply (gethash modifier-code semantic-token-modifier-cache 'not-found)))
                 (when (eq 'not-found faces-to-apply)
                   (setq faces-to-apply nil)
                   (cl-loop for j from 0 to (1- (length modifier-faces)) do
                            (when (and (aref modifier-faces j)
                                       (> (logand modifier-code (ash 1 j)) 0))
                              (push (aref modifier-faces j) faces-to-apply)))
                   (puthash modifier-code faces-to-apply semantic-token-modifier-cache))
                 (dolist (face faces-to-apply)
                   (add-face-text-property text-property-beg text-property-end face)))
               when (> current-line line-max-inclusive) return nil)))))
      `(jit-lock-bounds ,beg . ,end)))))

(defun lsp-semantic-tokens--request-update ()
  "Request semantic-tokens update."
  ;; when dispatching ranged requests, we'll over-request by several chunks in both directions,
  ;; which should minimize those occasions where font-lock region extension extends beyond the
  ;; region covered by our freshly requested tokens (see lsp-mode issue #3154), while still limiting
  ;; requests to fairly small regions even if the underlying buffer is large
  (when (lsp-feature? "textDocument/semanticTokensFull")
    (lsp--semantic-tokens-request
     (cons (max (point-min) (- (window-start) (* 5 jit-lock-chunk-size)))
           (min (point-max) (+ (window-end) (* 5 jit-lock-chunk-size)))) t)))

(defun lsp--semantic-tokens-as-defined-by-workspace (workspace)
  "Return plist of token-types and token-modifiers defined by WORKSPACE,
or nil if none are defined."
  (when-let ((token-capabilities
              (or
               (-some->
                   (lsp--registered-capability "textDocument/semanticTokens")
                 (lsp--registered-capability-options))
               (lsp:server-capabilities-semantic-tokens-provider?
                (lsp--workspace-server-capabilities workspace)))))
    (-let* (((&SemanticTokensOptions :legend) token-capabilities))
      `(:token-types ,(lsp:semantic-tokens-legend-token-types legend)
        :token-modifiers ,(lsp:semantic-tokens-legend-token-modifiers legend)))))

(defun lsp-semantic-tokens-suggest-overrides ()
  "Suggest face overrides that best match the faces
chosen by `font-lock-fontify-region'."
  (interactive)
  (-when-let* ((token-info (-some #'lsp--semantic-tokens-as-defined-by-workspace lsp--buffer-workspaces))
               ((&plist :token-types token-types :token-modifiers token-modifiers) token-info))
    (let* ((tokens (lsp-request
                    "textDocument/semanticTokens/full"
                    `(:textDocument, (lsp--text-document-identifier))))
           (inhibit-field-text-motion t)
           (data (lsp-get tokens :data))
           (associated-faces '())
           (line-delta)
           ;; KLUDGE: clear cache so our font-lock advice won't apply semantic-token faces
           (old-cache lsp--semantic-tokens-cache)
           (face-or-faces))
      (setq lsp--semantic-tokens-cache nil)
      (save-restriction
        (save-excursion
          (widen)
          (font-lock-fontify-region (point-min) (point-max) t)
          (save-mark-and-excursion
            (save-restriction
              (widen)
              (goto-char (point-min))
              (cl-loop
               for i from 0 to (1- (length data)) by 5 do
               (setq line-delta (aref data i))
               (unless (= line-delta 0) (forward-line line-delta))
               (forward-char (aref data (+ i 1)))
               (setq face-or-faces (get-text-property (point) 'face))
               ;; TODO: consider modifiers?
               (when face-or-faces
                 (--each (if (listp face-or-faces) face-or-faces (list face-or-faces))
                   (cl-pushnew `(,(aref data (+ i 3)) . ,it) associated-faces :test #'equal))))
              (setq lsp--semantic-tokens-cache old-cache)
              (font-lock-flush)))))
      (switch-to-buffer (get-buffer-create "*Suggested Overrides*"))
      (insert "(")
      ;; TODO: sort alternatives by frequency
      (--each-indexed (-group-by #'car associated-faces)
        (insert (if (= it-index 0) "(" "\n ("))
        (insert (format "%s . " (aref token-types (car it))))
        (--each-indexed (mapcar #'cdr (cdr it))
          (insert (if (= it-index 0) (format "%s)" (prin1-to-string it))
                    (format " ; Alternative: %s" (prin1-to-string it))))))
      (insert ")"))))

(declare-function tree-sitter-hl-mode "ext:tree-sitter-hl")

(with-eval-after-load 'tree-sitter-hl
  (add-hook
   'tree-sitter-hl-mode-hook
   (lambda ()
     (when (and lsp-mode lsp--semantic-tokens-teardown
                (boundp 'tree-sitter-hl-mode) tree-sitter-hl-mode)
       (lsp-warn "It seems you have configured tree-sitter-hl to activate after lsp-mode.
To prevent tree-sitter-hl from overriding lsp-mode's semantic token highlighting, lsp-mode
will now disable both semantic highlighting and tree-sitter-hl mode and subsequently re-enable both,
starting with tree-sitter-hl-mode.

Please adapt your config to prevent unnecessary mode reinitialization in the future.")
       (tree-sitter-hl-mode -1)
       (funcall lsp--semantic-tokens-teardown)
       (setq lsp--semantic-tokens-teardown nil)
       (tree-sitter-hl-mode t)
       (lsp--semantic-tokens-initialize-buffer)))))

;;;###autoload
(defun lsp--semantic-tokens-initialize-buffer ()
  "Initialize the buffer for semantic tokens.
IS-RANGE-PROVIDER is non-nil when server supports range requests."
  (let* ((old-extend-region-functions font-lock-extend-region-functions)
         ;; make sure font-lock always fontifies entire lines (TODO: do we also have
         ;; to change some jit-lock-...-region functions/variables?)
         (new-extend-region-functions
          (if (memq 'font-lock-extend-region-wholelines old-extend-region-functions)
              old-extend-region-functions
            (cons 'font-lock-extend-region-wholelines old-extend-region-functions)))
         (buffer (current-buffer)))
    (setq lsp--semantic-tokens-cache nil)
    (setq font-lock-extend-region-functions new-extend-region-functions)
    (add-function :around (local 'font-lock-fontify-region-function) #'lsp-semantic-tokens--fontify)
    (add-hook 'lsp-on-change-hook #'lsp-semantic-tokens--request-update nil t)
    (lsp-semantic-tokens--request-update)
    (setq lsp--semantic-tokens-teardown
          (lambda ()
            (setq lsp--semantic-tokens-pending-full-token-requests
                  (--remove (eq buffer (car it)) lsp--semantic-tokens-pending-full-token-requests))
            (setq font-lock-extend-region-functions old-extend-region-functions)
            (setq lsp--semantic-tokens-cache nil)
            (remove-function (local 'font-lock-fontify-region-function)
                             #'lsp-semantic-tokens--fontify)
            (remove-hook 'lsp-on-change-hook #'lsp-semantic-tokens--request-update t)))))

(defun lsp--semantic-tokens-build-face-map (identifiers faces category varname)
  "Build map of FACES for IDENTIFIERS using CATEGORY and VARNAME."
  (apply 'vector
         (mapcar (lambda (id)
                   (let ((maybe-face (cdr (assoc id faces))))
                     (when (and lsp-semantic-tokens-warn-on-missing-face (not maybe-face))
                       (lsp-warn "No face has been associated to the %s '%s': consider adding a corresponding definition to %s"
                                 category id varname)) maybe-face)) identifiers)))

(defun lsp-semantic-tokens--apply-alist-overrides (base overrides discard-defaults)
  "Merge or replace BASE with OVERRIDES, depending on DISCARD-DEFAULTS.
For keys present in both alists, the assignments made by
OVERRIDES will take precedence."
  (if discard-defaults
      overrides
    (let* ((copy-base (copy-alist base)))
      (mapc (-lambda ((key . value)) (setf (alist-get key copy-base nil nil #'string=) value)) overrides)
      copy-base)))

(defun lsp-semantic-tokens--type-faces-for (client)
  "Return the semantic token type faces for CLIENT."
  (lsp-semantic-tokens--apply-alist-overrides
   lsp-semantic-token-faces
   (plist-get (lsp--client-semantic-tokens-faces-overrides client) :types)
   (plist-get (lsp--client-semantic-tokens-faces-overrides client) :discard-default-types)))

(defun lsp-semantic-tokens--modifier-faces-for (client)
  "Return the semantic token type faces for CLIENT."
  (lsp-semantic-tokens--apply-alist-overrides
   lsp-semantic-token-modifier-faces
   (plist-get (lsp--client-semantic-tokens-faces-overrides client) :modifiers)
   (plist-get (lsp--client-semantic-tokens-faces-overrides client) :discard-default-modifiers)))

(defun lsp--semantic-tokens-on-refresh (workspace)
  "Clear semantic tokens within all buffers of WORKSPACE,
refresh in currently active buffer."
  (cl-assert (not (eq nil workspace)))
  (when lsp-semantic-tokens-honor-refresh-requests
    (cl-loop
     for ws-buffer in (lsp--workspace-buffers workspace) do
     (let ((fontify-immediately (equal (current-buffer) ws-buffer)))
       (with-current-buffer ws-buffer (lsp--semantic-tokens-request nil fontify-immediately))))))

;;;###autoload
(defun lsp--semantic-tokens-initialize-workspace (workspace)
  "Initialize semantic tokens for WORKSPACE."
  (cl-assert workspace)
  (-let (((&plist :token-types types :token-modifiers modifiers)
          (lsp--semantic-tokens-as-defined-by-workspace workspace))
         (client (lsp--workspace-client workspace)))
    (setf (lsp--workspace-semantic-tokens-faces workspace)
          (lsp--semantic-tokens-build-face-map
           types (lsp-semantic-tokens--type-faces-for client)
           "semantic token" "lsp-semantic-token-faces"))
    (setf (lsp--workspace-semantic-tokens-modifier-faces workspace)
          (lsp--semantic-tokens-build-face-map
           modifiers (lsp-semantic-tokens--modifier-faces-for client)
           "semantic token modifier" "lsp-semantic-token-modifier-faces"))))

;;;###autoload
(defun lsp-semantic-tokens--warn-about-deprecated-setting ()
  "Warn about deprecated semantic highlighting variable."
  (when (boundp 'lsp-semantic-highlighting)
    (pcase lsp-semantic-highlighting
      (:semantic-tokens
       (lsp-warn "It seems you wish to use semanticTokens-based
 highlighting. To do so, please remove any references to the
 deprecated variable `lsp-semantic-highlighting' from your
 configuration and set `lsp-semantic-tokens-enable' to `t'
 instead.")
       (setq lsp-semantic-tokens-enable t))
      ((or :immediate :deferred)
       (lsp-warn "It seems you wish to use Theia-based semantic
 highlighting. This protocol has been superseded by the
 semanticTokens protocol specified by LSP v3.16 and is no longer
 supported by lsp-mode. If your language server provides
 semanticToken support, please set
 `lsp-semantic-tokens-enable' to `t' to use it.")))))

;;;###autoload
(defun lsp-semantic-tokens--enable ()
  "Enable semantic tokens mode."
  (when (and lsp-semantic-tokens-enable
             (lsp-feature? "textDocument/semanticTokensFull"))
    (lsp-semantic-tokens--warn-about-deprecated-setting)
    (lsp-semantic-tokens-mode 1)))

(defun lsp-semantic-tokens--disable ()
  "Disable semantic tokens mode."
  (lsp-semantic-tokens-mode -1))

;;;###autoload
(define-minor-mode lsp-semantic-tokens-mode
  "Toggle semantic-tokens support."
  :group 'lsp-semantic-tokens
  :global nil
  (cond
   ((and lsp-semantic-tokens-mode (lsp-feature? "textDocument/semanticTokensFull"))
    (add-hook 'lsp-configure-hook #'lsp-semantic-tokens--enable nil t)
    (add-hook 'lsp-unconfigure-hook #'lsp-semantic-tokens--disable nil t)
    (mapc #'lsp--semantic-tokens-initialize-workspace
          (lsp--find-workspaces-for "textDocument/semanticTokensFull"))
    (lsp--semantic-tokens-initialize-buffer))
   (t
    (remove-hook 'lsp-configure-hook #'lsp-semantic-tokens--enable t)
    (remove-hook 'lsp-unconfigure-hook #'lsp-semantic-tokens--disable t)
    (when lsp--semantic-tokens-teardown
      (funcall lsp--semantic-tokens-teardown))
    (lsp-semantic-tokens--request-update)
    (setq lsp--semantic-tokens-cache nil
          lsp--semantic-tokens-teardown nil))))

;; debugging helpers
(defun lsp--semantic-tokens-verify ()
  "Store current token set and compare with the response to a full token request."
  (interactive)
  (let ((old-tokens (--> lsp--semantic-tokens-cache (plist-get it :response) (lsp-get it :data)))
        (old-version (--> lsp--semantic-tokens-cache (plist-get it :_documentVersion))))
    (if (not (equal lsp--cur-version old-version))
        (message "Stored documentVersion %d differs from current version %d" old-version lsp--cur-version)
      (lsp-request-async
       "textDocument/semanticTokens/full" `(:textDocument ,(lsp--text-document-identifier))
       (lambda (response)
         (let ((new-tokens (lsp-get response :data)))
           (if (equal old-tokens new-tokens)
               (message "New tokens (total count %d) are identical to previously held token set"
                        (length new-tokens))
             (message "Newly returned tokens differ from old token set")
             (print old-tokens)
             (print new-tokens))))
       :mode 'tick
       :cancel-token (format "semantic-tokens-%s" (lsp--buffer-uri))))))

(defvar-local lsp-semantic-tokens--log '())

(defvar-local lsp-semantic-tokens--prev-response nil)

(defun lsp-semantic-tokens--log-buffer-contents (tag)
  "Log buffer contents for TAG."
  (save-restriction
    (save-excursion
      (widen) (push `(:tag ,tag
                      :buffer-contents ,(buffer-substring (point-min) (point-max))
                      :prev-response ,lsp-semantic-tokens--prev-response)
                    lsp-semantic-tokens--log))))

(defun lsp-semantic-tokens-enable-log ()
  "Enable logging of intermediate fontification states.

This is a debugging tool, and may incur significant performance penalties."
  (setq lsp-semantic-tokens--log '())
  (defun lsp-advice-tokens-fontify (orig-func old-fontify-region beg-orig end-orig &optional loudly)
    (lsp-semantic-tokens--log-buffer-contents 'before)
    (let ((result (funcall orig-func old-fontify-region beg-orig end-orig loudly)))
      (lsp-semantic-tokens--log-buffer-contents 'after)
      result))
  (advice-add 'lsp-semantic-tokens--fontify :around 'lsp-advice-tokens-fontify)

  (defun lsp-log-delta-response (response)
    (setq lsp-semantic-tokens--prev-response `(:request-type "delta"
                                               :response ,response
                                               :version ,lsp--cur-version)))
  (advice-add 'lsp--semantic-tokens-ingest-full/delta-response :before 'lsp-log-delta-response)

  (defun lsp-log-full-response (response)
    (setq lsp-semantic-tokens--prev-response `(:request-type "full"
                                                             :response ,response
                                                             :version ,lsp--cur-version)))
  (advice-add 'lsp--semantic-tokens-ingest-full-response :before 'lsp-log-full-response)

  (defun lsp-log-range-response (response)
    (setq lsp-semantic-tokens--prev-response `(:request-type "range"
                                               :response ,response
                                               :version ,lsp--cur-version)))
  (advice-add 'lsp--semantic-tokens-ingest-range-response :before 'lsp-log-range-response))

(defun lsp-semantic-tokens-disable-log ()
  "Disable logging of intermediate fontification states."
  (advice-remove 'lsp-semantic-tokens--fontify 'lsp-advice-tokens-fontify)
  (advice-remove 'lsp--semantic-tokens-ingest-full/delta-response 'lsp-log-delta-response)
  (advice-remove 'lsp--semantic-tokens-ingest-full-response 'lsp-log-full-response)
  (advice-remove 'lsp--semantic-tokens-ingest-range-response 'lsp-log-range-response))

(declare-function htmlize-buffer "ext:htmlize")

(defun lsp-semantic-tokens-export-log ()
  "Write HTML-formatted snapshots of previous fontification results to /tmp."
  (require 'htmlize)
  (let* ((outdir (f-join "/tmp" "semantic-token-snapshots"))
         (progress-reporter
          (make-progress-reporter
           (format "Writing buffer snapshots to %s..." outdir)
           0 (length lsp-semantic-tokens--log))))
    (f-mkdir outdir)
    (--each-indexed (reverse lsp-semantic-tokens--log)
      (-let* (((&plist :tag tag
                       :buffer-contents buffer-contents
                       :prev-response prev-response) it)
              (html-buffer))
        ;; FIXME: doesn't update properly; sit-for helps... somewhat,
        ;; but unreliably
        (when (= (% it-index 5) 0)
          (progress-reporter-update progress-reporter it-index)
          (sit-for 0.01))
        ;; we're emitting 2 snapshots (before & after) per update, so request
        ;; parameters should only change on every 2nd invocation
        (when (cl-evenp it-index)
          (with-temp-buffer
            (insert (prin1-to-string prev-response))
            (write-file (f-join outdir (format "parameters_%d.el" (/ it-index 2))))))
        (with-temp-buffer
          (insert buffer-contents)
          (setq html-buffer (htmlize-buffer))
          (with-current-buffer html-buffer
            ;; some configs such as emacs-doom may autoformat on save; switch to
            ;; fundamental-mode to avoid this
            (fundamental-mode)
            (write-file (f-join outdir (format "buffer_%d_%s.html" (/ it-index 2) tag)))))
        (kill-buffer html-buffer)))
    (progress-reporter-done progress-reporter)))

(lsp-consistency-check lsp-semantic-tokens)

(provide 'lsp-semantic-tokens)
;;; lsp-semantic-tokens.el ends here