style: improve code, add some comment

doc.rkt

@@ -322,9 +322,33 @@
 (define (token-modifier-encoding token)
   (define indexes (indexes-where *semantic-token-modifiers*
                                  (λ (m) (memq m (SemanticToken-modifiers token)))))
+  ;; build a bit flag of the modifiers of `token`.
+  ;;
+  ;; equivalent to C family pseudocode
+  ;;
+  ;; uint32_t flag = 0
+  ;; for index in indexes:
+  ;;   flag = flag | (1 << index)
+  ;; return flag
+  ;;
+  ;; But the integer bit width is ignored here, because
+  ;; the *semantic-token-modifiers* is very small.
   (for/sum ([index indexes])
     (expt 2 index)))
 
+;; encode `token` using relative encoding
+;;
+;; each token is encoded as five integers (copied from lsp specificatioin 3.17):
+;; * deltaLine: token line number, relative to the start of the previous token
+;; * deltaStart: token start character, relative to the start of the previous token 
+;;               (relative to 0 or the previous token’s start if they are on the same line)
+;; * length: the length of the token.
+;; * tokenType: will be looked up in SemanticTokensLegend.tokenTypes.
+;;              We currently ask that tokenType < 65536.
+;; * tokenModifiers: each set bit will be looked up in SemanticTokensLegend.tokenModifiers
+;;
+;; for the first token, its previous token is defined as a zero length fake token which
+;; has line number 0 and character position 0.
 (define (token-encoding doc token prev-pos)
   (define-values (line ch) (doc-line/ch doc (SemanticToken-start token)))
   (define-values (prev-line prev-ch) (doc-line/ch doc prev-pos))
@@ -338,6 +362,10 @@
   (define modifier (token-modifier-encoding token))
   (values delta-line delta-start len type modifier))
 
+;; get the tokens whose range are contained in interval [pos-start, pos-end)
+;; the tokens whose range intersects the given range is included.
+;; the previous token of the first token in the result is defined as a zero length fake token which
+;; has line number 0 and character position 0.
 (define (doc-range-tokens doc path pos-start pos-end)
   (define tokens (collect-semantic-tokens (Doc-text doc) (uri->path path)))
   (define tokens-in-range
@@ -346,8 +374,7 @@
                 tokens))
   (for/fold ([result '()]
              [prev-pos 0]
-             #:result (let ()
-                        (flatten (reverse result))))
+             #:result (flatten (reverse result)))
             ([token tokens-in-range])
     (define-values (delta-line delta-start len type modifier)
       (token-encoding doc token prev-pos))

highlight.rkt

@@ -12,6 +12,13 @@
 
 (provide collect-semantic-tokens)
 
+;; A temporary structure to hold tokens
+;; `tag` is symbol that is a tag associated with this token.
+;; An identifier may correspond multiple tokens. They will be merged, then converted into
+;; lsp semantic token types and modifiers.
+(struct Token
+  (start end tag))
+
 (define collector%
   (class (annotations-mixin object%)
     (define styles '())
@@ -23,13 +30,13 @@
 
     (define/override (syncheck:color-range src start end style)
       (when (< start end)
-        (set! styles (cons (list start end style) styles))))
+        (set! styles (cons (Token start end (string->symbol style)) styles))))
 
     (define/override (syncheck:add-definition-target src start finish id mods)
       (when (< start finish)
-        (set! styles (cons (list start finish 'definition) styles))))
+        (set! styles (cons (Token start finish 'definition) styles))))
 
-    (define/public (get-color)
+    (define/public (get-styles)
       (set->list (list->set styles)))))
 
 ; (-> lsp-editor% Path (Listof SemanticToken))
@@ -60,36 +67,37 @@
       (add-syntax expanded)
       (done))
 
-    (define drracket-styles (convert-drracket-color-styles (send collector get-color)))
+    (define drracket-styles (convert-drracket-color-styles (send collector get-styles)))
     (set! token-list (append drracket-styles token-list)))
 
   (let* ([tokens-no-false (filter-not false? token-list)]
-         [tokens-no-out-bounds (filter (λ (t) (< -1 (first t) (string-length code-str)))
+         [tokens-no-out-bounds (filter (λ (t) (< -1 (Token-start t) (string-length code-str)))
                                        tokens-no-false)]
-         [tokens-in-order (sort tokens-no-out-bounds < #:key first)]
-         [same-loc-token-groups (group-by first tokens-in-order)]
-         [tokens-merge-types
-          (for/list ([group same-loc-token-groups])
-            (define fst (first group))
-            (list (first fst) (second fst) (map third group)))]
+         [tokens-in-order (sort tokens-no-out-bounds < #:key Token-start)]
+         [same-ident-token-groups (group-by Token-start tokens-in-order)]
+         [tokens-with-merged-tags
+          (for/list ([token-group same-ident-token-groups])
+            (define tok (first token-group))
+            (list (Token-start tok) (Token-end tok) (map Token-tag token-group)))]
          [result-tokens
-          (for*/list ([t tokens-merge-types]
+          (for*/list ([t tokens-with-merged-tags]
                       [type (in-value (select-type (third t)))]
-                      [modifiers (in-value (filter (λ (t) (memq t *semantic-token-modifiers*))
-                                                   (third t)))]
+                      [modifiers (in-value (get-valid-modifiers (third t)))]
                       #:when (not (false? type)))
             (SemanticToken (first t) (second t) type modifiers))])
     result-tokens))
 
 (define (convert-drracket-color-styles styles)
   (for/list ([s styles])
     (match s
-      [(list start end "drracket:check-syntax:lexically-bound")
-       (list start end 'variable)]
+      [(Token start end 'drracket:check-syntax:lexically-bound)
+       (Token start end 'variable)]
       [_ #f])))
 
-(define (select-type types)
-  (define valid-types (filter (λ (t) (memq t *semantic-token-types*)) types))
+;; `tags` might contains multiple valid types.
+;; This function selects a proper type based on some rules.
+(define (select-type tags)
+  (define valid-types (filter (λ (t) (memq t *semantic-token-types*)) tags))
   (cond [(null? valid-types)
          #f]
         [(memq 'function valid-types)
@@ -98,6 +106,9 @@
          'variable]
         [else (first valid-types)]))
 
+(define (get-valid-modifiers tags)
+  (filter (λ (t) (memq t *semantic-token-modifiers*)) tags))
+
 (define (walk-stx stx)
   (syntax-parse stx
     #:datum-literals (#%module-begin)
@@ -110,43 +121,43 @@
              (walk-stx #'(any* ...)))]
     [#%module-begin
      (list)]
-    [atom (list (stx-typeof #'atom))]))
+    [atom (list (tag-of-atom-stx #'atom))]))
 
 (define (walk-expanded-stx src stx)
   (syntax-parse stx
     #:datum-literals (lambda define-values)
     [(lambda (args ...) expr ...)
      (walk-expanded-stx src #'(expr ...))]
     [(define-values (fs) (lambda _ ...))
-     (append (stx-lst-typeof src #'(fs) 'function)
+     (append (tags-of-stx-lst src #'(fs) 'function)
              (walk-expanded-stx src (drop (syntax-e stx) 2)))]
     [(any1 any* ...)
      (append (walk-expanded-stx src #'any1)
              (walk-expanded-stx src #'(any* ...)))]
     [_ (list)]))
 
-(define (stx-lst-typeof src stx-lst type)
+(define (tags-of-stx-lst src stx-lst tag)
   (define (in-current-file? stx)
     (equal? src (syntax-source stx)))
 
   (let* ([stx-lst (syntax-e stx-lst)]
          [stx-lst-in-current-file (filter in-current-file? stx-lst)]
-         [type-lst (map (λ (stx) (stx-typeof stx type)) stx-lst-in-current-file)])
-    type-lst))
+         [tag-lst (map (λ (stx) (tag-of-atom-stx stx tag)) stx-lst-in-current-file)])
+    tag-lst))
 
-(define (stx-typeof atom-stx [expect-type #f])
+(define (tag-of-atom-stx atom-stx [expect-tag #f])
   (define pos+1 (syntax-position atom-stx))
   (define len (syntax-span atom-stx))
   (if (or (not pos+1) (not len) (= len 0)
           (not (syntax-original? atom-stx)))
       #f
       (let ([pos (sub1 pos+1)])
-        (list pos (+ pos len)
-              (if (false? expect-type)
-                  (get-type (syntax-e atom-stx))
-                  expect-type)))))
+        (Token pos (+ pos len)
+               (if (false? expect-tag)
+                   (get-atom-tag (syntax-e atom-stx))
+                   expect-tag)))))
 
-(define (get-type atom)
+(define (get-atom-tag atom)
   (match atom
     [(? number?) 'number]
     [(? symbol?) 'symbol]

struct.rkt

@@ -133,13 +133,20 @@
   (start end type modifiers)
   #:transparent)
 
+;; The order of this list is irrelevant.
+;; The client receives this list from server ability declaration during
+;; initialize handshake then use it to decode server semantic tokens messages.
+;; Different order produces different encoding results of semantic tokens,
+;; but does not affect client and server behavior.
+;; To change the order, simply change it here, don't need to change other code.
 (define *semantic-token-types*
   '(variable
      function
      string
      number
      regexp))
 
+;; The order of this list is irrelevant, similar to *semantic-token-types*.
 (define *semantic-token-modifiers*
   '(definition))
 

tests/lifecycle/init_resp.json

@@ -27,19 +27,7 @@
             "renameProvider": true,
             "semanticTokensProvider": {
                 "full": true,
-                "range": true,
-                "legend": {
-                    "tokenModifiers": [
-                        "definition"
-                    ],
-                    "tokenTypes": [
-                        "variable",
-                        "function",
-                        "string",
-                        "number",
-                        "regexp"
-                    ]
-                }
+                "range": true
             },
             "signatureHelpProvider": {
                 "triggerCharacters": [

tests/lifecycle/test-main.rkt

@@ -2,7 +2,9 @@
 (require chk
          json
          racket/os
-         "../../msg-io.rkt")
+         "../../msg-io.rkt"
+         "../../json-util.rkt"
+         "../../struct.rkt")
 
 (define init-req
   (hasheq 'jsonrpc "2.0"
@@ -35,7 +37,11 @@
   ;; Initialize request
   (display-message/flush init-req stdin)
   (let ([resp (read-message stdout)])
-    (chk #:= resp (read-json (open-input-file "init_resp.json"))))
+    (define expected-json (read-json (open-input-file "init_resp.json")))
+    (define json (jsexpr-set expected-json '(result capabilities semanticTokensProvider legend)
+                             (hasheq 'tokenModifiers (map symbol->string *semantic-token-modifiers*)
+                                     'tokenTypes (map symbol->string *semantic-token-types*))))
+    (chk #:= resp json))
 
   ;; Shutdown request
   (display-message/flush shutdown-req stdin)
@@ -49,3 +55,4 @@
   (subprocess-wait sp)
   (define st (subprocess-status sp))
   (chk (zero? st)))
+

text-document.rkt

@@ -494,7 +494,7 @@
      (define start-pos (doc-pos this-doc st-ln st-ch))
      (define end-pos (doc-pos this-doc ed-ln ed-ch))
      (success-response id (hash 'data (doc-range-tokens this-doc uri start-pos end-pos)))]
-    [_ (error-response id INVALID-PARAMS "textDocument/semanticTokens/full failed")]))
+    [_ (error-response id INVALID-PARAMS "textDocument/semanticTokens/range failed")]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;