diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Revision history for lsp-types +## 1.2.0.1 + +* Add compatibility with GHC 9.2 (#345) (@fendor) +* Fix missing lenses (@michaelpj) +* Semantic tokens support (@michaelpj) +* Fix GHC 9 build (@anka-213) +* Add call hierarchy support (@July541) +* Do not crash on workspace/didChangeConfiguration (#321) (@strager) +* Improve error messages on JSON decode failures (#320) (@strager) + ## 1.2.0.0 * Prevent crashing when optional fields are missing (@anka-213) diff --git a/lsp-types.cabal b/lsp-types.cabal --- a/lsp-types.cabal +++ b/lsp-types.cabal @@ -1,5 +1,5 @@ name: lsp-types -version: 1.2.0.0 +version: 1.3.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol, data types description: An implementation of the types to allow language implementors to @@ -22,7 +22,8 @@ , Language.LSP.Types.Lens , Language.LSP.VFS , Data.IxMap - other-modules: Language.LSP.Types.Cancellation + other-modules: Language.LSP.Types.CallHierarchy + , Language.LSP.Types.Cancellation , Language.LSP.Types.ClientCapabilities , Language.LSP.Types.CodeAction , Language.LSP.Types.CodeLens @@ -55,6 +56,7 @@ , 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 @@ -68,24 +70,26 @@ , Language.LSP.Types.WorkspaceSymbol -- other-extensions: ghc-options: -Wall - build-depends: base >= 4.11 && < 4.15 + build-depends: base >= 4.11 && < 4.16 , aeson >=1.2.2.0 , binary , bytestring , 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/src/Language/LSP/Types.hs b/src/Language/LSP/Types.hs --- a/src/Language/LSP/Types.hs +++ b/src/Language/LSP/Types.hs @@ -1,5 +1,6 @@ module Language.LSP.Types - ( module Language.LSP.Types.Cancellation + ( module Language.LSP.Types.CallHierarchy + , module Language.LSP.Types.Cancellation , module Language.LSP.Types.CodeAction , module Language.LSP.Types.CodeLens , module Language.LSP.Types.Command @@ -32,6 +33,7 @@ , 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 @@ -43,6 +45,7 @@ ) where +import Language.LSP.Types.CallHierarchy import Language.LSP.Types.Cancellation import Language.LSP.Types.CodeAction import Language.LSP.Types.CodeLens @@ -74,6 +77,7 @@ 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/src/Language/LSP/Types/CallHierarchy.hs b/src/Language/LSP/Types/CallHierarchy.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Types/CallHierarchy.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | Since LSP 3.16.0 -} +module Language.LSP.Types.CallHierarchy where + +import Data.Aeson.TH +import Data.Aeson.Types ( Value ) +import Data.Text ( Text ) + +import Language.LSP.Types.Common +import Language.LSP.Types.DocumentSymbol +import Language.LSP.Types.Location +import Language.LSP.Types.Progress +import Language.LSP.Types.StaticRegistrationOptions +import Language.LSP.Types.TextDocument +import Language.LSP.Types.Uri +import Language.LSP.Types.Utils + + +data CallHierarchyClientCapabilities = + CallHierarchyClientCapabilities + { _dynamicRegistration :: Maybe Bool } + deriving (Show, Read, Eq) +deriveJSON lspOptions ''CallHierarchyClientCapabilities + +makeExtendingDatatype "CallHierarchyOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''CallHierarchyOptions + +makeExtendingDatatype "CallHierarchyRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''CallHierarchyOptions + , ''StaticRegistrationOptions + ] + [] +deriveJSON lspOptions ''CallHierarchyRegistrationOptions + +makeExtendingDatatype "CallHierarchyPrepareParams" + [''TextDocumentPositionParams, ''WorkDoneProgressParams] [] +deriveJSON lspOptions ''CallHierarchyPrepareParams + +data CallHierarchyItem = + CallHierarchyItem + { _name :: Text + , _kind :: SymbolKind + , _tags :: Maybe (List SymbolTag) + -- | More detail for this item, e.g. the signature of a function. + , _detail :: Maybe Text + , _uri :: Uri + , _range :: Range + -- | The range that should be selected and revealed when this symbol + -- is being picked, e.g. the name of a function. Must be contained by + -- the @_range@. + , _selectionRange :: Range + -- | A data entry field that is preserved between a call hierarchy + -- prepare and incoming calls or outgoing calls requests. + , _xdata :: Maybe Value + } + deriving (Show, Read, Eq) +deriveJSON lspOptions ''CallHierarchyItem + +-- ------------------------------------- + +makeExtendingDatatype "CallHierarchyIncomingCallsParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [("_item", [t| CallHierarchyItem |])] +deriveJSON lspOptions ''CallHierarchyIncomingCallsParams + +data CallHierarchyIncomingCall = + CallHierarchyIncomingCall + { -- | The item that makes the call. + _from :: CallHierarchyItem + -- | The ranges at which the calls appear. This is relative to the caller + -- denoted by @_from@. + , _fromRanges :: List Range + } + deriving (Show, Read, Eq) +deriveJSON lspOptions ''CallHierarchyIncomingCall + +-- ------------------------------------- + +makeExtendingDatatype "CallHierarchyOutgoingCallsParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [("_item", [t| CallHierarchyItem |])] +deriveJSON lspOptions ''CallHierarchyOutgoingCallsParams + +data CallHierarchyOutgoingCall = + CallHierarchyOutgoingCall + { -- | The item that is called. + _to :: CallHierarchyItem + -- | The range at which this item is called. THis is the range relative to + -- the caller, e.g the item passed to `callHierarchy/outgoingCalls` request. + , _fromRanges :: List Range + } + deriving (Show, Read, Eq) +deriveJSON lspOptions ''CallHierarchyOutgoingCall diff --git a/src/Language/LSP/Types/Capabilities.hs b/src/Language/LSP/Types/Capabilities.hs --- a/src/Language/LSP/Types/Capabilities.hs +++ b/src/Language/LSP/Types/Capabilities.hs @@ -51,7 +51,8 @@ (Just (ExecuteCommandClientCapabilities dynamicReg)) (since 3 6 True) (since 3 6 True) - + (since 3 16 (SemanticTokensWorkspaceClientCapabilities $ Just True)) + resourceOperations = List [ ResourceOperationCreate , ResourceOperationDelete @@ -103,6 +104,20 @@ , 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) @@ -126,6 +141,9 @@ (Just publishDiagnosticsCapabilities) (since 3 10 foldingRangeCapability) (since 3 5 (SelectionRangeClientCapabilities dynamicReg)) + (since 3 16 (CallHierarchyClientCapabilities dynamicReg)) + (since 3 16 semanticTokensCapabilities) + sync = TextDocumentSyncClientCapabilities dynamicReg @@ -266,5 +284,5 @@ since x y a | maj >= x && min >= y = Just a | otherwise = Nothing - + window = WindowClientCapabilities (since 3 15 True) diff --git a/src/Language/LSP/Types/ClientCapabilities.hs b/src/Language/LSP/Types/ClientCapabilities.hs --- a/src/Language/LSP/Types/ClientCapabilities.hs +++ b/src/Language/LSP/Types/ClientCapabilities.hs @@ -6,6 +6,7 @@ import Data.Aeson.TH import qualified Data.Aeson as A import Data.Default +import Language.LSP.Types.CallHierarchy import Language.LSP.Types.CodeAction import Language.LSP.Types.CodeLens import Language.LSP.Types.Command @@ -25,6 +26,7 @@ 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 @@ -60,12 +62,18 @@ -- | 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 -- ------------------------------------- @@ -101,7 +109,7 @@ , _onTypeFormatting :: Maybe DocumentOnTypeFormattingClientCapabilities -- | Capabilities specific to the `textDocument/declaration` request. - -- + -- -- Since LSP 3.14.0 , _declaration :: Maybe DeclarationClientCapabilities @@ -142,6 +150,15 @@ -- | Capabilities specific to the `textDocument/selectionRange` request. -- Since LSP 3.15.0 , _selectionRange :: Maybe SelectionRangeClientCapabilities + + -- | 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 @@ -149,7 +166,7 @@ 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 -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Types/CodeAction.hs b/src/Language/LSP/Types/CodeAction.hs --- a/src/Language/LSP/Types/CodeAction.hs +++ b/src/Language/LSP/Types/CodeAction.hs @@ -83,7 +83,7 @@ parseJSON (String "source") = pure CodeActionSource parseJSON (String "source.organizeImports") = pure CodeActionSourceOrganizeImports parseJSON (String s) = pure (CodeActionUnknown s) - parseJSON _ = mempty + parseJSON _ = fail "CodeActionKind" -- ------------------------------------- diff --git a/src/Language/LSP/Types/Common.hs b/src/Language/LSP/Types/Common.hs --- a/src/Language/LSP/Types/Common.hs +++ b/src/Language/LSP/Types/Common.hs @@ -9,6 +9,7 @@ import Control.Applicative import Control.DeepSeq import Data.Aeson +import qualified Data.HashMap.Strict as HashMap import GHC.Generics -- | A terser, isomorphic data type for 'Either', that does not get tagged when @@ -54,4 +55,5 @@ toJSON Empty = Null instance FromJSON Empty where parseJSON Null = pure Empty - parseJSON _ = mempty + parseJSON (Object o) | HashMap.null o = pure Empty + parseJSON _ = fail "expected 'null' or '{}'" diff --git a/src/Language/LSP/Types/Completion.hs b/src/Language/LSP/Types/Completion.hs --- a/src/Language/LSP/Types/Completion.hs +++ b/src/Language/LSP/Types/Completion.hs @@ -96,7 +96,7 @@ parseJSON (A.Number 23) = pure CiEvent parseJSON (A.Number 24) = pure CiOperator parseJSON (A.Number 25) = pure CiTypeParameter - parseJSON _ = mempty + parseJSON _ = fail "CompletionItemKind" data CompletionItemTag -- | Render a completion as obsolete, usually using a strike-out. @@ -110,7 +110,7 @@ instance A.FromJSON CompletionItemTag where parseJSON (A.Number 1) = pure CitDeprecated - parseJSON _ = mempty + parseJSON _ = fail "CompletionItemTag" data CompletionItemTagsClientCapabilities = CompletionItemTagsClientCapabilities @@ -158,7 +158,7 @@ instance A.FromJSON InsertTextMode where parseJSON (A.Number 1) = pure AsIs parseJSON (A.Number 2) = pure AdjustIndentation - parseJSON _ = mempty + parseJSON _ = fail "InsertTextMode" data CompletionItemInsertTextModeClientCapabilities = CompletionItemInsertTextModeClientCapabilities @@ -263,7 +263,7 @@ instance A.FromJSON InsertTextFormat where parseJSON (A.Number 1) = pure PlainText parseJSON (A.Number 2) = pure Snippet - parseJSON _ = mempty + parseJSON _ = fail "InsertTextFormat" data CompletionDoc = CompletionDocString Text | CompletionDocMarkup MarkupContent @@ -381,7 +381,7 @@ parseJSON (A.Number 2) = pure CtTriggerCharacter parseJSON (A.Number 3) = pure CtTriggerForIncompleteCompletions parseJSON (A.Number x) = pure (CtUnknown x) - parseJSON _ = mempty + parseJSON _ = fail "CompletionTriggerKind" makeExtendingDatatype "CompletionOptions" [''WorkDoneProgressOptions] [ ("_triggerCharacters", [t| Maybe [Text] |]) diff --git a/src/Language/LSP/Types/Diagnostic.hs b/src/Language/LSP/Types/Diagnostic.hs --- a/src/Language/LSP/Types/Diagnostic.hs +++ b/src/Language/LSP/Types/Diagnostic.hs @@ -37,7 +37,7 @@ parseJSON (A.Number 2) = pure DsWarning parseJSON (A.Number 3) = pure DsInfo parseJSON (A.Number 4) = pure DsHint - parseJSON _ = mempty + parseJSON _ = fail "DiagnosticSeverity" data DiagnosticTag -- | Unused or unnecessary code. @@ -61,7 +61,7 @@ instance A.FromJSON DiagnosticTag where parseJSON (A.Number 1) = pure DtUnnecessary parseJSON (A.Number 2) = pure DtDeprecated - parseJSON _ = mempty + parseJSON _ = fail "DiagnosticTag" -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Types/DocumentHighlight.hs b/src/Language/LSP/Types/DocumentHighlight.hs --- a/src/Language/LSP/Types/DocumentHighlight.hs +++ b/src/Language/LSP/Types/DocumentHighlight.hs @@ -53,7 +53,7 @@ parseJSON (Number 1) = pure HkText parseJSON (Number 2) = pure HkRead parseJSON (Number 3) = pure HkWrite - parseJSON _ = mempty + parseJSON _ = mempty "DocumentHighlightKind" -- ------------------------------------- diff --git a/src/Language/LSP/Types/DocumentSymbol.hs b/src/Language/LSP/Types/DocumentSymbol.hs --- a/src/Language/LSP/Types/DocumentSymbol.hs +++ b/src/Language/LSP/Types/DocumentSymbol.hs @@ -124,7 +124,7 @@ parseJSON (Number 25) = pure SkOperator parseJSON (Number 26) = pure SkTypeParameter parseJSON (Number x) = pure (SkUnknown x) - parseJSON _ = mempty + parseJSON _ = fail "SymbolKind" {-| Symbol tags are extra annotations that tweak the rendering of a symbol. @@ -143,7 +143,7 @@ instance FromJSON SymbolTag where parseJSON (Number 1) = pure StDeprecated parseJSON (Number x) = pure (StUnknown x) - parseJSON _ = mempty + parseJSON _ = fail "SymbolTag" -- ------------------------------------- diff --git a/src/Language/LSP/Types/FoldingRange.hs b/src/Language/LSP/Types/FoldingRange.hs --- a/src/Language/LSP/Types/FoldingRange.hs +++ b/src/Language/LSP/Types/FoldingRange.hs @@ -73,7 +73,7 @@ parseJSON (A.String "imports") = pure FoldingRangeImports parseJSON (A.String "region") = pure FoldingRangeRegion parseJSON (A.String x) = pure (FoldingRangeUnknown x) - parseJSON _ = mempty + parseJSON _ = fail "FoldingRangeKind" -- | Represents a folding range. data FoldingRange = diff --git a/src/Language/LSP/Types/Initialize.hs b/src/Language/LSP/Types/Initialize.hs --- a/src/Language/LSP/Types/Initialize.hs +++ b/src/Language/LSP/Types/Initialize.hs @@ -28,8 +28,8 @@ "off" -> return TraceOff "messages" -> return TraceMessages "verbose" -> return TraceVerbose - _ -> mempty - parseJSON _ = mempty + _ -> fail "Trace" + parseJSON _ = fail "Trace" data ClientInfo = ClientInfo @@ -89,7 +89,7 @@ instance FromJSON InitializedParams where parseJSON (Object _) = pure InitializedParams - parseJSON _ = mempty + parseJSON _ = fail "InitializedParams" instance ToJSON InitializedParams where toJSON InitializedParams = Object mempty diff --git a/src/Language/LSP/Types/Lens.hs b/src/Language/LSP/Types/Lens.hs --- a/src/Language/LSP/Types/Lens.hs +++ b/src/Language/LSP/Types/Lens.hs @@ -12,6 +12,7 @@ module Language.LSP.Types.Lens where +import Language.LSP.Types.CallHierarchy import Language.LSP.Types.Cancellation import Language.LSP.Types.ClientCapabilities import Language.LSP.Types.CodeAction @@ -50,6 +51,7 @@ 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!! @@ -354,3 +356,29 @@ -- Static registration makeFieldsNoPrefix ''StaticRegistrationOptions + +-- Call hierarchy +makeFieldsNoPrefix ''CallHierarchyClientCapabilities +makeFieldsNoPrefix ''CallHierarchyOptions +makeFieldsNoPrefix ''CallHierarchyRegistrationOptions +makeFieldsNoPrefix ''CallHierarchyPrepareParams +makeFieldsNoPrefix ''CallHierarchyIncomingCallsParams +makeFieldsNoPrefix ''CallHierarchyIncomingCall +makeFieldsNoPrefix ''CallHierarchyOutgoingCallsParams +makeFieldsNoPrefix ''CallHierarchyOutgoingCall +makeFieldsNoPrefix ''CallHierarchyItem + +-- Semantic tokens +makeFieldsNoPrefix ''SemanticTokensLegend +makeFieldsNoPrefix ''SemanticTokensDeltaClientCapabilities +makeFieldsNoPrefix ''SemanticTokensRequestsClientCapabilities +makeFieldsNoPrefix ''SemanticTokensClientCapabilities +makeFieldsNoPrefix ''SemanticTokensParams +makeFieldsNoPrefix ''SemanticTokensDeltaParams +makeFieldsNoPrefix ''SemanticTokensRangeParams +makeFieldsNoPrefix ''SemanticTokens +makeFieldsNoPrefix ''SemanticTokensPartialResult +makeFieldsNoPrefix ''SemanticTokensEdit +makeFieldsNoPrefix ''SemanticTokensDelta +makeFieldsNoPrefix ''SemanticTokensDeltaPartialResult +makeFieldsNoPrefix ''SemanticTokensWorkspaceClientCapabilities diff --git a/src/Language/LSP/Types/LspId.hs b/src/Language/LSP/Types/LspId.hs --- a/src/Language/LSP/Types/LspId.hs +++ b/src/Language/LSP/Types/LspId.hs @@ -22,7 +22,7 @@ instance A.FromJSON (LspId m) where parseJSON v@(A.Number _) = IdInt <$> A.parseJSON v parseJSON (A.String s) = return (IdString s) - parseJSON _ = mempty + parseJSON _ = fail "LspId" instance IxOrd LspId where type Base LspId = SomeLspId diff --git a/src/Language/LSP/Types/MarkupContent.hs b/src/Language/LSP/Types/MarkupContent.hs --- a/src/Language/LSP/Types/MarkupContent.hs +++ b/src/Language/LSP/Types/MarkupContent.hs @@ -27,7 +27,7 @@ instance FromJSON MarkupKind where parseJSON (String "plaintext") = pure MkPlainText parseJSON (String "markdown") = pure MkMarkdown - parseJSON _ = mempty + parseJSON _ = fail "MarkupKind" -- | A `MarkupContent` literal represents a string value which content is interpreted base on its -- | kind flag. Currently the protocol supports `plaintext` and `markdown` as markup kinds. diff --git a/src/Language/LSP/Types/Message.hs b/src/Language/LSP/Types/Message.hs --- a/src/Language/LSP/Types/Message.hs +++ b/src/Language/LSP/Types/Message.hs @@ -17,6 +17,7 @@ module Language.LSP.Types.Message where +import Language.LSP.Types.CallHierarchy import Language.LSP.Types.Cancellation import Language.LSP.Types.CodeAction import Language.LSP.Types.CodeLens @@ -44,6 +45,7 @@ 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 @@ -120,8 +122,18 @@ MessageParams TextDocumentFoldingRange = FoldingRangeParams -- Selection Range MessageParams TextDocumentSelectionRange = SelectionRangeParams + -- Call hierarchy + 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 @@ -193,6 +205,16 @@ -- FoldingRange ResponseResult TextDocumentFoldingRange = List FoldingRange ResponseResult TextDocumentSelectionRange = List SelectionRange + -- Call hierarchy + 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 @@ -322,7 +344,7 @@ parseJSON (Number (-32001)) = pure UnknownErrorCode parseJSON (Number (-32800)) = pure RequestCancelled parseJSON (Number (-32801)) = pure ContentModified - parseJSON _ = mempty + parseJSON _ = fail "ErrorCode" -- ------------------------------------- diff --git a/src/Language/LSP/Types/Method.hs b/src/Language/LSP/Types/Method.hs --- a/src/Language/LSP/Types/Method.hs +++ b/src/Language/LSP/Types/Method.hs @@ -75,6 +75,16 @@ -- FoldingRange TextDocumentFoldingRange :: Method FromClient Request TextDocumentSelectionRange :: Method FromClient Request + -- Call hierarchy + 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 @@ -145,7 +155,16 @@ STextDocumentPrepareRename :: SMethod TextDocumentPrepareRename STextDocumentFoldingRange :: SMethod TextDocumentFoldingRange STextDocumentSelectionRange :: SMethod TextDocumentSelectionRange + STextDocumentPrepareCallHierarchy :: SMethod TextDocumentPrepareCallHierarchy + 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 @@ -236,6 +255,7 @@ 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 @@ -268,12 +288,19 @@ parseJSON (A.String "textDocument/prepareRename") = pure $ SomeClientMethod STextDocumentPrepareRename parseJSON (A.String "textDocument/foldingRange") = pure $ SomeClientMethod STextDocumentFoldingRange parseJSON (A.String "textDocument/selectionRange") = pure $ SomeClientMethod STextDocumentFoldingRange + 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 -- Custom parseJSON (A.String m) = pure $ SomeClientMethod (SCustomMethod m) - parseJSON _ = mempty + parseJSON _ = fail "SomeClientMethod" instance A.FromJSON SomeServerMethod where -- Server @@ -299,10 +326,9 @@ -- Custom parseJSON (A.String m) = pure $ SomeServerMethod (SCustomMethod m) - parseJSON _ = mempty + parseJSON _ = fail "SomeServerMethod" -- instance FromJSON (SMethod m) -makeSingletonFromJSON 'SomeMethod ''SMethod -- --------------------------------------------------------------------- -- TO JSON @@ -329,6 +355,7 @@ 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" @@ -359,6 +386,13 @@ toJSON STextDocumentPrepareRename = A.String "textDocument/prepareRename" toJSON STextDocumentFoldingRange = A.String "textDocument/foldingRange" toJSON STextDocumentSelectionRange = A.String "textDocument/selectionRange" + 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" @@ -383,3 +417,5 @@ toJSON SCancelRequest = A.String "$/cancelRequest" -- Custom toJSON (SCustomMethod m) = A.String m + +makeSingletonFromJSON 'SomeMethod ''SMethod diff --git a/src/Language/LSP/Types/Parsing.hs b/src/Language/LSP/Types/Parsing.hs --- a/src/Language/LSP/Types/Parsing.hs +++ b/src/Language/LSP/Types/Parsing.hs @@ -250,6 +250,14 @@ splitClientMethod STextDocumentPrepareRename = IsClientReq splitClientMethod STextDocumentFoldingRange = IsClientReq 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/src/Language/LSP/Types/Registration.hs b/src/Language/LSP/Types/Registration.hs --- a/src/Language/LSP/Types/Registration.hs +++ b/src/Language/LSP/Types/Registration.hs @@ -29,6 +29,7 @@ import Data.Kind import Data.Void (Void) import GHC.Generics +import Language.LSP.Types.CallHierarchy import Language.LSP.Types.CodeAction import Language.LSP.Types.CodeLens import Language.LSP.Types.Command @@ -49,6 +50,7 @@ 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 @@ -96,6 +98,8 @@ RegistrationOptions TextDocumentRename = RenameRegistrationOptions RegistrationOptions TextDocumentFoldingRange = FoldingRangeRegistrationOptions RegistrationOptions TextDocumentSelectionRange = SelectionRangeRegistrationOptions + RegistrationOptions TextDocumentPrepareCallHierarchy = CallHierarchyRegistrationOptions + RegistrationOptions TextDocumentSemanticTokens = SemanticTokensRegistrationOptions RegistrationOptions m = Void data Registration (m :: Method FromClient t) = diff --git a/src/Language/LSP/Types/Rename.hs b/src/Language/LSP/Types/Rename.hs --- a/src/Language/LSP/Types/Rename.hs +++ b/src/Language/LSP/Types/Rename.hs @@ -24,7 +24,7 @@ instance FromJSON PrepareSupportDefaultBehavior where parseJSON (Number 1) = pure PsIdentifier - parseJSON _ = mempty + parseJSON _ = fail "PrepareSupportDefaultBehavior" data RenameClientCapabilities = RenameClientCapabilities diff --git a/src/Language/LSP/Types/SemanticTokens.hs b/src/Language/LSP/Types/SemanticTokens.hs new file mode 100644 --- /dev/null +++ b/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/src/Language/LSP/Types/ServerCapabilities.hs b/src/Language/LSP/Types/ServerCapabilities.hs --- a/src/Language/LSP/Types/ServerCapabilities.hs +++ b/src/Language/LSP/Types/ServerCapabilities.hs @@ -7,6 +7,7 @@ import Data.Aeson import Data.Aeson.TH import Data.Text (Text) +import Language.LSP.Types.CallHierarchy import Language.LSP.Types.CodeAction import Language.LSP.Types.CodeLens import Language.LSP.Types.Command @@ -25,6 +26,7 @@ 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 @@ -72,7 +74,7 @@ -- | The server provides signature help support. , _signatureHelpProvider :: Maybe SignatureHelpOptions -- | The server provides go to declaration support. - -- + -- -- Since LSP 3.14.0 , _declarationProvider :: Maybe (Bool |? DeclarationOptions |? DeclarationRegistrationOptions) -- | The server provides goto definition support. @@ -117,6 +119,12 @@ , _executeCommandProvider :: Maybe ExecuteCommandOptions -- | The server provides selection range support. Since LSP 3.15 , _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/src/Language/LSP/Types/SignatureHelp.hs b/src/Language/LSP/Types/SignatureHelp.hs --- a/src/Language/LSP/Types/SignatureHelp.hs +++ b/src/Language/LSP/Types/SignatureHelp.hs @@ -99,8 +99,8 @@ is <- parseJSON v case is of [l, h] -> pure $ ParameterLabelOffset l h - _ -> mempty - parseInterval _ = mempty + _ -> fail "ParameterLabel" + parseInterval _ = fail "ParameterLabel" -- ------------------------------------- @@ -166,7 +166,7 @@ parseJSON (Number 1) = pure SHTKInvoked parseJSON (Number 2) = pure SHTKTriggerCharacter parseJSON (Number 3) = pure SHTKContentChange - parseJSON _ = mempty + parseJSON _ = fail "SignatureHelpTriggerKind" -- | Additional information about the context in which a signature help request -- was triggered. diff --git a/src/Language/LSP/Types/TextDocument.hs b/src/Language/LSP/Types/TextDocument.hs --- a/src/Language/LSP/Types/TextDocument.hs +++ b/src/Language/LSP/Types/TextDocument.hs @@ -84,6 +84,7 @@ { -- | The client is supposed to include the content on save. _includeText :: Maybe Bool } deriving (Show, Read, Eq) +deriveJSON lspOptions ''SaveOptions -- ------------------------------------- @@ -106,8 +107,8 @@ parseJSON (Number 0) = pure TdSyncNone parseJSON (Number 1) = pure TdSyncFull parseJSON (Number 2) = pure TdSyncIncremental - parseJSON _ = mempty - + parseJSON _ = fail "TextDocumentSyncKind" + data TextDocumentSyncOptions = TextDocumentSyncOptions { -- | Open and close notifications are sent to the server. If omitted open @@ -220,7 +221,7 @@ parseJSON (Number 1) = pure SaveManual parseJSON (Number 2) = pure SaveAfterDelay parseJSON (Number 3) = pure SaveFocusOut - parseJSON _ = mempty + parseJSON _ = fail "TextDocumentSaveReason" data WillSaveTextDocumentParams = WillSaveTextDocumentParams @@ -234,7 +235,6 @@ -- ------------------------------------- -deriveJSON lspOptions ''SaveOptions makeExtendingDatatype "TextDocumentSaveRegistrationOptions" [''TextDocumentRegistrationOptions] diff --git a/src/Language/LSP/Types/Uri.hs b/src/Language/LSP/Types/Uri.hs --- a/src/Language/LSP/Types/Uri.hs +++ b/src/Language/LSP/Types/Uri.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -8,7 +9,8 @@ , NormalizedUri(..) , toNormalizedUri , fromNormalizedUri - , NormalizedFilePath(..) + , NormalizedFilePath + , normalizedFilePath , toNormalizedFilePath , fromNormalizedFilePath , normalizedFilePathToUri @@ -165,8 +167,12 @@ get = do v <- Data.Binary.get :: Get FilePath let nuri = internalNormalizedFilePathToUri v - return (NormalizedFilePath nuri v) + return (normalizedFilePath nuri v) +-- | A smart constructor that performs UTF-8 encoding and hash consing +normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath +normalizedFilePath nuri nfp = NormalizedFilePath nuri nfp + -- | Internal helper that takes a file path that is assumed to -- already be normalized to a URI. It is up to the caller -- to ensure normalization. @@ -188,7 +194,7 @@ fromString = toNormalizedFilePath toNormalizedFilePath :: FilePath -> NormalizedFilePath -toNormalizedFilePath fp = NormalizedFilePath nuri nfp +toNormalizedFilePath fp = normalizedFilePath nuri nfp where nfp = FP.normalise fp nuri = internalNormalizedFilePathToUri nfp @@ -200,5 +206,5 @@ normalizedFilePathToUri (NormalizedFilePath uri _) = uri uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath -uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri) mbFilePath +uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri) diff --git a/src/Language/LSP/Types/Utils.hs b/src/Language/LSP/Types/Utils.hs --- a/src/Language/LSP/Types/Utils.hs +++ b/src/Language/LSP/Types/Utils.hs @@ -38,7 +38,7 @@ makeInst :: Name -> Con -> Q [Dec] makeInst wrap (GadtC [sConstructor] args t) = do ns <- replicateM (length args) (newName "x") - let wrappedPat = pure $ ConP wrap [ConP sConstructor (map VarP ns)] + let wrappedPat = conP wrap [conP sConstructor (map varP ns)] unwrappedE = pure $ foldl' AppE (ConE sConstructor) (map VarE ns) [d| instance FromJSON $(pure t) where parseJSON = parseJSON >=> \case diff --git a/src/Language/LSP/Types/WatchedFiles.hs b/src/Language/LSP/Types/WatchedFiles.hs --- a/src/Language/LSP/Types/WatchedFiles.hs +++ b/src/Language/LSP/Types/WatchedFiles.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} module Language.LSP.Types.WatchedFiles where - + import Data.Aeson import Data.Aeson.TH import Data.Bits @@ -68,12 +68,11 @@ | Right i <- floatingOrInteger n :: Either Double Int , 0 <= i && i <= 7 = pure $ WatchKind (testBit i 0x0) (testBit i 0x1) (testBit i 0x2) - | otherwise = mempty - parseJSON _ = mempty + | otherwise = fail "WatchKind" + parseJSON _ = fail "WatchKind" -deriveJSON lspOptions ''DidChangeWatchedFilesRegistrationOptions deriveJSON lspOptions ''FileSystemWatcher - +deriveJSON lspOptions ''DidChangeWatchedFilesRegistrationOptions -- | The file event type. data FileChangeType = FcCreated -- ^ The file got created. | FcChanged -- ^ The file got changed. @@ -89,7 +88,7 @@ parseJSON (Number 1) = pure FcCreated parseJSON (Number 2) = pure FcChanged parseJSON (Number 3) = pure FcDeleted - parseJSON _ = mempty + parseJSON _ = fail "FileChangetype" -- ------------------------------------- diff --git a/src/Language/LSP/Types/Window.hs b/src/Language/LSP/Types/Window.hs --- a/src/Language/LSP/Types/Window.hs +++ b/src/Language/LSP/Types/Window.hs @@ -28,7 +28,7 @@ parseJSON (A.Number 2) = pure MtWarning parseJSON (A.Number 3) = pure MtInfo parseJSON (A.Number 4) = pure MtLog - parseJSON _ = mempty + parseJSON _ = fail "MessageType" -- --------------------------------------- diff --git a/src/Language/LSP/Types/WorkspaceEdit.hs b/src/Language/LSP/Types/WorkspaceEdit.hs --- a/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/src/Language/LSP/Types/WorkspaceEdit.hs @@ -276,7 +276,7 @@ parseJSON (String "create") = pure ResourceOperationCreate parseJSON (String "rename") = pure ResourceOperationRename parseJSON (String "delete") = pure ResourceOperationDelete - parseJSON _ = mempty + parseJSON _ = fail "ResourceOperationKind" data FailureHandlingKind = FailureHandlingAbort -- ^ Applying the workspace change is simply aborted if one of the changes provided fails. All operations executed before the failing operation stay executed. @@ -296,7 +296,7 @@ parseJSON (String "transactional") = pure FailureHandlingTransactional parseJSON (String "textOnlyTransactional") = pure FailureHandlingTextOnlyTransactional parseJSON (String "undo") = pure FailureHandlingUndo - parseJSON _ = mempty + parseJSON _ = fail "FailureHandlingKind" data WorkspaceEditChangeAnnotationClientCapabilities = WorkspaceEditChangeAnnotationClientCapabilities diff --git a/src/Language/LSP/Types/WorkspaceFolders.hs b/src/Language/LSP/Types/WorkspaceFolders.hs --- a/src/Language/LSP/Types/WorkspaceFolders.hs +++ b/src/Language/LSP/Types/WorkspaceFolders.hs @@ -10,7 +10,7 @@ data WorkspaceFolder = WorkspaceFolder - { -- | The name of the workspace folder. Defaults to the uri's basename. + { -- | The URI of the workspace folder. _uri :: Text -- | The name of the workspace folder. Defaults to the uri's basename. , _name :: Text