Add initial Semantic token

doc.rkt

@@ -9,6 +9,7 @@
          "path-util.rkt"
          "doc-trace.rkt"
          "struct.rkt"
+         "highlight.rkt"
          racket/match
          racket/class
          racket/set
@@ -315,6 +316,44 @@
                                   #:end (Pos #:line line #:char really-indent))
                    #:newText new-text)]))
 
+(define (token-type-encoding token)
+  (index-of *semantic-token-types* (SemanticToken-type token)))
+
+(define (token-modifier-encoding token)
+  (define indexes (indexes-where *semantic-token-modifiers*
+                                 (λ (m) (memq m (SemanticToken-modifiers token)))))
+  (for/sum ([index indexes])
+    (expt 2 index)))
+
+(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))
+  (define delta-line (- line prev-line))
+  (define delta-start
+    (if (= line prev-line)
+        (- ch prev-ch)
+        ch))
+  (define len (- (SemanticToken-end token) (SemanticToken-start token)))
+  (define type (token-type-encoding token))
+  (define modifier (token-modifier-encoding token))
+  (values delta-line delta-start len type modifier))
+
+(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
+    (filter-not (λ (tok) (or (<= (SemanticToken-end tok) pos-start)
+                             (>= (SemanticToken-start tok) pos-end)))
+                tokens))
+  (for/fold ([result '()]
+             [prev-pos 0]
+             #:result (let ()
+                        (flatten (reverse result))))
+            ([token tokens-in-range])
+    (define-values (delta-line delta-start len type modifier)
+      (token-encoding doc token prev-pos))
+    (values (cons (list delta-line delta-start len type modifier) result)
+            (SemanticToken-start token))))
+
 (provide Doc-trace
          new-doc
          doc-checked?
@@ -329,4 +368,6 @@
          doc-find-containing-paren
          doc-get-symbols
          get-definition-by-id
-         format!)
+         format!
+         doc-range-tokens)
+

highlight.rkt

@@ -0,0 +1,157 @@
+#lang racket/base
+
+(require syntax/modread
+         drracket/check-syntax
+         syntax/parse
+         "struct.rkt"
+         racket/class
+         racket/set
+         racket/list
+         racket/bool
+         racket/match)
+
+(provide collect-semantic-tokens)
+
+(define collector%
+  (class (annotations-mixin object%)
+    (define styles '())
+
+    (super-new)
+
+    (define/override (syncheck:find-source-object stx)
+      #f)
+
+    (define/override (syncheck:color-range src start end style)
+      (when (< start end)
+        (set! styles (cons (list start end style) styles))))
+
+    (define/override (syncheck:add-definition-target src start finish id mods)
+      (when (< start finish)
+        (set! styles (cons (list start finish 'definition) styles))))
+
+    (define/public (get-color)
+      (set->list (list->set styles)))))
+
+; (-> lsp-editor% Path (Listof SemanticToken))
+(define (collect-semantic-tokens doc-text path)
+  (define code-str (send doc-text get-text))
+  (define in (open-input-string code-str))
+  (port-count-lines! in)
+  (define-values (path-dir _1 _2) (split-path path))
+
+  (define base-ns (make-base-namespace))
+
+  (define-values (add-syntax done)
+    (make-traversal base-ns #f))
+
+  (define token-list '())
+
+  (define collector (new collector%))
+  (with-handlers ([(λ (_) #t) (λ (_) #f)])
+    (parameterize ([current-load-relative-directory path-dir]
+                   [current-namespace base-ns]
+                   [current-annotations collector])
+      (define stx (with-module-reading-parameterization
+                    (lambda () (read-syntax path in))))
+      (set! token-list (append (walk-stx stx) token-list))
+
+      (define expanded (expand stx))
+      (set! token-list (append (walk-expanded-stx path expanded) token-list))
+      (add-syntax expanded)
+      (done))
+
+    (define drracket-styles (convert-drracket-color-styles (send collector get-color)))
+    (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-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)))]
+         [result-tokens
+          (for*/list ([t tokens-merge-types]
+                      [type (in-value (select-type (third t)))]
+                      [modifiers (in-value (filter (λ (t) (memq t *semantic-token-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)]
+      [_ #f])))
+
+(define (select-type types)
+  (define valid-types (filter (λ (t) (memq t *semantic-token-types*)) types))
+  (cond [(null? valid-types)
+         #f]
+        [(memq 'function valid-types)
+         'function]
+        [(memq 'variable valid-types)
+         'variable]
+        [else (first valid-types)]))
+
+(define (walk-stx stx)
+  (syntax-parse stx
+    #:datum-literals (#%module-begin)
+    [() (list)]
+    [(any1 any* ...)
+     (append (walk-stx #'any1)
+             (walk-stx #'(any* ...)))]
+    [#(any1 any* ...)
+     (append (walk-stx #'any1)
+             (walk-stx #'(any* ...)))]
+    [#%module-begin
+     (list)]
+    [atom (list (stx-typeof #'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)
+             (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 (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))
+
+(define (stx-typeof atom-stx [expect-type #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)))))
+
+(define (get-type atom)
+  (match atom
+    [(? number?) 'number]
+    [(? symbol?) 'symbol]
+    [(? string?) 'string]
+    [(? bytes?) 'string]
+    [(? regexp?) 'regexp]
+    [_ 'unknown]))
+

methods.rkt

@@ -6,6 +6,7 @@
          "error-codes.rkt"
          "msg-io.rkt"
          "responses.rkt"
+         "struct.rkt"
          (prefix-in text-document/ "text-document.rkt"))
 
 ;; TextDocumentSynKind enumeration
@@ -88,6 +89,10 @@
        (text-document/range-formatting! id params)]
       ["textDocument/onTypeFormatting"
        (text-document/on-type-formatting! id params)]
+      ["textDocument/semanticTokens/full"
+       (text-document/full-semantic-tokens id params)]
+      ["textDocument/semanticTokens/range"
+       (text-document/range-semantic-tokens id params)]
       [_
        (eprintf "invalid request for method ~v\n" method)
        (define err (format "The method ~v was not found" method))
@@ -127,6 +132,11 @@
                                     (hash-table ['prepareSupport #t])])])
           (hasheq 'prepareProvider #t)]
          [_ #t]))
+     (define semantic-provider
+       (hasheq 'legend (hasheq 'tokenTypes (map symbol->string *semantic-token-types*)
+                               'tokenModifiers (map symbol->string *semantic-token-modifiers*))
+               'full #t
+               'range #t))
      (define server-capabilities
        (hasheq 'textDocumentSync sync-options
                'hoverProvider #t
@@ -137,6 +147,7 @@
                'signatureHelpProvider (hasheq 'triggerCharacters (list " " ")" "]"))
                'inlayHintProvider #t
                'renameProvider renameProvider
+               'semanticTokensProvider semantic-provider
                'documentHighlightProvider #t
                'documentSymbolProvider #t
                'documentFormattingProvider #t

struct.rkt

@@ -129,6 +129,20 @@
                             #:trim-final-newlines (hash-ref jsexpr 'trimFinalNewlines undef-object)
                             #:key (hash-ref jsexpr 'key undef-object))))
 
+(struct SemanticToken
+  (start end type modifiers)
+  #:transparent)
+
+(define *semantic-token-types*
+  '(variable
+     function
+     string
+     number
+     regexp))
+
+(define *semantic-token-modifiers*
+  '(definition))
+
 ;; usage:
 ;; (jsexpr? jsexpr) ;; #t
 ;; (match jsexpr
@@ -147,4 +161,7 @@
 (provide FormattingOptions
          FormattingOptions-tab-size
          FormattingOptions-trim-trailing-whitespace
-         as-FormattingOptions)
+         as-FormattingOptions
+         (struct-out SemanticToken)
+         *semantic-token-types*
+         *semantic-token-modifiers*)

tests/lifecycle/init_resp.json

@@ -25,6 +25,22 @@
             "inlayHintProvider": true,
             "referencesProvider": true,
             "renameProvider": true,
+            "semanticTokensProvider": {
+                "full": true,
+                "range": true,
+                "legend": {
+                    "tokenModifiers": [
+                        "definition"
+                    ],
+                    "tokenTypes": [
+                        "variable",
+                        "function",
+                        "string",
+                        "number",
+                        "regexp"
+                    ]
+                }
+            },
             "signatureHelpProvider": {
                 "triggerCharacters": [
                     " ",
@@ -40,4 +56,4 @@
             }
         }
     }
-}
+}

text-document.rkt

@@ -478,6 +478,24 @@
     [_
      (error-response id INVALID-PARAMS "textDocument/onTypeFormatting failed")]))
 
+(define (full-semantic-tokens id params)
+  (match params
+    [(hash-table ['textDocument (DocIdentifier #:uri uri)])
+     (define this-doc (hash-ref open-docs (string->symbol uri)))
+     (success-response id (hash 'data (doc-range-tokens this-doc uri 0 (doc-endpos this-doc))))]
+    [_ (error-response id INVALID-PARAMS "textDocument/semanticTokens/full failed")]))
+
+(define (range-semantic-tokens id params)
+  (match params
+    [(hash-table ['textDocument (DocIdentifier #:uri uri)]
+                 ['range (Range #:start (Pos #:line st-ln #:char st-ch)
+                           #:end (Pos #:line ed-ln #:char ed-ch))])
+     (define this-doc (hash-ref open-docs (string->symbol uri)))
+     (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")]))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (provide
@@ -498,4 +516,7 @@
   [prepareRename (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)]
   [formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)]
   [range-formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)]
-  [on-type-formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)]))
+  [on-type-formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)]
+  [full-semantic-tokens (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)]
+  [range-semantic-tokens (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)]))
+