lsp-types 1.2.0.0 → 1.3.0.0
raw patch · 32 files changed
+819/−57 lines, 32 filesdep +Diffdep +dlistdep +mtldep −dependent-sumdep ~base
Dependencies added: Diff, dlist, mtl
Dependencies removed: dependent-sum
Dependency ranges changed: base
Files
- ChangeLog.md +10/−0
- lsp-types.cabal +8/−4
- src/Language/LSP/Types.hs +5/−1
- src/Language/LSP/Types/CallHierarchy.hs +100/−0
- src/Language/LSP/Types/Capabilities.hs +20/−2
- src/Language/LSP/Types/ClientCapabilities.hs +20/−3
- src/Language/LSP/Types/CodeAction.hs +1/−1
- src/Language/LSP/Types/Common.hs +3/−1
- src/Language/LSP/Types/Completion.hs +5/−5
- src/Language/LSP/Types/Diagnostic.hs +2/−2
- src/Language/LSP/Types/DocumentHighlight.hs +1/−1
- src/Language/LSP/Types/DocumentSymbol.hs +2/−2
- src/Language/LSP/Types/FoldingRange.hs +1/−1
- src/Language/LSP/Types/Initialize.hs +3/−3
- src/Language/LSP/Types/Lens.hs +28/−0
- src/Language/LSP/Types/LspId.hs +1/−1
- src/Language/LSP/Types/MarkupContent.hs +1/−1
- src/Language/LSP/Types/Message.hs +24/−2
- src/Language/LSP/Types/Method.hs +39/−3
- src/Language/LSP/Types/Parsing.hs +8/−0
- src/Language/LSP/Types/Registration.hs +4/−0
- src/Language/LSP/Types/Rename.hs +1/−1
- src/Language/LSP/Types/SemanticTokens.hs +496/−0
- src/Language/LSP/Types/ServerCapabilities.hs +9/−1
- src/Language/LSP/Types/SignatureHelp.hs +3/−3
- src/Language/LSP/Types/TextDocument.hs +4/−4
- src/Language/LSP/Types/Uri.hs +10/−4
- src/Language/LSP/Types/Utils.hs +1/−1
- src/Language/LSP/Types/WatchedFiles.hs +5/−6
- src/Language/LSP/Types/Window.hs +1/−1
- src/Language/LSP/Types/WorkspaceEdit.hs +2/−2
- src/Language/LSP/Types/WorkspaceFolders.hs +1/−1
ChangeLog.md view
@@ -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)
lsp-types.cabal view
@@ -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
src/Language/LSP/Types.hs view
@@ -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
+ src/Language/LSP/Types/CallHierarchy.hs view
@@ -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
src/Language/LSP/Types/Capabilities.hs view
@@ -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)
src/Language/LSP/Types/ClientCapabilities.hs view
@@ -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 -- ---------------------------------------------------------------------
src/Language/LSP/Types/CodeAction.hs view
@@ -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" -- -------------------------------------
src/Language/LSP/Types/Common.hs view
@@ -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 '{}'"
src/Language/LSP/Types/Completion.hs view
@@ -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] |])
src/Language/LSP/Types/Diagnostic.hs view
@@ -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" -- ---------------------------------------------------------------------
src/Language/LSP/Types/DocumentHighlight.hs view
@@ -53,7 +53,7 @@ parseJSON (Number 1) = pure HkText parseJSON (Number 2) = pure HkRead parseJSON (Number 3) = pure HkWrite- parseJSON _ = mempty+ parseJSON _ = mempty "DocumentHighlightKind" -- -------------------------------------
src/Language/LSP/Types/DocumentSymbol.hs view
@@ -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" -- -------------------------------------
src/Language/LSP/Types/FoldingRange.hs view
@@ -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 =
src/Language/LSP/Types/Initialize.hs view
@@ -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
src/Language/LSP/Types/Lens.hs view
@@ -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
src/Language/LSP/Types/LspId.hs view
@@ -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
src/Language/LSP/Types/MarkupContent.hs view
@@ -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.
src/Language/LSP/Types/Message.hs view
@@ -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" -- -------------------------------------
src/Language/LSP/Types/Method.hs view
@@ -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
src/Language/LSP/Types/Parsing.hs view
@@ -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
src/Language/LSP/Types/Registration.hs view
@@ -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) =
src/Language/LSP/Types/Rename.hs view
@@ -24,7 +24,7 @@ instance FromJSON PrepareSupportDefaultBehavior where parseJSON (Number 1) = pure PsIdentifier- parseJSON _ = mempty+ parseJSON _ = fail "PrepareSupportDefaultBehavior" data RenameClientCapabilities = RenameClientCapabilities
+ src/Language/LSP/Types/SemanticTokens.hs view
@@ -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)+
src/Language/LSP/Types/ServerCapabilities.hs view
@@ -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
src/Language/LSP/Types/SignatureHelp.hs view
@@ -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.
src/Language/LSP/Types/TextDocument.hs view
@@ -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]
src/Language/LSP/Types/Uri.hs view
@@ -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)
src/Language/LSP/Types/Utils.hs view
@@ -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
src/Language/LSP/Types/WatchedFiles.hs view
@@ -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" -- -------------------------------------
src/Language/LSP/Types/Window.hs view
@@ -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" -- ---------------------------------------
src/Language/LSP/Types/WorkspaceEdit.hs view
@@ -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
src/Language/LSP/Types/WorkspaceFolders.hs view
@@ -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