diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs index fb3cd66b4..61e00673a 100644 --- a/lsp-test/src/Language/LSP/Test.hs +++ b/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 diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs index 2066ac571..286101e78 100644 --- a/lsp-test/test/DummyServer.hs +++ b/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 ] diff --git a/lsp-test/test/Test.hs b/lsp-test/test/Test.hs index 30ff7f08a..9088d21c9 100644 --- a/lsp-test/test/Test.hs +++ b/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 } diff --git a/lsp-types/lsp-types.cabal b/lsp-types/lsp-types.cabal index 550207436..688c281ff 100644 --- a/lsp-types/lsp-types.cabal +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types.hs b/lsp-types/src/Language/LSP/Types.hs index d6b4c97fe..3c2525ead 100644 --- a/lsp-types/src/Language/LSP/Types.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types/Capabilities.hs b/lsp-types/src/Language/LSP/Types/Capabilities.hs index 6a61c4895..9008bf5ce 100644 --- a/lsp-types/src/Language/LSP/Types/Capabilities.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types/ClientCapabilities.hs b/lsp-types/src/Language/LSP/Types/ClientCapabilities.hs index 78fcb5a19..ed427a3b8 100644 --- a/lsp-types/src/Language/LSP/Types/ClientCapabilities.hs +++ b/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,6 +154,11 @@ 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 @@ -154,7 +166,7 @@ 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 -- --------------------------------------------------------------------- diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index 4d156146f..15fde51ca 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types/Message.hs b/lsp-types/src/Language/LSP/Types/Message.hs index 3bea7ab0c..452dbc3b7 100644 --- a/lsp-types/src/Language/LSP/Types/Message.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types/Method.hs b/lsp-types/src/Language/LSP/Types/Method.hs index 90897283c..7a215f64f 100644 --- a/lsp-types/src/Language/LSP/Types/Method.hs +++ b/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" diff --git a/lsp-types/src/Language/LSP/Types/Parsing.hs b/lsp-types/src/Language/LSP/Types/Parsing.hs index 08f756dec..ff7559f24 100644 --- a/lsp-types/src/Language/LSP/Types/Parsing.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types/Registration.hs b/lsp-types/src/Language/LSP/Types/Registration.hs index 1499460ac..210e9ee57 100644 --- a/lsp-types/src/Language/LSP/Types/Registration.hs +++ b/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) = diff --git a/lsp-types/src/Language/LSP/Types/SemanticTokens.hs b/lsp-types/src/Language/LSP/Types/SemanticTokens.hs new file mode 100644 index 000000000..aac80a48e --- /dev/null +++ b/lsp-types/src/Language/LSP/Types/SemanticTokens.hs @@ -0,0 +1,496 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Language.LSP.Types.SemanticTokens where + +import qualified Data.Aeson as A +import Data.Aeson.TH +import Data.Text (Text) + +import Control.Monad.Except + +import Language.LSP.Types.Common +import Language.LSP.Types.Location +import Language.LSP.Types.Progress +import Language.LSP.Types.StaticRegistrationOptions +import Language.LSP.Types.TextDocument +import Language.LSP.Types.Utils + +import qualified Data.Algorithm.Diff as Diff +import qualified Data.Bits as Bits +import qualified Data.DList as DList +import Data.Default +import Data.Foldable hiding (length) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, + maybeToList) +import Data.String + +data SemanticTokenTypes = + SttType + | SttClass + | SttEnum + | SttInterface + | SttStruct + | SttTypeParameter + | SttParameter + | SttVariable + | SttProperty + | SttEnumMember + | SttEvent + | SttFunction + | SttMethod + | SttMacro + | SttKeyword + | SttModifier + | SttComment + | SttString + | SttNumber + | SttRegexp + | SttOperator + | SttUnknown Text + deriving (Show, Read, Eq, Ord) + +instance A.ToJSON SemanticTokenTypes where + toJSON SttType = A.String "type" + toJSON SttClass = A.String "class" + toJSON SttEnum = A.String "enum" + toJSON SttInterface = A.String "interface" + toJSON SttStruct = A.String "struct" + toJSON SttTypeParameter = A.String "typeParameter" + toJSON SttParameter = A.String "parameter" + toJSON SttVariable = A.String "variable" + toJSON SttProperty = A.String "property" + toJSON SttEnumMember = A.String "enumMember" + toJSON SttEvent = A.String "event" + toJSON SttFunction = A.String "function" + toJSON SttMethod = A.String "method" + toJSON SttMacro = A.String "macro" + toJSON SttKeyword = A.String "keyword" + toJSON SttModifier = A.String "modifier" + toJSON SttComment = A.String "comment" + toJSON SttString = A.String "string" + toJSON SttNumber = A.String "number" + toJSON SttRegexp = A.String "regexp" + toJSON SttOperator = A.String "operator" + toJSON (SttUnknown t) = A.String t + +instance A.FromJSON SemanticTokenTypes where + parseJSON (A.String "type") = pure SttType + parseJSON (A.String "class") = pure SttClass + parseJSON (A.String "enum") = pure SttEnum + parseJSON (A.String "interface") = pure SttInterface + parseJSON (A.String "struct") = pure SttStruct + parseJSON (A.String "typeParameter") = pure SttTypeParameter + parseJSON (A.String "parameter") = pure SttParameter + parseJSON (A.String "variable") = pure SttVariable + parseJSON (A.String "property") = pure SttProperty + parseJSON (A.String "enumMember") = pure SttEnumMember + parseJSON (A.String "event") = pure SttEvent + parseJSON (A.String "function") = pure SttFunction + parseJSON (A.String "method") = pure SttMethod + parseJSON (A.String "macro") = pure SttMacro + parseJSON (A.String "keyword") = pure SttKeyword + parseJSON (A.String "modifier") = pure SttModifier + parseJSON (A.String "comment") = pure SttComment + parseJSON (A.String "string") = pure SttString + parseJSON (A.String "number") = pure SttNumber + parseJSON (A.String "regexp") = pure SttRegexp + parseJSON (A.String "operator") = pure SttOperator + parseJSON (A.String t) = pure $ SttUnknown t + parseJSON _ = mempty + +-- | The set of semantic token types which are "known" (i.e. listed in the LSP spec). +knownSemanticTokenTypes :: [SemanticTokenTypes] +knownSemanticTokenTypes = [ + SttType + , SttClass + , SttEnum + , SttInterface + , SttStruct + , SttTypeParameter + , SttParameter + , SttVariable + , SttProperty + , SttEnumMember + , SttEvent + , SttFunction + , SttMethod + , SttMacro + , SttKeyword + , SttModifier + , SttComment + , SttString + , SttNumber + , SttRegexp + , SttOperator + ] + +data SemanticTokenModifiers = + StmDeclaration + | StmDefinition + | StmReadonly + | StmStatic + | StmDeprecated + | StmAbstract + | StmAsync + | StmModification + | StmDocumentation + | StmDefaultLibrary + | StmUnknown Text + deriving (Show, Read, Eq, Ord) + +instance A.ToJSON SemanticTokenModifiers where + toJSON StmDeclaration = A.String "declaration" + toJSON StmDefinition = A.String "definition" + toJSON StmReadonly = A.String "readonly" + toJSON StmStatic = A.String "static" + toJSON StmDeprecated = A.String "deprecated" + toJSON StmAbstract = A.String "abstract" + toJSON StmAsync = A.String "async" + toJSON StmModification = A.String "modification" + toJSON StmDocumentation = A.String "documentation" + toJSON StmDefaultLibrary = A.String "defaultLibrary" + toJSON (StmUnknown t) = A.String t + +instance A.FromJSON SemanticTokenModifiers where + parseJSON (A.String "declaration") = pure StmDeclaration + parseJSON (A.String "definition") = pure StmDefinition + parseJSON (A.String "readonly") = pure StmReadonly + parseJSON (A.String "static") = pure StmStatic + parseJSON (A.String "deprecated") = pure StmDeprecated + parseJSON (A.String "abstract") = pure StmAbstract + parseJSON (A.String "async") = pure StmAsync + parseJSON (A.String "modification") = pure StmModification + parseJSON (A.String "documentation") = pure StmDocumentation + parseJSON (A.String "defaultLibrary") = pure StmDefaultLibrary + parseJSON (A.String t) = pure $ StmUnknown t + parseJSON _ = mempty + +-- | The set of semantic token modifiers which are "known" (i.e. listed in the LSP spec). +knownSemanticTokenModifiers :: [SemanticTokenModifiers] +knownSemanticTokenModifiers = [ + StmDeclaration + , StmDefinition + , StmReadonly + , StmStatic + , StmDeprecated + , StmAbstract + , StmAsync + , StmModification + , StmDocumentation + , StmDefaultLibrary + ] + +data TokenFormat = TokenFormatRelative + deriving (Show, Read, Eq) + +instance A.ToJSON TokenFormat where + toJSON TokenFormatRelative = A.String "relative" + +instance A.FromJSON TokenFormat where + parseJSON (A.String "relative") = pure TokenFormatRelative + parseJSON _ = mempty + +data SemanticTokensLegend = SemanticTokensLegend { + -- | The token types a server uses. + _tokenTypes :: List SemanticTokenTypes, + -- | The token modifiers a server uses. + _tokenModifiers :: List SemanticTokenModifiers +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensLegend + +-- We give a default legend which just lists the "known" types and modifiers in the order they're listed. +instance Default SemanticTokensLegend where + def = SemanticTokensLegend (List knownSemanticTokenTypes) (List knownSemanticTokenModifiers) + +data SemanticTokensRangeClientCapabilities = SemanticTokensRangeBool Bool | SemanticTokensRangeObj A.Value + deriving (Show, Read, Eq) +deriveJSON lspOptionsUntagged ''SemanticTokensRangeClientCapabilities + +data SemanticTokensDeltaClientCapabilities = SemanticTokensDeltaClientCapabilities { + -- | The client will send the `textDocument/semanticTokens/full/delta` + -- request if the server provides a corresponding handler. + _delta :: Maybe Bool +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensDeltaClientCapabilities + +data SemanticTokensFullClientCapabilities = SemanticTokensFullBool Bool | SemanticTokensFullDelta SemanticTokensDeltaClientCapabilities + deriving (Show, Read, Eq) +deriveJSON lspOptionsUntagged ''SemanticTokensFullClientCapabilities + +data SemanticTokensRequestsClientCapabilities = SemanticTokensRequestsClientCapabilities { + -- | The client will send the `textDocument/semanticTokens/range` request + -- if the server provides a corresponding handler. + _range :: Maybe SemanticTokensRangeClientCapabilities, + -- | The client will send the `textDocument/semanticTokens/full` request + -- if the server provides a corresponding handler. + _full :: Maybe SemanticTokensFullClientCapabilities +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensRequestsClientCapabilities + +data SemanticTokensClientCapabilities = SemanticTokensClientCapabilities { + -- | Whether implementation supports dynamic registration. If this is set to + -- `true` the client supports the new `(TextDocumentRegistrationOptions & + -- StaticRegistrationOptions)` return value for the corresponding server + -- capability as well. + _dynamicRegistration :: Maybe Bool, + + -- | Which requests the client supports and might send to the server + -- depending on the server's capability. Please note that clients might not + -- show semantic tokens or degrade some of the user experience if a range + -- or full request is advertised by the client but not provided by the + -- server. If for example the client capability `requests.full` and + -- `request.range` are both set to true but the server only provides a + -- range provider the client might not render a minimap correctly or might + -- even decide to not show any semantic tokens at all. + _requests :: SemanticTokensRequestsClientCapabilities, + + -- | The token types that the client supports. + _tokenTypes :: List SemanticTokenTypes, + + -- | The token modifiers that the client supports. + _tokenModifiers :: List SemanticTokenModifiers, + + -- | The formats the clients supports. + _formats :: List TokenFormat, + + -- | Whether the client supports tokens that can overlap each other. + _overlappingTokenSupport :: Maybe Bool, + + -- | Whether the client supports tokens that can span multiple lines. + _multilineTokenSupport :: Maybe Bool +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensClientCapabilities + +makeExtendingDatatype "SemanticTokensOptions" [''WorkDoneProgressOptions] + [ ("_legend", [t| SemanticTokensLegend |]) + , ("_range", [t| Maybe SemanticTokensRangeClientCapabilities |]) + , ("_full", [t| Maybe SemanticTokensFullClientCapabilities |]) + ] +deriveJSON lspOptions ''SemanticTokensOptions + +makeExtendingDatatype "SemanticTokensRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''SemanticTokensOptions + , ''StaticRegistrationOptions] [] +deriveJSON lspOptions ''SemanticTokensRegistrationOptions + +makeExtendingDatatype "SemanticTokensParams" + [''WorkDoneProgressParams + , ''PartialResultParams] + [ ("_textDocument", [t| TextDocumentIdentifier |]) ] +deriveJSON lspOptions ''SemanticTokensParams + +data SemanticTokens = SemanticTokens { + -- | An optional result id. If provided and clients support delta updating + -- the client will include the result id in the next semantic token request. + -- A server can then instead of computing all semantic tokens again simply + -- send a delta. + _resultId :: Maybe Text, + + -- | The actual tokens. + _xdata :: List Int +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokens + +data SemanticTokensPartialResult = SemanticTokensPartialResult { + _xdata :: List Int +} +deriveJSON lspOptions ''SemanticTokensPartialResult + +makeExtendingDatatype "SemanticTokensDeltaParams" + [''WorkDoneProgressParams + , ''PartialResultParams] + [ ("_textDocument", [t| TextDocumentIdentifier |]) + , ("_previousResultId", [t| Text |]) + ] +deriveJSON lspOptions ''SemanticTokensDeltaParams + +data SemanticTokensEdit = SemanticTokensEdit { + -- | The start offset of the edit. + _start :: Int, + -- | The count of elements to remove. + _deleteCount :: Int, + -- | The elements to insert. + _xdata :: Maybe (List Int) +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensEdit + +data SemanticTokensDelta = SemanticTokensDelta { + _resultId :: Maybe Text, + -- | The semantic token edits to transform a previous result into a new + -- result. + _edits :: List SemanticTokensEdit +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensDelta + +data SemanticTokensDeltaPartialResult = SemantictokensDeltaPartialResult { + _edits :: List SemanticTokensEdit +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensDeltaPartialResult + +makeExtendingDatatype "SemanticTokensRangeParams" + [''WorkDoneProgressParams + , ''PartialResultParams] + [ ("_textDocument", [t| TextDocumentIdentifier |]) + , ("_range", [t| Range |]) + ] +deriveJSON lspOptions ''SemanticTokensRangeParams + +data SemanticTokensWorkspaceClientCapabilities = SemanticTokensWorkspaceClientCapabilities { + -- | Whether the client implementation supports a refresh request sent from + -- the server to the client. + -- + -- Note that this event is global and will force the client to refresh all + -- semantic tokens currently shown. It should be used with absolute care + -- and is useful for situation where a server for example detect a project + -- wide change that requires such a calculation. + _refreshSupport :: Maybe Bool +} deriving (Show, Read, Eq) +deriveJSON lspOptions ''SemanticTokensWorkspaceClientCapabilities + +---------------------------------------------------------- +-- Tools for working with semantic tokens. +---------------------------------------------------------- + +-- | A single 'semantic token' as described in the LSP specification, using absolute positions. +-- This is the kind of token that is usually easiest for editors to produce. +data SemanticTokenAbsolute = SemanticTokenAbsolute { + line :: Int, + startChar :: Int, + length :: Int, + tokenType :: SemanticTokenTypes, + tokenModifiers :: [SemanticTokenModifiers] +} deriving (Show, Read, Eq, Ord) +-- Note: we want the Ord instance to sort the tokens textually: this is achieved due to the +-- order of the constructors + +-- | A single 'semantic token' as described in the LSP specification, using relative positions. +data SemanticTokenRelative = SemanticTokenRelative { + deltaLine :: Int, + deltaStartChar :: Int, + length :: Int, + tokenType :: SemanticTokenTypes, + tokenModifiers :: [SemanticTokenModifiers] +} deriving (Show, Read, Eq, Ord) +-- Note: we want the Ord instance to sort the tokens textually: this is achieved due to the +-- order of the constructors + +-- | Turn a list of absolutely-positioned tokens into a list of relatively-positioned tokens. The tokens are assumed to be in the +-- order that they appear in the document! +relativizeTokens :: [SemanticTokenAbsolute] -> [SemanticTokenRelative] +relativizeTokens xs = DList.toList $ go 0 0 xs mempty + where + -- Pass an accumulator to make this tail-recursive + go :: Int -> Int -> [SemanticTokenAbsolute] -> DList.DList SemanticTokenRelative -> DList.DList SemanticTokenRelative + go _ _ [] acc = acc + go lastLine lastChar (SemanticTokenAbsolute l c len ty mods:ts) acc = + let + lastCharInLine = if l == lastLine then lastChar else 0 + dl = l - lastLine + dc = c - lastCharInLine + in go l c ts (DList.snoc acc (SemanticTokenRelative dl dc len ty mods)) + +-- | Turn a list of relatively-positioned tokens into a list of absolutely-positioned tokens. The tokens are assumed to be in the +-- order that they appear in the document! +absolutizeTokens :: [SemanticTokenRelative] -> [SemanticTokenAbsolute] +absolutizeTokens xs = DList.toList $ go 0 0 xs mempty + where + -- Pass an accumulator to make this tail-recursive + go :: Int -> Int -> [SemanticTokenRelative] -> DList.DList SemanticTokenAbsolute -> DList.DList SemanticTokenAbsolute + go _ _ [] acc = acc + go lastLine lastChar (SemanticTokenRelative dl dc len ty mods:ts) acc = + let + lastCharInLine = if dl == 0 then lastChar else 0 + l = lastLine + dl + c = lastCharInLine + dc + in go l c ts (DList.snoc acc (SemanticTokenAbsolute l c len ty mods)) + +-- | Encode a series of relatively-positioned semantic tokens into an integer array following the given legend. +encodeTokens :: SemanticTokensLegend -> [SemanticTokenRelative] -> Either Text [Int] +encodeTokens SemanticTokensLegend{_tokenTypes=List tts,_tokenModifiers=List tms} sts = + DList.toList . DList.concat <$> traverse encodeToken sts + where + -- Note that there's no "fast" version of these (e.g. backed by an IntMap or similar) + -- in general, due to the possibility of unknown token types which are only identified by strings. + tyMap :: Map.Map SemanticTokenTypes Int + tyMap = Map.fromList $ zip tts [0..] + modMap :: Map.Map SemanticTokenModifiers Int + modMap = Map.fromList $ zip tms [0..] + + lookupTy :: SemanticTokenTypes -> Either Text Int + lookupTy ty = case Map.lookup ty tyMap of + Just tycode -> pure tycode + Nothing -> throwError $ "Semantic token type " <> fromString (show ty) <> " did not appear in the legend" + lookupMod :: SemanticTokenModifiers -> Either Text Int + lookupMod modifier = case Map.lookup modifier modMap of + Just modcode -> pure modcode + Nothing -> throwError $ "Semantic token modifier " <> fromString (show modifier) <> " did not appear in the legend" + + -- Use a DList here for better efficiency when concatenating all these together + encodeToken :: SemanticTokenRelative -> Either Text (DList.DList Int) + encodeToken (SemanticTokenRelative dl dc len ty mods) = do + tycode <- lookupTy ty + modcodes <- traverse lookupMod mods + let combinedModcode = foldl' Bits.setBit Bits.zeroBits modcodes + + pure [dl, dc, len, tycode, combinedModcode ] + +-- This is basically 'SemanticTokensEdit', but slightly easier to work with. +-- | An edit to a buffer of items. +data Edit a = Edit { editStart :: Int, editDeleteCount :: Int, editInsertions :: [a] } + deriving (Read, Show, Eq, Ord) + +-- | Compute a list of edits that will turn the first list into the second list. +computeEdits :: Eq a => [a] -> [a] -> [Edit a] +computeEdits l r = DList.toList $ go 0 Nothing (Diff.getGroupedDiff l r) mempty + where + {- + Strategy: traverse the list of diffs, keeping the current index and (maybe) an in-progress 'Edit'. + Whenever we see a 'Diff' that's only one side or the other, we can bundle that in to our in-progress + 'Edit'. We only have to stop if we see a 'Diff' that's on both sides (i.e. unchanged), then we + dump the 'Edit' into the accumulator. + We need the index, because 'Edit's need to say where they start. + -} + go :: Int -> Maybe (Edit a) -> [Diff.Diff [a]] -> DList.DList (Edit a) -> DList.DList (Edit a) + -- No more diffs: append the current edit if there is one and return + go _ e [] acc = acc <> DList.fromList (maybeToList e) + + -- Items only on the left (i.e. deletions): increment the current index, and record the count of deletions, + -- starting a new edit if necessary. + go ix e (Diff.First ds : rest) acc = + let + deleteCount = Prelude.length ds + edit = fromMaybe (Edit ix 0 []) e + in go (ix + deleteCount) (Just (edit{editDeleteCount=editDeleteCount edit + deleteCount})) rest acc + -- Items only on the right (i.e. insertions): don't increment the current index, and record the insertions, + -- starting a new edit if necessary. + go ix e (Diff.Second as : rest) acc = + let edit = fromMaybe (Edit ix 0 []) e + in go ix (Just (edit{editInsertions=editInsertions edit <> as})) rest acc + + -- Items on both sides: increment the current index appropriately (since the items appear on the left), + -- and append the current edit (if there is one) to our list of edits (since we can't continue it with a break). + go ix e (Diff.Both bs _bs : rest) acc = + let bothCount = Prelude.length bs + in go (ix + bothCount) Nothing rest (acc <> DList.fromList (maybeToList e)) + +-- | Convenience method for making a 'SemanticTokens' from a list of 'SemanticTokenAbsolute's. An error may be returned if +-- the tokens refer to types or modifiers which are not in the legend. +-- The resulting 'SemanticTokens' lacks a result ID, which must be set separately if you are using that. +makeSemanticTokens :: SemanticTokensLegend -> [SemanticTokenAbsolute] -> Either Text SemanticTokens +makeSemanticTokens legend sts = do + encoded <- encodeTokens legend $ relativizeTokens sts + pure $ SemanticTokens Nothing (List encoded) + +-- | Convenience function for making a 'SemanticTokensDelta' from a previous and current 'SemanticTokens'. +-- The resulting 'SemanticTokensDelta' lacks a result ID, which must be set separately if you are using that. +makeSemanticTokensDelta :: SemanticTokens -> SemanticTokens -> SemanticTokensDelta +makeSemanticTokensDelta SemanticTokens{_xdata=List prevTokens} SemanticTokens{_xdata=List curTokens} = + let edits = computeEdits prevTokens curTokens + stEdits = fmap (\(Edit s ds as) -> SemanticTokensEdit s ds (Just $ List as)) edits + in SemanticTokensDelta Nothing (List stEdits) + diff --git a/lsp-types/src/Language/LSP/Types/ServerCapabilities.hs b/lsp-types/src/Language/LSP/Types/ServerCapabilities.hs index 6d8e2cd57..278a011de 100644 --- a/lsp-types/src/Language/LSP/Types/ServerCapabilities.hs +++ b/lsp-types/src/Language/LSP/Types/ServerCapabilities.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 @@ -120,6 +121,10 @@ data ServerCapabilities = , _selectionRangeProvider :: Maybe (Bool |? SelectionRangeOptions |? SelectionRangeRegistrationOptions) -- | The server provides call hierarchy support. , _callHierarchyProvider :: Maybe (Bool |? CallHierarchyOptions |? CallHierarchyRegistrationOptions) + -- | The server provides semantic tokens support. + -- + -- @since 3.16.0 + , _semanticTokensProvider :: Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions) -- | The server provides workspace symbol support. , _workspaceSymbolProvider :: Maybe Bool -- | Workspace specific server capabilities diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index 4a3d6b2e7..20b7d7d3a 100644 --- a/lsp/lsp.cabal +++ b/lsp/lsp.cabal @@ -37,10 +37,8 @@ library , attoparsec , bytestring , containers - , directory , data-default , exceptions - , filepath , hslogger , hashable , lsp-types == 1.2.* @@ -116,6 +114,7 @@ test-suite unit-test DiagnosticsSpec MethodSpec ServerCapabilitiesSpec + SemanticTokensSpec TypesSpec URIFilePathSpec VspSpec @@ -123,12 +122,8 @@ test-suite unit-test build-depends: base , QuickCheck , aeson - , bytestring , containers - , data-default - , directory , filepath - , hashable , lsp , hspec -- , hspec-jenkins @@ -137,7 +132,6 @@ test-suite unit-test , quickcheck-instances , rope-utf16-splay >= 0.2 , sorted-list == 0.2.1.* - , stm , text , unordered-containers -- For GHCI tests diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index ceb7de6d6..c934bced7 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -474,7 +474,7 @@ getWorkspaceFolders = do clientCaps <- getClientCapabilities let clientSupportsWfs = fromMaybe False $ do let (J.ClientCapabilities mw _ _ _) = clientCaps - (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw + (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _ _) <- mw mwf if clientSupportsWfs then Just <$> getsState resWorkspaceFolders @@ -564,6 +564,7 @@ registerCapability method regOpts f = do STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just STextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? J.textDocument . _Just . J.callHierarchy . _Just + STextDocumentSemanticTokens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.semanticTokens . _Just _ -> False -- | Sends a @client/unregisterCapability@ request and removes the handler diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index c50ca5b30..a249df6ec 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -33,13 +33,13 @@ import Control.Concurrent.STM import Control.Monad.Trans.Except import Control.Monad.Reader import Data.IxMap -import System.Directory import System.Log.Logger import qualified Data.Dependent.Map as DMap import Data.Maybe import Data.Dependent.Map (DMap) import qualified Data.Map.Strict as Map import System.Exit +import Data.Default (def) processMessage :: BSL.ByteString -> LspM config () processMessage jsonStr = do @@ -164,6 +164,7 @@ inferServerCapabilities clientCaps o h = , _executeCommandProvider = executeCommandProvider , _selectionRangeProvider = supportedBool STextDocumentSelectionRange , _callHierarchyProvider = supportedBool STextDocumentPrepareCallHierarchy + , _semanticTokensProvider = semanticTokensProvider , _workspaceSymbolProvider = supported SWorkspaceSymbol , _workspace = Just workspace -- TODO: Add something for experimental @@ -247,6 +248,16 @@ inferServerCapabilities clientCaps o h = | supported_b STextDocumentRename = Just (InL True) | otherwise = Just (InL False) + -- Always provide the default legend + -- TODO: allow user-provided legend via 'Options', or at least user-provided types + semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing def semanticTokenRangeProvider semanticTokenFullProvider + semanticTokenRangeProvider + | supported_b STextDocumentSemanticTokensRange = Just $ SemanticTokensRangeBool True + | otherwise = Nothing + semanticTokenFullProvider + | supported_b STextDocumentSemanticTokensFull = Just $ SemanticTokensFullDelta $ SemanticTokensDeltaClientCapabilities $ supported STextDocumentSemanticTokensFullDelta + | otherwise = Nothing + sync = case textDocumentSync o of Just x -> Just (InL x) Nothing -> Nothing diff --git a/lsp/test/MethodSpec.hs b/lsp/test/MethodSpec.hs index 354df8701..84eb18716 100644 --- a/lsp/test/MethodSpec.hs +++ b/lsp/test/MethodSpec.hs @@ -31,6 +31,7 @@ clientMethods = [ ,"workspace/didChangeWatchedFiles" ,"workspace/symbol" ,"workspace/executeCommand" + ,"workspace/semanticTokens/refresh" -- Document ,"textDocument/didOpen" ,"textDocument/didChange" @@ -59,6 +60,11 @@ clientMethods = [ ,"textDocument/prepareCallHierarchy" ,"callHierarchy/incomingCalls" ,"callHierarchy/outgoingCalls" + + ,"textDocument/semanticTokens" + ,"textDocument/semanticTokens/full" + ,"textDocument/semanticTokens/full/delta" + ,"textDocument/semanticTokens/range" ] serverMethods :: [T.Text] diff --git a/lsp/test/SemanticTokensSpec.hs b/lsp/test/SemanticTokensSpec.hs new file mode 100644 index 000000000..d826f30f0 --- /dev/null +++ b/lsp/test/SemanticTokensSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module SemanticTokensSpec where + +import Test.Hspec +import Language.LSP.Types +import Data.List (unfoldr) +import Data.Either (isRight) + +spec :: Spec +spec = do + let exampleLegend = SemanticTokensLegend (List [SttProperty, SttType, SttClass]) (List [StmUnknown "private", StmStatic]) + exampleTokens1 = [ + SemanticTokenAbsolute 2 5 3 SttProperty [StmUnknown "private", StmStatic] + , SemanticTokenAbsolute 2 10 4 SttType [] + , SemanticTokenAbsolute 5 2 7 SttClass [] + ] + exampleTokens2 = [ + SemanticTokenAbsolute 3 5 3 SttProperty [StmUnknown "private", StmStatic] + , SemanticTokenAbsolute 3 10 4 SttType [] + , SemanticTokenAbsolute 6 2 7 SttClass [] + ] + + bigNumber :: Int + bigNumber = 100000 + bigTokens = + unfoldr (\i -> if i == bigNumber then Nothing else Just (SemanticTokenAbsolute i 1 1 SttType [StmUnknown "private", StmStatic], i+1)) 0 + -- Relativized version of bigTokens + bigTokensRel = + unfoldr (\i -> if i == bigNumber then Nothing else Just (SemanticTokenRelative (if i == 0 then 0 else 1) 1 1 SttType [StmUnknown "private", StmStatic], i+1)) 0 + + -- One more order of magnitude makes diffing more-or-less hang - possibly we need a better diffing algorithm, since this is only ~= 200 tokens at 5 ints per token + -- (I checked and it is the diffing that's slow, not turning it into edits) + smallerBigNumber :: Int + smallerBigNumber = 1000 + bigInts :: [Int] + bigInts = + unfoldr (\i -> if i == smallerBigNumber then Nothing else Just (1, i+1)) 0 + bigInts2 :: [Int] + bigInts2 = + unfoldr (\i -> if i == smallerBigNumber then Nothing else Just (if even i then 2 else 1, i+1)) 0 + + describe "relativize/absolutizeTokens" $ do + it "round-trips" $ do + absolutizeTokens (relativizeTokens exampleTokens1) `shouldBe` exampleTokens1 + absolutizeTokens (relativizeTokens exampleTokens2) `shouldBe` exampleTokens2 + it "handles big tokens" $ relativizeTokens bigTokens `shouldBe` bigTokensRel + + describe "encodeTokens" $ do + context "when running the LSP examples" $ do + it "encodes example 1 correctly" $ + let encoded = encodeTokens exampleLegend (relativizeTokens exampleTokens1) + in encoded `shouldBe` Right [{- token 1 -}2,5,3,0,3,{- token 2 -}0,5,4,1,0,{- token 3 -}3,2,7,2,0] + it "encodes example 2 correctly" $ + let encoded = encodeTokens exampleLegend (relativizeTokens exampleTokens2) + in encoded `shouldBe` Right [{- token 1 -}3,5,3,0,3,{- token 2 -}0,5,4,1,0,{- token 3 -}3,2,7,2,0] + it "handles big tokens" $ encodeTokens exampleLegend bigTokensRel `shouldSatisfy` isRight + + describe "computeEdits" $ do + it "handles an edit in the middle" $ + computeEdits @Int [1,2,3] [1,4,5,3] `shouldBe` [Edit 1 1 [4,5]] + it "handles an edit at the end" $ + computeEdits @Int [1,2,3] [1,2,4,5] `shouldBe` [Edit 2 1 [4,5]] + it "handles an edit at the beginning" $ + computeEdits @Int [1,2,3] [4,5,2,3] `shouldBe` [Edit 0 1 [4,5]] + it "handles an ambiguous edit" $ + computeEdits @Int [1,2,3] [1,3,4,3] `shouldBe` [Edit 1 1 [], Edit 3 0 [4,3]] + it "handles a long edit" $ + computeEdits @Int [1,2,3,4,5] [1,7,7,7,7,7,5] `shouldBe` [Edit 1 3 [7,7,7,7,7]] + it "handles multiple edits" $ + computeEdits @Int [1,2,3,4,5] [1,6,3,7,7,5] `shouldBe` [Edit 1 1 [6], Edit 3 1 [7,7]] + it "handles big tokens" $ + -- It's a little hard to specify a useful predicate here, the main point is that it should not take too long + computeEdits @Int bigInts bigInts2 `shouldSatisfy` (not . null)