Semantic tokens support

lsp-test/src/Language/LSP/Test.hs

@@ -92,11 +92,14 @@ module Language.LSP.Test
   , applyEdit
   -- ** Code lenses
   , getCodeLenses
-  -- ** Capabilities
-  , getRegisteredCapabilities
+  -- ** Call hierarchy
   , prepareCallHierarchy
   , incomingCalls
   , outgoingCalls
+  -- ** SemanticTokens
+  , getSemanticTokens
+  -- ** Capabilities
+  , getRegisteredCapabilities
   ) where
 
 import Control.Applicative.Combinators
@@ -606,7 +609,7 @@ applyEdit doc edit = do
 
   let supportsDocChanges = fromMaybe False $ do
         let mWorkspace = caps ^. LSP.workspace
-        C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
+        C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ _ <- mWorkspace
         C.WorkspaceEditClientCapabilities mDocChanges _ _ _ _ <- mEdit
         mDocChanges
 
@@ -743,13 +746,6 @@ getCodeLenses tId = do
     case getResponseResult rsp of
         List res -> pure res
 
--- | Returns a list of capabilities that the server has requested to /dynamically/
--- register during the 'Session'.
---
--- @since 0.11.0.0
-getRegisteredCapabilities :: Session [SomeRegistration]
-getRegisteredCapabilities = Map.elems . curDynCaps <$> get
-
 -- | Pass a param and return the response from `prepareCallHierarchy`
 prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem]
 prepareCallHierarchy = resolveRequestWithListResp STextDocumentPrepareCallHierarchy
@@ -768,3 +764,17 @@ resolveRequestWithListResp method params = do
   case getResponseResult rsp of
     Nothing -> pure []
     Just (List x) -> pure x
+
+-- | Pass a param and return the response from `prepareCallHierarchy`
+getSemanticTokens :: TextDocumentIdentifier -> Session (Maybe SemanticTokens)
+getSemanticTokens doc = do
+  let params = SemanticTokensParams Nothing Nothing doc
+  rsp <- request STextDocumentSemanticTokensFull params
+  pure $ getResponseResult rsp 
+
+-- | Returns a list of capabilities that the server has requested to /dynamically/
+-- register during the 'Session'.
+--
+-- @since 0.11.0.0
+getRegisteredCapabilities :: Session [SomeRegistration]
+getRegisteredCapabilities = Map.elems . curDynCaps <$> get

lsp-test/test/DummyServer.hs

@@ -16,6 +16,7 @@ import System.Directory
 import System.FilePath
 import System.Process
 import Language.LSP.Types
+import Data.Default
 
 withDummyServer :: ((Handle, Handle) -> IO ()) -> IO ()
 withDummyServer f = do
@@ -212,4 +213,9 @@ handlers =
             CallHierarchyOutgoingCallsParams _ _ item = params
         resp $ Right $ Just $
           List [CallHierarchyOutgoingCall item (List [Range (Position 4 5) (Position 2 3)])]
+     , requestHandler STextDocumentSemanticTokensFull $ \_req resp -> do
+        let tokens = makeSemanticTokens def [SemanticTokenAbsolute 0 1 2 SttType []]
+        case tokens of
+          Left t -> resp $ Left $ ResponseError InternalError t Nothing
+          Right tokens -> resp $ Right $ Just tokens
     ]

lsp-test/test/Test.hs

@@ -394,6 +394,11 @@ main = hspec $ around withDummyServer $ do
       [CallHierarchyOutgoingCall _ (List fromRanges)] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item)
       liftIO $ head fromRanges `shouldBe` Range (Position 4 5) (Position 2 3)
 
+  describe "semantic tokens" $ do
+    it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
+      let doc = TextDocumentIdentifier (Uri "")
+      Just toks <- getSemanticTokens doc
+      liftIO $ toks ^. xdata `shouldBe` List [0,1,2,0,0]
 
 didChangeCaps :: ClientCapabilities
 didChangeCaps = def { _workspace = Just workspaceCaps }

lsp-types/lsp-types.cabal

@@ -56,6 +56,7 @@ library
                      , Language.LSP.Types.Rename
                      , Language.LSP.Types.SelectionRange
                      , Language.LSP.Types.ServerCapabilities
+                     , Language.LSP.Types.SemanticTokens
                      , Language.LSP.Types.SignatureHelp
                      , Language.LSP.Types.StaticRegistrationOptions
                      , Language.LSP.Types.TextDocument
@@ -76,17 +77,19 @@ library
                      , containers
                      , data-default
                      , deepseq
+                     , Diff
                      , directory
+                     , dlist
                      , filepath
                      , hashable
                      , hslogger
                      , lens >= 4.15.2
+                     , mtl
                      , network-uri
                      , rope-utf16-splay >= 0.3.1.0
                      , scientific
                      , some
                      , dependent-sum-template
-                     , dependent-sum >= 0.6.2.2
                      , text
                      , template-haskell
                      , temporary

lsp-types/src/Language/LSP/Types.hs

@@ -33,6 +33,7 @@ module Language.LSP.Types
   , module Language.LSP.Types.SignatureHelp
   , module Language.LSP.Types.StaticRegistrationOptions
   , module Language.LSP.Types.SelectionRange
+  , module Language.LSP.Types.SemanticTokens
   , module Language.LSP.Types.TextDocument
   , module Language.LSP.Types.TypeDefinition
   , module Language.LSP.Types.Uri
@@ -76,6 +77,7 @@ import           Language.LSP.Types.References
 import           Language.LSP.Types.Registration
 import           Language.LSP.Types.Rename
 import           Language.LSP.Types.SelectionRange
+import           Language.LSP.Types.SemanticTokens
 import           Language.LSP.Types.SignatureHelp
 import           Language.LSP.Types.StaticRegistrationOptions
 import           Language.LSP.Types.TextDocument

lsp-types/src/Language/LSP/Types/Capabilities.hs

@@ -51,6 +51,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Jus
           (Just (ExecuteCommandClientCapabilities dynamicReg))
           (since 3 6 True)
           (since 3 6 True)
+          (since 3 16 (SemanticTokensWorkspaceClientCapabilities $ Just True))
 
     resourceOperations = List
       [ ResourceOperationCreate
@@ -103,6 +104,20 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Jus
              , SkTypeParameter
              ]
 
+    -- Only one token format for now, just list it here
+    tfs = List [ TokenFormatRelative ]
+
+    semanticTokensCapabilities = SemanticTokensClientCapabilities
+      (Just True)
+      (SemanticTokensRequestsClientCapabilities
+       (Just $ SemanticTokensRangeBool True)
+       (Just (SemanticTokensFullDelta (SemanticTokensDeltaClientCapabilities $ Just True))))
+      (List knownSemanticTokenTypes)
+      (List knownSemanticTokenModifiers)
+      tfs
+      (Just True)
+      (Just True)
+
     td = TextDocumentClientCapabilities
           (Just sync)
           (Just completionCapability)
@@ -127,6 +142,8 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Jus
           (since 3 10 foldingRangeCapability)
           (since 3 5 (SelectionRangeClientCapabilities dynamicReg))
           (since 3 16 (CallHierarchyClientCapabilities dynamicReg))
+          (since 3 16 semanticTokensCapabilities)
+
     sync =
       TextDocumentSyncClientCapabilities
         dynamicReg

lsp-types/src/Language/LSP/Types/ClientCapabilities.hs

@@ -26,6 +26,7 @@ import Language.LSP.Types.Implementation
 import Language.LSP.Types.References
 import Language.LSP.Types.Rename
 import Language.LSP.Types.SelectionRange
+import Language.LSP.Types.SemanticTokens
 import Language.LSP.Types.SignatureHelp
 import Language.LSP.Types.TextDocument
 import Language.LSP.Types.TypeDefinition
@@ -61,12 +62,18 @@ data WorkspaceClientCapabilities =
 
       -- | The client supports `workspace/configuration` requests.
     , _configuration :: Maybe Bool
+
+      -- | Capabilities specific to the semantic token requests scoped to the
+      -- workspace.
+      --
+      -- @since 3.16.0
+    , _semanticTokens :: Maybe SemanticTokensWorkspaceClientCapabilities
     } deriving (Show, Read, Eq)
 
 deriveJSON lspOptions ''WorkspaceClientCapabilities
 
 instance Default WorkspaceClientCapabilities where
-  def = WorkspaceClientCapabilities def def def def def def def def
+  def = WorkspaceClientCapabilities def def def def def def def def def
 
 -- -------------------------------------
 
@@ -147,14 +154,19 @@ data TextDocumentClientCapabilities =
       -- | Call hierarchy specific to the `textDocument/prepareCallHierarchy` request.
       -- Since LSP 3.16.0
     , _callHierarchy :: Maybe CallHierarchyClientCapabilities
+
+    -- | Capabilities specific to the various semantic token requests.
+    --
+    -- @since 3.16.0
+    , _semanticTokens :: Maybe SemanticTokensClientCapabilities
     } deriving (Show, Read, Eq)
 
 deriveJSON lspOptions ''TextDocumentClientCapabilities
 
 instance Default TextDocumentClientCapabilities where
   def = TextDocumentClientCapabilities def def def def def def def def
                                        def def def def def def def def
-                                       def def def def def def def
+                                       def def def def def def def def
 
 -- ---------------------------------------------------------------------
 

lsp-types/src/Language/LSP/Types/Lens.hs

@@ -51,6 +51,7 @@ import           Language.LSP.Types.WorkspaceEdit
 import           Language.LSP.Types.WorkspaceFolders
 import           Language.LSP.Types.WorkspaceSymbol
 import           Language.LSP.Types.Message
+import           Language.LSP.Types.SemanticTokens
 import           Control.Lens.TH
 
 -- TODO: This is out of date and very unmantainable, use TH to call all these!!
@@ -366,3 +367,15 @@ makeFieldsNoPrefix ''CallHierarchyIncomingCall
 makeFieldsNoPrefix ''CallHierarchyOutgoingCallsParams
 makeFieldsNoPrefix ''CallHierarchyOutgoingCall
 makeFieldsNoPrefix ''CallHierarchyItem
+
+-- Semantic tokens
+makeFieldsNoPrefix ''SemanticTokensLegend
+makeFieldsNoPrefix ''SemanticTokensDeltaClientCapabilities
+makeFieldsNoPrefix ''SemanticTokensRequestsClientCapabilities
+makeFieldsNoPrefix ''SemanticTokensClientCapabilities
+makeFieldsNoPrefix ''SemanticTokens
+makeFieldsNoPrefix ''SemanticTokensPartialResult
+makeFieldsNoPrefix ''SemanticTokensEdit
+makeFieldsNoPrefix ''SemanticTokensDelta
+makeFieldsNoPrefix ''SemanticTokensDeltaPartialResult
+makeFieldsNoPrefix ''SemanticTokensWorkspaceClientCapabilities

lsp-types/src/Language/LSP/Types/Message.hs

@@ -45,6 +45,7 @@ import           Language.LSP.Types.Registration
 import           Language.LSP.Types.Rename
 import           Language.LSP.Types.References
 import           Language.LSP.Types.SelectionRange
+import           Language.LSP.Types.SemanticTokens
 import           Language.LSP.Types.SignatureHelp
 import           Language.LSP.Types.TextDocument
 import           Language.LSP.Types.TypeDefinition
@@ -125,8 +126,14 @@ type family MessageParams (m :: Method f t) :: Type where
   MessageParams TextDocumentPrepareCallHierarchy   = CallHierarchyPrepareParams
   MessageParams CallHierarchyIncomingCalls         = CallHierarchyIncomingCallsParams
   MessageParams CallHierarchyOutgoingCalls         = CallHierarchyOutgoingCallsParams
+  -- Semantic tokens 
+  MessageParams TextDocumentSemanticTokens         = Empty
+  MessageParams TextDocumentSemanticTokensFull     = SemanticTokensParams
+  MessageParams TextDocumentSemanticTokensFullDelta = SemanticTokensDeltaParams
+  MessageParams TextDocumentSemanticTokensRange    = SemanticTokensRangeParams 
+  MessageParams WorkspaceSemanticTokensRefresh     = Empty
 -- Server
-    -- Window
+  -- Window
   MessageParams WindowShowMessage                  = ShowMessageParams
   MessageParams WindowShowMessageRequest           = ShowMessageRequestParams
   MessageParams WindowLogMessage                   = LogMessageParams
@@ -202,6 +209,12 @@ type family ResponseResult (m :: Method f Request) :: Type where
   ResponseResult TextDocumentPrepareCallHierarchy = Maybe (List CallHierarchyItem)
   ResponseResult CallHierarchyIncomingCalls    = Maybe (List CallHierarchyIncomingCall)
   ResponseResult CallHierarchyOutgoingCalls    = Maybe (List CallHierarchyOutgoingCall)
+  -- Semantic tokens 
+  ResponseResult TextDocumentSemanticTokens          = Empty
+  ResponseResult TextDocumentSemanticTokensFull      = Maybe SemanticTokens
+  ResponseResult TextDocumentSemanticTokensFullDelta = Maybe (SemanticTokens |? SemanticTokensDelta)
+  ResponseResult TextDocumentSemanticTokensRange     = Maybe SemanticTokens 
+  ResponseResult WorkspaceSemanticTokensRefresh      = Empty
   -- Custom can be either a notification or a message
 -- Server
   -- Window

lsp-types/src/Language/LSP/Types/Method.hs

@@ -79,6 +79,12 @@ data Method (f :: From) (t :: MethodType) where
   TextDocumentPrepareCallHierarchy   :: Method FromClient Request
   CallHierarchyIncomingCalls         :: Method FromClient Request
   CallHierarchyOutgoingCalls         :: Method FromClient Request
+  -- SemanticTokens
+  TextDocumentSemanticTokens         :: Method FromClient Request
+  TextDocumentSemanticTokensFull     :: Method FromClient Request
+  TextDocumentSemanticTokensFullDelta :: Method FromClient Request
+  TextDocumentSemanticTokensRange    :: Method FromClient Request
+  WorkspaceSemanticTokensRefresh     :: Method FromClient Request
 
 -- ServerMethods
   -- Window
@@ -153,6 +159,12 @@ data SMethod (m :: Method f t) where
   SCallHierarchyIncomingCalls         :: SMethod CallHierarchyIncomingCalls
   SCallHierarchyOutgoingCalls         :: SMethod CallHierarchyOutgoingCalls
 
+  STextDocumentSemanticTokens         :: SMethod TextDocumentSemanticTokens
+  STextDocumentSemanticTokensFull     :: SMethod TextDocumentSemanticTokensFull
+  STextDocumentSemanticTokensFullDelta :: SMethod TextDocumentSemanticTokensFullDelta
+  STextDocumentSemanticTokensRange    :: SMethod TextDocumentSemanticTokensRange
+  SWorkspaceSemanticTokensRefresh     :: SMethod WorkspaceSemanticTokensRefresh
+
   SWindowShowMessage                  :: SMethod WindowShowMessage
   SWindowShowMessageRequest           :: SMethod WindowShowMessageRequest
   SWindowLogMessage                   :: SMethod WindowLogMessage
@@ -243,6 +255,7 @@ instance FromJSON SomeClientMethod where
   parseJSON (A.String "workspace/didChangeWatchedFiles")     = pure $ SomeClientMethod SWorkspaceDidChangeWatchedFiles
   parseJSON (A.String "workspace/symbol")                    = pure $ SomeClientMethod SWorkspaceSymbol
   parseJSON (A.String "workspace/executeCommand")            = pure $ SomeClientMethod SWorkspaceExecuteCommand
+  parseJSON (A.String "workspace/semanticTokens/refresh")    = pure $ SomeClientMethod SWorkspaceSemanticTokensRefresh
  -- Document
   parseJSON (A.String "textDocument/didOpen")                = pure $ SomeClientMethod STextDocumentDidOpen
   parseJSON (A.String "textDocument/didChange")              = pure $ SomeClientMethod STextDocumentDidChange
@@ -278,6 +291,10 @@ instance FromJSON SomeClientMethod where
   parseJSON (A.String "textDocument/prepareCallHierarchy")   = pure $ SomeClientMethod STextDocumentPrepareCallHierarchy
   parseJSON (A.String "callHierarchy/incomingCalls")         = pure $ SomeClientMethod SCallHierarchyIncomingCalls
   parseJSON (A.String "callHierarchy/outgoingCalls")         = pure $ SomeClientMethod SCallHierarchyOutgoingCalls
+  parseJSON (A.String "textDocument/semanticTokens")         = pure $ SomeClientMethod STextDocumentSemanticTokens
+  parseJSON (A.String "textDocument/semanticTokens/full")    = pure $ SomeClientMethod STextDocumentSemanticTokensFull
+  parseJSON (A.String "textDocument/semanticTokens/full/delta") = pure $ SomeClientMethod STextDocumentSemanticTokensFullDelta
+  parseJSON (A.String "textDocument/semanticTokens/range")    = pure $ SomeClientMethod STextDocumentSemanticTokensRange
   parseJSON (A.String "window/workDoneProgress/cancel")      = pure $ SomeClientMethod SWindowWorkDoneProgressCancel
 -- Cancelling
   parseJSON (A.String "$/cancelRequest")                     = pure $ SomeClientMethod SCancelRequest
@@ -338,6 +355,7 @@ instance A.ToJSON (SMethod m) where
   toJSON SWorkspaceDidChangeWatchedFiles     = A.String "workspace/didChangeWatchedFiles"
   toJSON SWorkspaceSymbol                    = A.String "workspace/symbol"
   toJSON SWorkspaceExecuteCommand            = A.String "workspace/executeCommand"
+  toJSON SWorkspaceSemanticTokensRefresh     = A.String "workspace/semanticTokens/refresh"
   -- Document
   toJSON STextDocumentDidOpen                = A.String "textDocument/didOpen"
   toJSON STextDocumentDidChange              = A.String "textDocument/didChange"
@@ -371,6 +389,10 @@ instance A.ToJSON (SMethod m) where
   toJSON STextDocumentPrepareCallHierarchy   = A.String "textDocument/prepareCallHierarchy"
   toJSON SCallHierarchyIncomingCalls         = A.String "callHierarchy/incomingCalls"
   toJSON SCallHierarchyOutgoingCalls         = A.String "callHierarchy/outgoingCalls"
+  toJSON STextDocumentSemanticTokens         = A.String "textDocument/semanticTokens"
+  toJSON STextDocumentSemanticTokensFull     = A.String "textDocument/semanticTokens/full"
+  toJSON STextDocumentSemanticTokensFullDelta = A.String "textDocument/semanticTokens/full/delta"
+  toJSON STextDocumentSemanticTokensRange    = A.String "textDocument/semanticTokens/range"
   toJSON STextDocumentDocumentLink           = A.String "textDocument/documentLink"
   toJSON SDocumentLinkResolve                = A.String "documentLink/resolve"
   toJSON SWindowWorkDoneProgressCancel       = A.String "window/workDoneProgress/cancel"

lsp-types/src/Language/LSP/Types/Parsing.hs

@@ -253,6 +253,11 @@ splitClientMethod STextDocumentSelectionRange = IsClientReq
 splitClientMethod STextDocumentPrepareCallHierarchy = IsClientReq
 splitClientMethod SCallHierarchyIncomingCalls = IsClientReq
 splitClientMethod SCallHierarchyOutgoingCalls = IsClientReq
+splitClientMethod STextDocumentSemanticTokens = IsClientReq
+splitClientMethod STextDocumentSemanticTokensFull = IsClientReq
+splitClientMethod STextDocumentSemanticTokensFullDelta = IsClientReq
+splitClientMethod STextDocumentSemanticTokensRange = IsClientReq
+splitClientMethod SWorkspaceSemanticTokensRefresh  = IsClientReq
 splitClientMethod SCancelRequest = IsClientNot
 splitClientMethod SCustomMethod{} = IsClientEither
 

lsp-types/src/Language/LSP/Types/Registration.hs

@@ -50,6 +50,7 @@ import           Language.LSP.Types.References
 import           Language.LSP.Types.Rename
 import           Language.LSP.Types.SignatureHelp
 import           Language.LSP.Types.SelectionRange
+import           Language.LSP.Types.SemanticTokens
 import           Language.LSP.Types.TextDocument
 import           Language.LSP.Types.TypeDefinition
 import           Language.LSP.Types.Utils
@@ -98,6 +99,7 @@ type family RegistrationOptions (m :: Method FromClient t) :: Type where
   RegistrationOptions TextDocumentFoldingRange           = FoldingRangeRegistrationOptions
   RegistrationOptions TextDocumentSelectionRange         = SelectionRangeRegistrationOptions
   RegistrationOptions TextDocumentPrepareCallHierarchy   = CallHierarchyRegistrationOptions
+  RegistrationOptions TextDocumentSemanticTokens         = SemanticTokensRegistrationOptions
   RegistrationOptions m                                  = Void
 
 data Registration (m :: Method FromClient t) =