Add semantic tokens to server capabilities response

resources/coalton-lsp-user.lisp

@@ -0,0 +1,24 @@
+;;;; helpers for interactive development: starting network server,
+;;;; changing logging options
+
+(defpackage #:coalton-lsp-user
+  (:use #:cl
+        #:coalton-lsp))
+
+(in-package #:coalton-lsp-user)
+
+(defun restart-server ()
+  (when *server*
+    (stop-server))
+  (start-server *server-port*))
+
+;;; (restart-server)
+
+(defun enable-debugging ()
+  (set-log-level :debug))
+
+(defun enable-worker-debugging ()
+  (setf coalton-lsp::*worker-debug* t))
+
+(defun enable-file-logger ()
+  (set-log-file "~/git/coalton-mode/rpc.log"))

src/lib/log.lisp

@@ -38,6 +38,8 @@
           :reader log-level)
    (lock :initform (bt:make-lock))))
 
+(defmethod stop ((self stream-logger)))
+
 (defvar *levels*
   '(:trace :debug :info :warn :error))
 
@@ -59,7 +61,8 @@
         (write-string " : " stream)
         (%write-context stream)
         (apply #'format stream format format-args)
-        (terpri stream)))))
+        (terpri stream)
+        (force-output stream)))))
 
 (defparameter *logger*
   (make-instance 'stream-logger :stream t :level ':info))
@@ -71,6 +74,24 @@
 (defun set-log-level (level)
   (setf (slot-value *logger* 'level) level))
 
+(defclass file-logger (stream-logger)
+  ())
+
+(defmethod stop ((self file-logger))
+  (close (slot-value self 'stream)))
+
+(defun set-log-file (filename)
+  (when *logger*
+    (stop *logger*))
+  (let ((stream (open filename
+                      :direction ':output
+                      :if-exists ':append
+                      :if-does-not-exist ':create
+                      :element-type 'character)))
+    (setf *logger* (make-instance 'file-logger
+                     :stream stream
+                     :level ':debug))))
+
 (defun /trace-p ()
   (log-p *logger* ':trace))
 

src/lib/process.lisp

@@ -73,20 +73,21 @@
   (loop :while (and (run-p worker)
                     (not (empty-p worker)))
         :do (let ((element (dequeue worker)))
-              (/debug "about to process one entry")
-              (handler-case
-                  (funcall (slot-value worker 'fn) element)
-                (condition (condition)
-                  (when *worker-debug*
-                    (signal condition))
-                  (/error "ignoring error : ~a" condition))))))
+              (/trace "service-queue: process ~a" element)
+              (cond (*worker-debug*
+                     (funcall (slot-value worker 'fn) element))
+                    (t
+                     (handler-case
+                         (funcall (slot-value worker 'fn) element)
+                       (condition (condition)
+                         (/error "ignoring error : ~a" condition))))))))
 
 (defmethod run ((self worker))
   (with-logging-context (:worker (lambda (stream)
                                    (write-string "worker" stream)))
-    (/debug "starting")
+    (/trace "starting")
     (unwind-protect
          (loop :while (run-p self)
                :do (service-queue self)
                    (sleep *worker-poll-interval*))
-      (/debug "stopping"))))
+      (/trace "stopping"))))

src/package.lisp

@@ -2,6 +2,9 @@
   (:documentation "An LSP server for the Coalton language")
   (:use #:cl)
   (:export #:main
-           #:start
-           #:stop
-           #:restart))
+           #:*server*
+           #:*server-port*
+           #:set-log-level
+           #:set-log-file
+           #:start-server
+           #:stop-server))

src/protocol.lisp

@@ -388,6 +388,43 @@
   (:resolve-provider (boolean :optional t))
   (:completion-item (completion-item-options :optional t)))
 
+(define-message document-filter ()
+  (:language (string :optional t))
+  (:scheme (string :optional t))
+  (:pattern (string :optional t)))
+
+(define-message text-document-registration-options ()
+  (:document-selector (document-filter :vector t :optional t)))
+
+(define-message empty ())
+
+(define-message delta ()
+  (:delta (boolean :optional t)))
+
+(define-union range-option (boolean empty))
+
+(define-union full-option (boolean delta))
+
+(define-message semantic-tokens-legend ()
+  (:token-types (string :vector t))
+  (:token-modifiers (string :vector t)))
+
+(define-message semantic-tokens-options (work-done-progress-options)
+  (:legend semantic-tokens-legend)
+  (:range (range-option :optional t))
+  (:full (full-option :optional t)))
+
+(define-message static-registration-options ()
+  (:id (string :optional t)))
+
+(define-message semantic-tokens-registration-options
+    (text-document-registration-options
+     semantic-tokens-options
+     static-registration-options))
+
+(define-union document-symbol-provider-options
+  (boolean document-symbol-options))
+
 (define-message server-capabilities ()
   (:position-encoding (position-encoding-kind :optional t))
   (:text-document-sync (text-document-sync-options :optional t))
@@ -401,7 +438,7 @@
   #++ (:implementation-provider (or boolean implementation-options implementation-registration-options))
   #++ (:references-provider (or boolean reference-options))
   #++ (:document-highlight-provider (or boolean document-highlight-options))
-  (:document-symbol-provider (document-symbol-options :optional t))
+  (:document-symbol-provider (document-symbol-provider-options :optional t))
   #++ (:code-action-provider (or boolean code-action-options))
   #++ (:code-lens-provider (code-lens-options :optional t))
   (:document-link-provider (document-link-options :optional t))
@@ -415,7 +452,7 @@
   #++ (:selection-range-provider (or boolean selection-range-options selection-range-registration-options))
   #++ (:linked-editing-range-provider (or boolean linked-editing-range-options linked-editing-range-registration-options))
   #++ (:call-hierarchy-provider (or boolean call-hierarchy-options call-hierarchy-registration-options))
-  #++ (:semantic-tokens-provider (or semantic-tokens-options semantic-tokens-registration-options))
+  (:semantic-tokens-provider semantic-tokens-registration-options)
   #++ (:moniker-provider (or boolean moniker-options moniker-registration-options))
   #++ (:type-hierarchy-provider (or boolean type-hierarchy-options type-hierarchy-registration-options))
   #++ (:inline-value-provider (or boolean inline-value-options inline-value-registration-options))
@@ -437,6 +474,14 @@
     (set-field result (list :capabilities :text-document-sync :change) :full)
     (set-field result (list :capabilities :definition-provider :work-done-progress) t)
     (set-field result (list :capabilities :document-formatting-provider :work-done-progress) t)
+    (set-field result (list :capabilities :document-symbol-provider) t)
+    (set-field result (list :capabilities :semantic-tokens-provider :legend :token-types)
+               '("namespace" "type" "function" "macro" "keyword" "class" "variable" "method"
+                 "event" "interface"))
+    (set-field result (list :capabilities :semantic-tokens-provider :legend :token-modifiers)
+               '("definition" "defaultLibrary" "implementation"))
+    (set-field result (list :capabilities :semantic-tokens-provider :range) t)
+    (set-field result (list :capabilities :semantic-tokens-provider :full) t)
     (set-field result (list :capabilities :position-encoding)
                (position-encoding session))
     result))
@@ -445,6 +490,15 @@
   initialize-params
   handle-initialize)
 
+(defun handle-shutdown (session params)
+  (declare (ignore params))
+  (shutdown-session session)
+  (make-message 'empty))
+
+(define-handler "shutdown"
+  empty
+  handle-shutdown)
+
 (define-message initialized-params ())
 
 (defun handle-initialized (session params)

src/server.lisp

@@ -72,7 +72,7 @@
         (stop session))))
   (call-next-method))
 
-(defvar *default-port* 7887
+(defvar *server-port* 7887
   "The default port of LSP sessions.")
 
 (defvar *server* nil
@@ -87,7 +87,7 @@
   (setf *server* nil)
   (/info "server halted"))
 
-(defun start-server (&optional (port *default-port*))
+(defun start-server (&optional (port *server-port*))
   "Run a Coalton LSP server on PORT."
   (when *server*
     (/info "halting server at tcp:~a" (server-address *server*))
@@ -98,7 +98,7 @@
                                :host "127.0.0.1"))))
   (/info "server started at tcp:~a" (server-address *server*)))
 
-(defun main (&key (port *default-port*))
+(defun main (&key (port *server-port*))
   "Run a Coalton LSP server on PORT, halting on interrupt."
   (start-server port)
   (handler-case

src/session.lisp

@@ -24,14 +24,14 @@
 
 (defun submit-event (session method value)
   (with-session-context (session)
-    (/debug "submit-event ~a ~a" method value)
+    (/trace "submit-event ~a ~a" method value)
     (with-slots (event-queue) session
       (enqueue event-queue (cons method value)))))
 
 (defun process-event (session event)
   (with-session-context (session)
     (destructuring-bind (method . value) event
-      (/debug "process-event ~a" method)
+      (/trace "process-event ~a" method)
       (funcall method session value))))
 
 (defun session-uri (session)
@@ -49,6 +49,9 @@
   (setf (session-state session) 'initializing)
   (setf (session-params session) params))
 
+(defun shutdown-session (session)
+  (setf (session-state session) 'shutting-down))
+
 (defun initialized-session (session)
   (with-session-context (session)
     (setf (session-state session) 'initialized)
@@ -262,9 +265,11 @@
 
 (defun process-request (session request)
   (handler-case
-      (let* ((handler (get-message-handler (request-method request)))
+      (let* ((method (request-method request))
+             (handler (get-message-handler method))
              (params (request-params request))
              (result (funcall (message-handler-fn handler) session params)))
+        (/debug "processing request: '~a'" method)
         (make-response (get-field request :id) result))
     (lsp-error (condition)
       (make-error-response (get-field request :id) condition))))

tests/session-tests.lisp

@@ -5,13 +5,43 @@
     (is (equalp (lsp::message-value
                  (lsp::process-request
                   session (lsp::make-request (rpc-example "initialize.json"))))
-        '(("result"
-           ("capabilities" ("positionEncoding" . "utf-16")
-            ("documentFormattingProvider" ("workDoneProgress" . T))
-            ("definitionProvider" ("workDoneProgress" . T))
-            ("textDocumentSync" ("change" . 1) ("openClose" . T)))
-           ("serverInfo" ("name" . "Coalton")))
-          ("id" . 1) ("jsonrpc" . "2.0"))))))
+                '(("result"
+                   ("capabilities"
+                    ("positionEncoding"
+                     . "utf-16")
+                    ("semanticTokensProvider"
+                     ("full" . T)
+                     ("range" . T)
+                     ("legend"
+                      ("tokenModifiers"
+                       "definition"
+                       "defaultLibrary"
+                       "implementation")
+                      ("tokenTypes"
+                       "namespace"
+                       "type"
+                       "function"
+                       "macro"
+                       "keyword"
+                       "class"
+                       "variable"
+                       "method"
+                       "event"
+                       "interface")))
+                    ("documentSymbolProvider"
+                     . T)
+                    ("documentFormattingProvider"
+                     ("workDoneProgress"
+                      . T))
+                    ("definitionProvider"
+                     ("workDoneProgress"
+                      . T))
+                    ("textDocumentSync"
+                     ("change" . 1)
+                     ("openClose"
+                      . T)))
+                   ("serverInfo" ("name" . "Coalton")))
+                  ("id" . 1) ("jsonrpc" . "2.0"))))))
 
 (deftest session-tests/get-field ()
   (let ((init (lsp::make-request (rpc-example "initialize.json"))))
@@ -46,8 +76,32 @@
       \"definitionProvider\": {
         \"workDoneProgress\": true
       },
+      \"documentSymbolProvider\": true,
       \"documentFormattingProvider\": {
         \"workDoneProgress\": true
+      },
+      \"semanticTokensProvider\": {
+        \"legend\": {
+          \"tokenTypes\": [
+            \"namespace\",
+            \"type\",
+            \"function\",
+            \"macro\",
+            \"keyword\",
+            \"class\",
+            \"variable\",
+            \"method\",
+            \"event\",
+            \"interface\"
+          ],
+          \"tokenModifiers\": [
+            \"definition\",
+            \"defaultLibrary\",
+            \"implementation\"
+          ]
+        },
+        \"range\": true,
+        \"full\": true
       }
     },
     \"serverInfo\": {