diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,21 @@ -# Revision history for haskell-lsp-types +# Revision history for lsp-types + +## 1.2.0.0 + +* Prevent crashing when optional fields are missing (@anka-213) +* Use StrictData (@wz1000) +* Add MarkupContent in SignatureHelp types (@michaelpj) +* Add activeParameter support in SignatureInformation (@michaelpj) +* Add label offset support in SignatureHelp (@michaelpj) +* Add some documentation comments to SignatureHelp types (@michaelpj) +* Add support for InsertReplaceEdit (@michaelpj) +* Add support for InsertTextMode (@michaelpj) +* Add resolveSupport (@michaelpj) +* Fix applying a TextEdit past the end of the document (#271) (@michaelpj) +* Use Empty instead of () as progress create response (#295) (@wz1000) +* Add tag support for DocumentSymbol, SymbolInformation, and document symbol provider label (#301) (@michaelpj) +* Support change annotations (#302) (@michaelpj) +* Add some more missing lenses (#307) (@michaelpj) ## 1.1.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,11 +3,15 @@ # lsp-types Haskell library for the data types for Microsoft Language Server Protocol +It is part of the [lsp](https://github.com/haskell/lsp) family of +packages, along with [lsp](https://hackage.haskell.org/package/lsp) +and [lsp-test](https://hackage.haskell.org/package/lsp-test) + ## Useful links +- https://github.com/haskell/lsp - https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md ## Other resource -See #haskell-ide-engine on IRC freenode - +See #haskell-language-server on IRC freenode diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/lsp-types.cabal b/lsp-types.cabal --- a/lsp-types.cabal +++ b/lsp-types.cabal @@ -1,11 +1,11 @@ name: lsp-types -version: 1.1.0.0 +version: 1.2.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol, data types description: An implementation of the types to allow language implementors to support the Language Server Protocol for their specific language. -homepage: https://github.com/alanz/lsp +homepage: https://github.com/haskell/lsp license: MIT license-file: LICENSE author: Alan Zimmerman @@ -48,6 +48,7 @@ , Language.LSP.Types.MarkupContent , Language.LSP.Types.Method , Language.LSP.Types.Message + , Language.LSP.Types.Parsing , Language.LSP.Types.Progress , Language.LSP.Types.Registration , Language.LSP.Types.References @@ -91,7 +92,8 @@ , unordered-containers hs-source-dirs: src default-language: Haskell2010 + default-extensions: StrictData source-repository head type: git - location: https://github.com/alanz/lsp + location: https://github.com/haskell/lsp diff --git a/src/Data/IxMap.hs b/src/Data/IxMap.hs --- a/src/Data/IxMap.hs +++ b/src/Data/IxMap.hs @@ -3,10 +3,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} module Data.IxMap where -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Data.Some import Data.Kind import Unsafe.Coerce @@ -36,5 +37,5 @@ pickFromIxMap :: IxOrd k => k m -> IxMap k f -> (Maybe (f m), IxMap k f) pickFromIxMap i (IxMap m) = case M.updateLookupWithKey (\_ _ -> Nothing) (toBase i) m of - (Nothing,m') -> (Nothing,IxMap m') - (Just (Some k),m') -> (Just (unsafeCoerce k),IxMap m') + (Nothing,!m') -> (Nothing,IxMap m') + (Just (Some k),!m') -> (Just (unsafeCoerce k),IxMap m') 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 @@ -24,6 +24,7 @@ , module Language.LSP.Types.MarkupContent , module Language.LSP.Types.Method , module Language.LSP.Types.Message + , module Language.LSP.Types.Parsing , module Language.LSP.Types.Progress , module Language.LSP.Types.References , module Language.LSP.Types.Registration @@ -67,6 +68,7 @@ import Language.LSP.Types.MarkupContent import Language.LSP.Types.Method import Language.LSP.Types.Message +import Language.LSP.Types.Parsing import Language.LSP.Types.Progress import Language.LSP.Types.References import Language.LSP.Types.Registration 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Language.LSP.Types.Capabilities ( module Language.LSP.Types.ClientCapabilities @@ -41,7 +42,9 @@ (Just (WorkspaceEditClientCapabilities (Just True) (since 3 13 resourceOperations) - Nothing)) + Nothing + (since 3 16 True) + (since 3 16 (WorkspaceEditChangeAnnotationClientCapabilities (Just True))))) (Just (DidChangeConfigurationClientCapabilities dynamicReg)) (Just (DidChangeWatchedFilesClientCapabilities dynamicReg)) (Just symbolCapabilities) @@ -58,10 +61,14 @@ symbolCapabilities = WorkspaceSymbolClientCapabilities dynamicReg (since 3 4 symbolKindCapabilities) + (since 3 16 symbolTagCapabilities) symbolKindCapabilities = WorkspaceSymbolKindClientCapabilities (Just sKs) + symbolTagCapabilities = + WorkspaceSymbolTagClientCapabilities (Just (List [StDeprecated])) + sKs | maj >= 3 && min >= 4 = List (oldSKs ++ newSKs) | otherwise = List oldSKs @@ -115,7 +122,7 @@ (Just (CodeLensClientCapabilities dynamicReg)) (Just (DocumentLinkClientCapabilities dynamicReg (since 3 15 True))) (since 3 6 (DocumentColorClientCapabilities dynamicReg)) - (Just (RenameClientCapabilities dynamicReg (since 3 12 True))) + (Just (RenameClientCapabilities dynamicReg (since 3 12 True) (since 3 16 PsIdentifier) (since 3 16 True))) (Just publishDiagnosticsCapabilities) (since 3 10 foldingRangeCapability) (since 3 5 (SelectionRangeClientCapabilities dynamicReg)) @@ -140,12 +147,15 @@ (Just True) (since 3 9 True) (since 3 15 completionItemTagsCapabilities) + (since 3 16 True) + (since 3 16 (CompletionItemResolveClientCapabilities (List ["documentation", "details"]))) + (since 3 16 (CompletionItemInsertTextModeClientCapabilities (List []))) completionItemKindCapabilities = CompletionItemKindClientCapabilities (Just ciKs) completionItemTagsCapabilities = - CompletionItemTagsClientCapabilities (List [ CtDeprecated ]) + CompletionItemTagsClientCapabilities (List [ CitDeprecated ]) ciKs | maj >= 3 && min >= 4 = List (oldCiKs ++ newCiKs) @@ -190,6 +200,10 @@ dynamicReg (since 3 8 (CodeActionLiteralSupport caKs)) (since 3 15 True) + (since 3 16 True) + (since 3 16 True) + (since 3 16 (CodeActionResolveClientCapabilities (List []))) + (since 3 16 True) caKs = CodeActionKindClientCapabilities (List [ CodeActionQuickFix , CodeActionRefactor @@ -208,17 +222,27 @@ signatureInformationCapability = SignatureHelpSignatureInformation - (Just (List [MkPlainText, MkMarkdown])) Nothing + (Just (List [MkPlainText, MkMarkdown])) + (Just signatureParameterCapability) + (since 3 16 True) + signatureParameterCapability = + SignatureHelpParameterInformation (since 3 14 True) + documentSymbolCapability = DocumentSymbolClientCapabilities dynamicReg (since 3 4 documentSymbolKind) (since 3 10 True) + (since 3 16 documentSymbolTag) + (since 3 16 True) documentSymbolKind = DocumentSymbolKindClientCapabilities (Just sKs) -- same as workspace symbol kinds + + documentSymbolTag = + DocumentSymbolTagClientCapabilities (Just (List [StDeprecated])) foldingRangeCapability = FoldingRangeClientCapabilities 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 @@ -116,6 +116,13 @@ deriveJSON lspOptions ''CodeActionLiteralSupport +data CodeActionResolveClientCapabilities = + CodeActionResolveClientCapabilities + { _properties :: List Text -- ^ The properties that a client can resolve lazily. + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CodeActionResolveClientCapabilities + data CodeActionClientCapabilities = CodeActionClientCapabilities { -- | Whether code action supports dynamic registration. _dynamicRegistration :: Maybe Bool, @@ -124,7 +131,30 @@ -- Since 3.8.0 _codeActionLiteralSupport :: Maybe CodeActionLiteralSupport, -- | Whether code action supports the `isPreferred` property. Since LSP 3.15.0 - _isPreferredSupport :: Maybe Bool + _isPreferredSupport :: Maybe Bool, + -- | Whether code action supports the `disabled` property. + -- + -- @since 3.16.0 + _disabledSupport :: Maybe Bool, + -- | Whether code action supports the `data` property which is + -- preserved between a `textDocument/codeAction` and a + -- `codeAction/resolve` request. + -- + -- @since 3.16.0 + _dataSupport :: Maybe Bool, + -- | Whether the client supports resolving additional code action + -- properties via a separate `codeAction/resolve` request. + -- + -- @since 3.16.0 + _resolveSupport :: Maybe CodeActionResolveClientCapabilities, + -- | Whether the client honors the change annotations in + -- text edits and resource operations returned via the + -- `CodeAction#edit` property by for example presenting + -- the workspace edit in the user interface and asking + -- for confirmation. + -- + -- @since 3.16.0 + _honorsChangeAnnotations :: Maybe Bool } deriving (Show, Read, Eq) @@ -133,7 +163,7 @@ -- ------------------------------------- makeExtendingDatatype "CodeActionOptions" [''WorkDoneProgressOptions] - [("_codeActionKinds", [t| Maybe (List CodeActionKind) |])] + [("_codeActionKinds", [t| Maybe (List CodeActionKind) |]), ("_resolveProvider", [t| Maybe Bool |]) ] deriveJSON lspOptions ''CodeActionOptions makeExtendingDatatype "CodeActionRegistrationOptions" @@ -205,7 +235,12 @@ -- | A command this code action executes. If a code action -- provides an edit and a command, first the edit is -- executed and then the command. - _command :: Maybe Command + _command :: Maybe Command, + -- | A data entry field that is preserved on a code action between + -- a `textDocument/codeAction` and a `codeAction/resolve` request. + -- + -- @since 3.16.0 + _xdata :: Maybe Value } deriving (Read, Show, Eq) deriveJSON lspOptions ''CodeAction 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 @@ -3,7 +3,6 @@ {-# LANGUAGE TemplateHaskell #-} module Language.LSP.Types.Completion where -import Control.Applicative import qualified Data.Aeson as A import Data.Aeson.TH import Data.Scientific ( Scientific ) @@ -15,6 +14,7 @@ import Language.LSP.Types.TextDocument import Language.LSP.Types.Utils import Language.LSP.Types.WorkspaceEdit +import Language.LSP.Types.Location (Range) data CompletionItemKind = CiText | CiMethod @@ -100,14 +100,16 @@ data CompletionItemTag -- | Render a completion as obsolete, usually using a strike-out. - = CtDeprecated + = CitDeprecated + | CitUnknown Scientific deriving (Eq, Ord, Show, Read) instance A.ToJSON CompletionItemTag where - toJSON CtDeprecated = A.Number 1 + toJSON CitDeprecated = A.Number 1 + toJSON (CitUnknown i) = A.Number i instance A.FromJSON CompletionItemTag where - parseJSON (A.Number 1) = pure CtDeprecated + parseJSON (A.Number 1) = pure CitDeprecated parseJSON _ = mempty data CompletionItemTagsClientCapabilities = @@ -118,6 +120,53 @@ deriveJSON lspOptions ''CompletionItemTagsClientCapabilities +data CompletionItemResolveClientCapabilities = + CompletionItemResolveClientCapabilities + { -- | The properties that a client can resolve lazily. + _properties :: List Text + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CompletionItemResolveClientCapabilities + +{-| +How whitespace and indentation is handled during completion +item insertion. + +@since 3.16.0 +-} +data InsertTextMode = + -- | The insertion or replace strings is taken as it is. If the + -- value is multi line the lines below the cursor will be + -- inserted using the indentation defined in the string value. + -- The client will not apply any kind of adjustments to the + -- string. + AsIs + -- | The editor adjusts leading whitespace of new lines so that + -- they match the indentation up to the cursor of the line for + -- which the item is accepted. + -- + -- Consider a line like this: <2tabs><3tabs>foo. Accepting a + -- multi line completion item is indented using 2 tabs and all + -- following lines inserted will be indented using 2 tabs as well. + | AdjustIndentation + deriving (Read,Show,Eq) + +instance A.ToJSON InsertTextMode where + toJSON AsIs = A.Number 1 + toJSON AdjustIndentation = A.Number 2 + +instance A.FromJSON InsertTextMode where + parseJSON (A.Number 1) = pure AsIs + parseJSON (A.Number 2) = pure AdjustIndentation + parseJSON _ = mempty + +data CompletionItemInsertTextModeClientCapabilities = + CompletionItemInsertTextModeClientCapabilities + { _valueSet :: List InsertTextMode + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CompletionItemInsertTextModeClientCapabilities + data CompletionItemClientCapabilities = CompletionItemClientCapabilities { -- | Client supports snippets as insert text. @@ -145,7 +194,26 @@ -- supporting tags have to handle unknown tags gracefully. Clients -- especially need to preserve unknown tags when sending a -- completion item back to the server in a resolve call. + -- + -- @since 3.15.0 , _tagSupport :: Maybe CompletionItemTagsClientCapabilities + -- | Client supports insert replace edit to control different behavior if + -- completion item is inserted in the text or should replace text. + -- + -- @since 3.16.0 + , _insertReplaceSupport :: Maybe Bool + -- | Indicates which properties a client can resolve lazily on a + -- completion item. Before version 3.16.0 only the predefined properties + -- `documentation` and `details` could be resolved lazily. + -- + -- @since 3.16.0 + , _resolveSupport :: Maybe CompletionItemResolveClientCapabilities + -- | The client supports the `insertTextMode` property on + -- a completion item to override the whitespace handling mode + -- as defined by the client (see `insertTextMode`). + -- + -- @since 3.16.0 + , _insertTextModeSupport :: Maybe CompletionItemInsertTextModeClientCapabilities } deriving (Show, Read, Eq) deriveJSON lspOptions ''CompletionItemClientCapabilities @@ -201,13 +269,22 @@ | CompletionDocMarkup MarkupContent deriving (Show, Read, Eq) -instance A.ToJSON CompletionDoc where - toJSON (CompletionDocString x) = A.toJSON x - toJSON (CompletionDocMarkup x) = A.toJSON x +deriveJSON lspOptionsUntagged ''CompletionDoc -instance A.FromJSON CompletionDoc where - parseJSON x = CompletionDocString <$> A.parseJSON x <|> CompletionDocMarkup <$> A.parseJSON x +data InsertReplaceEdit = + InsertReplaceEdit + { _newText :: Text -- ^ The string to be inserted. + , _insert :: Range -- ^ The range if the insert is requested + , _repalce :: Range -- ^ The range if the replace is requested. + } + deriving (Read,Show,Eq) +deriveJSON lspOptions ''InsertReplaceEdit +data CompletionEdit = CompletionEditText TextEdit | CompletionEditInsertReplace InsertReplaceEdit + deriving (Read,Show,Eq) + +deriveJSON lspOptionsUntagged ''CompletionEdit + data CompletionItem = CompletionItem { _label :: Text -- ^ The label of this completion item. By default also @@ -239,7 +316,11 @@ -- ^ The format of the insert text. The format applies to both the -- `insertText` property and the `newText` property of a provided -- `textEdit`. - , _textEdit :: Maybe TextEdit + , _insertTextMode :: Maybe InsertTextMode + -- ^ How whitespace and indentation is handled during completion + -- item insertion. If not provided the client's default value depends on + -- the @textDocument.completion.insertTextMode@ client capability. + , _textEdit :: Maybe CompletionEdit -- ^ An edit which is applied to a document when selecting this -- completion. When an edit is provided the value of `insertText` is -- ignored. 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 @@ -15,7 +15,9 @@ -- --------------------------------------------------------------------- -makeExtendingDatatype "DocumentSymbolOptions" [''WorkDoneProgressOptions] [] +makeExtendingDatatype "DocumentSymbolOptions" + [''WorkDoneProgressOptions] + [ ("_label", [t| Maybe Bool |])] deriveJSON lspOptions ''DocumentSymbolOptions makeExtendingDatatype "DocumentSymbolRegistrationOptions" @@ -123,6 +125,25 @@ parseJSON (Number 26) = pure SkTypeParameter parseJSON (Number x) = pure (SkUnknown x) parseJSON _ = mempty + +{-| +Symbol tags are extra annotations that tweak the rendering of a symbol. + +@since 3.16.0 +-} +data SymbolTag = + StDeprecated -- ^ Render a symbol as obsolete, usually using a strike-out. + | StUnknown Scientific + deriving (Read, Show, Eq) + +instance ToJSON SymbolTag where + toJSON StDeprecated = Number 1 + toJSON (StUnknown x) = Number x + +instance FromJSON SymbolTag where + parseJSON (Number 1) = pure StDeprecated + parseJSON (Number x) = pure (StUnknown x) + parseJSON _ = mempty -- ------------------------------------- @@ -142,6 +163,15 @@ deriveJSON lspOptions ''DocumentSymbolKindClientCapabilities +data DocumentSymbolTagClientCapabilities = + DocumentSymbolTagClientCapabilities + { -- | The tags supported by the client. + _valueSet :: Maybe (List SymbolTag) + } + deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DocumentSymbolTagClientCapabilities + data DocumentSymbolClientCapabilities = DocumentSymbolClientCapabilities { -- | Whether document symbol supports dynamic registration. @@ -149,11 +179,20 @@ -- | Specific capabilities for the `SymbolKind`. , _symbolKind :: Maybe DocumentSymbolKindClientCapabilities , _hierarchicalDocumentSymbolSupport :: Maybe Bool + -- | The client supports tags on `SymbolInformation`. + -- Clients supporting tags have to handle unknown tags gracefully. + -- + -- @since 3.16.0 + , _tagSupport :: Maybe DocumentSymbolTagClientCapabilities + -- | The client supports an additional label presented in the UI when + -- registering a document symbol provider. + -- + -- @since 3.16.0 + , _labelSupport :: Maybe Bool } deriving (Show, Read, Eq) deriveJSON lspOptions ''DocumentSymbolClientCapabilities - -- --------------------------------------------------------------------- -- | Represents programming constructs like variables, classes, interfaces etc. @@ -167,7 +206,8 @@ -- provided the name is used. , _detail :: Maybe Text , _kind :: SymbolKind -- ^ The kind of this symbol. - , _deprecated :: Maybe Bool -- ^ Indicates if this symbol is deprecated. + , _tags :: Maybe (List SymbolTag) -- ^ Tags for this document symbol. + , _deprecated :: Maybe Bool -- ^ Indicates if this symbol is deprecated. Deprecated, use tags instead. -- | The range enclosing this symbol not including leading/trailing -- whitespace but everything else like comments. This information is -- typically used to determine if the the clients cursor is inside the symbol @@ -190,7 +230,8 @@ SymbolInformation { _name :: Text -- ^ The name of this symbol. , _kind :: SymbolKind -- ^ The kind of this symbol. - , _deprecated :: Maybe Bool -- ^ Indicates if this symbol is deprecated. + , _tags :: Maybe (List SymbolTag) -- ^ Tags for this symbol. + , _deprecated :: Maybe Bool -- ^ Indicates if this symbol is deprecated. Deprecated, use tags instead. -- | The location of this symbol. The location's range is used by a tool -- to reveal the location in the editor. If the symbol is selected in the -- tool the range's start information is used to position the cursor. So @@ -207,5 +248,6 @@ -- symbols. , _containerName :: Maybe Text } deriving (Read,Show,Eq) +{-# DEPRECATED _deprecated "Use tags instead" #-} deriveJSON lspOptions ''SymbolInformation diff --git a/src/Language/LSP/Types/Hover.hs b/src/Language/LSP/Types/Hover.hs --- a/src/Language/LSP/Types/Hover.hs +++ b/src/Language/LSP/Types/Hover.hs @@ -2,8 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} module Language.LSP.Types.Hover where -import Control.Applicative -import Data.Aeson import Data.Aeson.TH import Data.Text ( Text ) @@ -49,12 +47,7 @@ | CodeString LanguageString deriving (Eq,Read,Show) -instance ToJSON MarkedString where - toJSON (PlainString x) = toJSON x - toJSON (CodeString x) = toJSON x -instance FromJSON MarkedString where - parseJSON (String t) = pure $ PlainString t - parseJSON o = CodeString <$> parseJSON o +deriveJSON lspOptionsUntagged ''MarkedString -- ------------------------------------- @@ -63,15 +56,7 @@ | HoverContents MarkupContent deriving (Read,Show,Eq) -instance ToJSON HoverContents where - toJSON (HoverContentsMS x) = toJSON x - toJSON (HoverContents x) = toJSON x -instance FromJSON HoverContents where - parseJSON v@(String _) = HoverContentsMS <$> parseJSON v - parseJSON v@(Array _) = HoverContentsMS <$> parseJSON v - parseJSON v@(Object _) = HoverContents <$> parseJSON v - <|> HoverContentsMS <$> parseJSON v - parseJSON _ = mempty +deriveJSON lspOptionsUntagged ''HoverContents -- ------------------------------------- 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 @@ -51,8 +51,6 @@ , ("_workspaceFolders", [t| Maybe (List WorkspaceFolder) |]) ] -{-# DEPRECATED _rootPath "Use _rootUri" #-} - deriveJSON lspOptions ''InitializeParams data InitializeError = 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 @@ -7,6 +7,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeInType #-} module Language.LSP.Types.Lens where @@ -113,6 +115,8 @@ makeFieldsNoPrefix ''MarkupContent -- Completion +makeFieldsNoPrefix ''CompletionDoc +makeFieldsNoPrefix ''CompletionEdit makeFieldsNoPrefix ''CompletionItem makeFieldsNoPrefix ''CompletionContext makeFieldsNoPrefix ''CompletionList @@ -120,9 +124,12 @@ makeFieldsNoPrefix ''CompletionOptions makeFieldsNoPrefix ''CompletionRegistrationOptions makeFieldsNoPrefix ''CompletionItemTagsClientCapabilities +makeFieldsNoPrefix ''CompletionItemResolveClientCapabilities +makeFieldsNoPrefix ''CompletionItemInsertTextModeClientCapabilities makeFieldsNoPrefix ''CompletionItemClientCapabilities makeFieldsNoPrefix ''CompletionItemKindClientCapabilities makeFieldsNoPrefix ''CompletionClientCapabilities +makeFieldsNoPrefix ''InsertReplaceEdit -- Declaration makeFieldsNoPrefix ''DeclarationClientCapabilities @@ -134,6 +141,7 @@ makeFieldsNoPrefix ''CodeActionKindClientCapabilities makeFieldsNoPrefix ''CodeActionLiteralSupport makeFieldsNoPrefix ''CodeActionClientCapabilities +makeFieldsNoPrefix ''CodeActionResolveClientCapabilities makeFieldsNoPrefix ''CodeActionOptions makeFieldsNoPrefix ''CodeActionRegistrationOptions makeFieldsNoPrefix ''CodeActionContext @@ -190,6 +198,7 @@ makeFieldsNoPrefix ''RenameOptions makeFieldsNoPrefix ''RenameRegistrationOptions makeFieldsNoPrefix ''RenameParams +makeFieldsNoPrefix ''PrepareSupportDefaultBehavior -- PrepareRename makeFieldsNoPrefix ''PrepareRenameParams @@ -237,6 +246,8 @@ -- WorkspaceEdit makeFieldsNoPrefix ''TextEdit +makeFieldsNoPrefix ''ChangeAnnotation +makeFieldsNoPrefix ''AnnotatedTextEdit makeFieldsNoPrefix ''VersionedTextDocumentIdentifier makeFieldsNoPrefix ''TextDocumentEdit makeFieldsNoPrefix ''CreateFileOptions @@ -247,6 +258,7 @@ makeFieldsNoPrefix ''DeleteFile makeFieldsNoPrefix ''WorkspaceEdit makeFieldsNoPrefix ''WorkspaceEditClientCapabilities +makeFieldsNoPrefix ''WorkspaceEditChangeAnnotationClientCapabilities -- Workspace Folders makeFieldsNoPrefix ''WorkspaceFolder 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 @@ -12,7 +12,7 @@ import Language.LSP.Types.Method -- | Id used for a request, Can be either a String or an Int -data LspId (m :: Method f Request) = IdInt Int | IdString Text +data LspId (m :: Method f Request) = IdInt !Int | IdString !Text deriving (Show,Read,Eq,Ord) instance A.ToJSON (LspId m) where @@ -25,15 +25,21 @@ parseJSON _ = mempty instance IxOrd LspId where - type Base LspId = Either Int Text - toBase (IdInt i) = Left i - toBase (IdString s) = Right s + type Base LspId = SomeLspId + toBase = SomeLspId data SomeLspId where - SomeLspId :: LspId m -> SomeLspId + SomeLspId :: !(LspId m) -> SomeLspId deriving instance Show SomeLspId instance Eq SomeLspId where - SomeLspId a == SomeLspId b = toBase a == toBase b + SomeLspId (IdInt a) == SomeLspId (IdInt b) = a == b + SomeLspId (IdString a) == SomeLspId (IdString b) = a == b + _ == _ = False instance Ord SomeLspId where - SomeLspId a `compare` SomeLspId b = toBase a `compare` toBase b + compare (SomeLspId x) (SomeLspId y) = go x y + where + go (IdInt a) (IdInt b) = a `compare` b + go (IdString a) (IdString b) = a `compare` b + go (IdInt _) (IdString _) = LT + go (IdString _) (IdInt _) = GT 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 @@ -57,12 +57,8 @@ import Data.Kind import Data.Aeson -import Data.Aeson.Types import Data.Aeson.TH -import Data.GADT.Compare import Data.Text (Text) -import Data.Type.Equality -import Data.Function (on) import GHC.Generics -- --------------------------------------------------------------------- @@ -201,7 +197,7 @@ -- Server -- Window ResponseResult WindowShowMessageRequest = Maybe MessageActionItem - ResponseResult WindowWorkDoneProgressCreate = () + ResponseResult WindowWorkDoneProgressCreate = Empty -- Capability ResponseResult ClientRegisterCapability = Empty ResponseResult ClientUnregisterCapability = Empty @@ -237,7 +233,7 @@ deriving instance Show (MessageParams m) => Show (NotificationMessage m) instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (NotificationMessage m) where - parseJSON = genericParseJSON lspOptions + parseJSON = genericParseJSON lspOptions . addNullField "params" instance (ToJSON (MessageParams m)) => ToJSON (NotificationMessage m) where toJSON = genericToJSON lspOptions toEncoding = genericToEncoding lspOptions @@ -253,8 +249,15 @@ deriving instance (Read (SMethod m), Read (MessageParams m)) => Read (RequestMessage m) deriving instance Show (MessageParams m) => Show (RequestMessage m) +-- | Replace a missing field in an object with a null field, to simplify parsing +-- This is a hack to allow other types than Maybe to work like Maybe in allowing the field to be missing. +-- See also this issue: https://github.com/haskell/aeson/issues/646 +addNullField :: Text -> Value -> Value +addNullField s (Object o) = Object $ HM.insertWith (\_new old -> old) s Null o +addNullField _ v = v + instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (RequestMessage m) where - parseJSON = genericParseJSON lspOptions + parseJSON = genericParseJSON lspOptions . addNullField "params" instance (ToJSON (MessageParams m), FromJSON (SMethod m)) => ToJSON (RequestMessage m) where toJSON = genericToJSON lspOptions toEncoding = genericToEncoding lspOptions @@ -382,255 +385,3 @@ -- Some helpful type synonyms type ClientMessage (m :: Method FromClient t) = Message m type ServerMessage (m :: Method FromServer t) = Message m - --- --------------------------------------------------------------------- --- Working with arbritary messages --- --------------------------------------------------------------------- - -data FromServerMessage' a where - FromServerMess :: forall t (m :: Method FromServer t) a. SMethod m -> Message m -> FromServerMessage' a - FromServerRsp :: forall (m :: Method FromClient Request) a. a m -> ResponseMessage m -> FromServerMessage' a - -type FromServerMessage = FromServerMessage' SMethod - -instance Eq FromServerMessage where - (==) = (==) `on` toJSON -instance Show FromServerMessage where - show = show . toJSON - -instance ToJSON FromServerMessage where - toJSON (FromServerMess m p) = serverMethodJSON m (toJSON p) - toJSON (FromServerRsp m p) = clientResponseJSON m (toJSON p) - -fromServerNot :: forall (m :: Method FromServer Notification). - Message m ~ NotificationMessage m => NotificationMessage m -> FromServerMessage -fromServerNot m@NotificationMessage{_method=meth} = FromServerMess meth m - -fromServerReq :: forall (m :: Method FromServer Request). - Message m ~ RequestMessage m => RequestMessage m -> FromServerMessage -fromServerReq m@RequestMessage{_method=meth} = FromServerMess meth m - -data FromClientMessage' a where - FromClientMess :: forall t (m :: Method FromClient t) a. SMethod m -> Message m -> FromClientMessage' a - FromClientRsp :: forall (m :: Method FromServer Request) a. a m -> ResponseMessage m -> FromClientMessage' a - -type FromClientMessage = FromClientMessage' SMethod - -instance ToJSON FromClientMessage where - toJSON (FromClientMess m p) = clientMethodJSON m (toJSON p) - toJSON (FromClientRsp m p) = serverResponseJSON m (toJSON p) - -fromClientNot :: forall (m :: Method FromClient Notification). - Message m ~ NotificationMessage m => NotificationMessage m -> FromClientMessage -fromClientNot m@NotificationMessage{_method=meth} = FromClientMess meth m - -fromClientReq :: forall (m :: Method FromClient Request). - Message m ~ RequestMessage m => RequestMessage m -> FromClientMessage -fromClientReq m@RequestMessage{_method=meth} = FromClientMess meth m - -type LookupFunc f a = forall (m :: Method f Request). LspId m -> Maybe (SMethod m, a m) - -{- -Message Types we must handle are the following - -Request | jsonrpc | id | method | params? -Response | jsonrpc | id | | | response? | error? -Notification | jsonrpc | | method | params? --} - -parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMessage' a) -parseServerMessage lookupId v@(Object o) = do - case HM.lookup "method" o of - Just cmd -> do - -- Request or Notification - SomeServerMethod m <- parseJSON cmd - case splitServerMethod m of - IsServerNot -> FromServerMess m <$> parseJSON v - IsServerReq -> FromServerMess m <$> parseJSON v - IsServerEither - | HM.member "id" o -- Request - , SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request)) - in FromServerMess m' <$> parseJSON v - | SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification)) - in FromServerMess m' <$> parseJSON v - Nothing -> do - case HM.lookup "id" o of - Just i' -> do - i <- parseJSON i' - case lookupId i of - Just (m,res) -> clientResponseJSON m $ FromServerRsp res <$> parseJSON v - Nothing -> fail $ unwords ["Failed in looking up response type of", show v] - Nothing -> fail $ unwords ["Got unexpected message without method or id"] -parseServerMessage _ v = fail $ unwords ["parseServerMessage expected object, got:",show v] - -parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMessage' a) -parseClientMessage lookupId v@(Object o) = do - case HM.lookup "method" o of - Just cmd -> do - -- Request or Notification - SomeClientMethod m <- parseJSON cmd - case splitClientMethod m of - IsClientNot -> FromClientMess m <$> parseJSON v - IsClientReq -> FromClientMess m <$> parseJSON v - IsClientEither - | HM.member "id" o -- Request - , SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request)) - in FromClientMess m' <$> parseJSON v - | SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification)) - in FromClientMess m' <$> parseJSON v - Nothing -> do - case HM.lookup "id" o of - Just i' -> do - i <- parseJSON i' - case lookupId i of - Just (m,res) -> serverResponseJSON m $ FromClientRsp res <$> parseJSON v - Nothing -> fail $ unwords ["Failed in looking up response type of", show v] - Nothing -> fail $ unwords ["Got unexpected message without method or id"] -parseClientMessage _ v = fail $ unwords ["parseClientMessage expected object, got:",show v] - --- --------------------------------------------------------------------- --- Helper Utilities --- --------------------------------------------------------------------- - -clientResponseJSON :: SClientMethod m -> (HasJSON (ResponseMessage m) => x) -> x -clientResponseJSON m x = case splitClientMethod m of - IsClientReq -> x - IsClientEither -> x - -serverResponseJSON :: SServerMethod m -> (HasJSON (ResponseMessage m) => x) -> x -serverResponseJSON m x = case splitServerMethod m of - IsServerReq -> x - IsServerEither -> x - -clientMethodJSON :: SClientMethod m -> (ToJSON (ClientMessage m) => x) -> x -clientMethodJSON m x = - case splitClientMethod m of - IsClientNot -> x - IsClientReq -> x - IsClientEither -> x - -serverMethodJSON :: SServerMethod m -> (ToJSON (ServerMessage m) => x) -> x -serverMethodJSON m x = - case splitServerMethod m of - IsServerNot -> x - IsServerReq -> x - IsServerEither -> x - -type HasJSON a = (ToJSON a,FromJSON a,Eq a) - --- Reify universal properties about Client/Server Messages - -data ClientNotOrReq (m :: Method FromClient t) where - IsClientNot - :: ( HasJSON (ClientMessage m) - , Message m ~ NotificationMessage m) - => ClientNotOrReq (m :: Method FromClient Notification) - IsClientReq - :: forall (m :: Method FromClient Request). - ( HasJSON (ClientMessage m) - , HasJSON (ResponseMessage m) - , Message m ~ RequestMessage m) - => ClientNotOrReq m - IsClientEither - :: ClientNotOrReq CustomMethod - -data ServerNotOrReq (m :: Method FromServer t) where - IsServerNot - :: ( HasJSON (ServerMessage m) - , Message m ~ NotificationMessage m) - => ServerNotOrReq (m :: Method FromServer Notification) - IsServerReq - :: forall (m :: Method FromServer Request). - ( HasJSON (ServerMessage m) - , HasJSON (ResponseMessage m) - , Message m ~ RequestMessage m) - => ServerNotOrReq m - IsServerEither - :: ServerNotOrReq CustomMethod - -splitClientMethod :: SClientMethod m -> ClientNotOrReq m -splitClientMethod SInitialize = IsClientReq -splitClientMethod SInitialized = IsClientNot -splitClientMethod SShutdown = IsClientReq -splitClientMethod SExit = IsClientNot -splitClientMethod SWorkspaceDidChangeWorkspaceFolders = IsClientNot -splitClientMethod SWorkspaceDidChangeConfiguration = IsClientNot -splitClientMethod SWorkspaceDidChangeWatchedFiles = IsClientNot -splitClientMethod SWorkspaceSymbol = IsClientReq -splitClientMethod SWorkspaceExecuteCommand = IsClientReq -splitClientMethod SWindowWorkDoneProgressCancel = IsClientNot -splitClientMethod STextDocumentDidOpen = IsClientNot -splitClientMethod STextDocumentDidChange = IsClientNot -splitClientMethod STextDocumentWillSave = IsClientNot -splitClientMethod STextDocumentWillSaveWaitUntil = IsClientReq -splitClientMethod STextDocumentDidSave = IsClientNot -splitClientMethod STextDocumentDidClose = IsClientNot -splitClientMethod STextDocumentCompletion = IsClientReq -splitClientMethod SCompletionItemResolve = IsClientReq -splitClientMethod STextDocumentHover = IsClientReq -splitClientMethod STextDocumentSignatureHelp = IsClientReq -splitClientMethod STextDocumentDeclaration = IsClientReq -splitClientMethod STextDocumentDefinition = IsClientReq -splitClientMethod STextDocumentTypeDefinition = IsClientReq -splitClientMethod STextDocumentImplementation = IsClientReq -splitClientMethod STextDocumentReferences = IsClientReq -splitClientMethod STextDocumentDocumentHighlight = IsClientReq -splitClientMethod STextDocumentDocumentSymbol = IsClientReq -splitClientMethod STextDocumentCodeAction = IsClientReq -splitClientMethod STextDocumentCodeLens = IsClientReq -splitClientMethod SCodeLensResolve = IsClientReq -splitClientMethod STextDocumentDocumentLink = IsClientReq -splitClientMethod SDocumentLinkResolve = IsClientReq -splitClientMethod STextDocumentDocumentColor = IsClientReq -splitClientMethod STextDocumentColorPresentation = IsClientReq -splitClientMethod STextDocumentFormatting = IsClientReq -splitClientMethod STextDocumentRangeFormatting = IsClientReq -splitClientMethod STextDocumentOnTypeFormatting = IsClientReq -splitClientMethod STextDocumentRename = IsClientReq -splitClientMethod STextDocumentPrepareRename = IsClientReq -splitClientMethod STextDocumentFoldingRange = IsClientReq -splitClientMethod STextDocumentSelectionRange = IsClientReq -splitClientMethod SCancelRequest = IsClientNot -splitClientMethod SCustomMethod{} = IsClientEither - -splitServerMethod :: SServerMethod m -> ServerNotOrReq m -splitServerMethod SWindowShowMessage = IsServerNot -splitServerMethod SWindowShowMessageRequest = IsServerReq -splitServerMethod SWindowLogMessage = IsServerNot -splitServerMethod SWindowWorkDoneProgressCreate = IsServerReq -splitServerMethod SProgress = IsServerNot -splitServerMethod STelemetryEvent = IsServerNot -splitServerMethod SClientRegisterCapability = IsServerReq -splitServerMethod SClientUnregisterCapability = IsServerReq -splitServerMethod SWorkspaceWorkspaceFolders = IsServerReq -splitServerMethod SWorkspaceConfiguration = IsServerReq -splitServerMethod SWorkspaceApplyEdit = IsServerReq -splitServerMethod STextDocumentPublishDiagnostics = IsServerNot -splitServerMethod SCancelRequest = IsServerNot -splitServerMethod SCustomMethod{} = IsServerEither - --- | Heterogeneous equality on singleton server methods -mEqServer :: SServerMethod m1 -> SServerMethod m2 -> Maybe (m1 :~~: m2) -mEqServer m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of - (IsServerNot, IsServerNot) -> do - Refl <- geq m1 m2 - pure HRefl - (IsServerReq, IsServerReq) -> do - Refl <- geq m1 m2 - pure HRefl - _ -> Nothing - --- | Heterogeneous equality on singlton client methods -mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (m1 :~~: m2) -mEqClient m1 m2 = case (splitClientMethod m1, splitClientMethod m2) of - (IsClientNot, IsClientNot) -> do - Refl <- geq m1 m2 - pure HRefl - (IsClientReq, IsClientReq) -> do - Refl <- geq m1 m2 - pure HRefl - _ -> Nothing diff --git a/src/Language/LSP/Types/Parsing.hs b/src/Language/LSP/Types/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Types/Parsing.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + +module Language.LSP.Types.Parsing where + +import Language.LSP.Types.LspId +import Language.LSP.Types.Method +import Language.LSP.Types.Message +import qualified Data.HashMap.Strict as HM + +import Data.Aeson +import Data.Aeson.Types +import Data.GADT.Compare +import Data.Type.Equality +import Data.Function (on) + +-- --------------------------------------------------------------------- +-- Working with arbritary messages +-- --------------------------------------------------------------------- + +data FromServerMessage' a where + FromServerMess :: forall t (m :: Method FromServer t) a. SMethod m -> Message m -> FromServerMessage' a + FromServerRsp :: forall (m :: Method FromClient Request) a. a m -> ResponseMessage m -> FromServerMessage' a + +type FromServerMessage = FromServerMessage' SMethod + +instance Eq FromServerMessage where + (==) = (==) `on` toJSON +instance Show FromServerMessage where + show = show . toJSON + +instance ToJSON FromServerMessage where + toJSON (FromServerMess m p) = serverMethodJSON m (toJSON p) + toJSON (FromServerRsp m p) = clientResponseJSON m (toJSON p) + +fromServerNot :: forall (m :: Method FromServer Notification). + Message m ~ NotificationMessage m => NotificationMessage m -> FromServerMessage +fromServerNot m@NotificationMessage{_method=meth} = FromServerMess meth m + +fromServerReq :: forall (m :: Method FromServer Request). + Message m ~ RequestMessage m => RequestMessage m -> FromServerMessage +fromServerReq m@RequestMessage{_method=meth} = FromServerMess meth m + +data FromClientMessage' a where + FromClientMess :: forall t (m :: Method FromClient t) a. SMethod m -> Message m -> FromClientMessage' a + FromClientRsp :: forall (m :: Method FromServer Request) a. a m -> ResponseMessage m -> FromClientMessage' a + +type FromClientMessage = FromClientMessage' SMethod + +instance ToJSON FromClientMessage where + toJSON (FromClientMess m p) = clientMethodJSON m (toJSON p) + toJSON (FromClientRsp m p) = serverResponseJSON m (toJSON p) + +fromClientNot :: forall (m :: Method FromClient Notification). + Message m ~ NotificationMessage m => NotificationMessage m -> FromClientMessage +fromClientNot m@NotificationMessage{_method=meth} = FromClientMess meth m + +fromClientReq :: forall (m :: Method FromClient Request). + Message m ~ RequestMessage m => RequestMessage m -> FromClientMessage +fromClientReq m@RequestMessage{_method=meth} = FromClientMess meth m + +-- --------------------------------------------------------------------- +-- Parsing +-- --------------------------------------------------------------------- + +type LookupFunc f a = forall (m :: Method f Request). LspId m -> Maybe (SMethod m, a m) + +{- +Message Types we must handle are the following + +Request | jsonrpc | id | method | params? +Response | jsonrpc | id | | | response? | error? +Notification | jsonrpc | | method | params? +-} + +{-# INLINE parseServerMessage #-} +parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMessage' a) +parseServerMessage lookupId v@(Object o) = do + case HM.lookup "method" o of + Just cmd -> do + -- Request or Notification + SomeServerMethod m <- parseJSON cmd + case splitServerMethod m of + IsServerNot -> FromServerMess m <$> parseJSON v + IsServerReq -> FromServerMess m <$> parseJSON v + IsServerEither + | HM.member "id" o -- Request + , SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request)) + in FromServerMess m' <$> parseJSON v + | SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification)) + in FromServerMess m' <$> parseJSON v + Nothing -> do + case HM.lookup "id" o of + Just i' -> do + i <- parseJSON i' + case lookupId i of + Just (m,res) -> clientResponseJSON m $ FromServerRsp res <$> parseJSON v + Nothing -> fail $ unwords ["Failed in looking up response type of", show v] + Nothing -> fail $ unwords ["Got unexpected message without method or id"] +parseServerMessage _ v = fail $ unwords ["parseServerMessage expected object, got:",show v] + +{-# INLINE parseClientMessage #-} +parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMessage' a) +parseClientMessage lookupId v@(Object o) = do + case HM.lookup "method" o of + Just cmd -> do + -- Request or Notification + SomeClientMethod m <- parseJSON cmd + case splitClientMethod m of + IsClientNot -> FromClientMess m <$> parseJSON v + IsClientReq -> FromClientMess m <$> parseJSON v + IsClientEither + | HM.member "id" o -- Request + , SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request)) + in FromClientMess m' <$> parseJSON v + | SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification)) + in FromClientMess m' <$> parseJSON v + Nothing -> do + case HM.lookup "id" o of + Just i' -> do + i <- parseJSON i' + case lookupId i of + Just (m,res) -> serverResponseJSON m $ FromClientRsp res <$> parseJSON v + Nothing -> fail $ unwords ["Failed in looking up response type of", show v] + Nothing -> fail $ unwords ["Got unexpected message without method or id"] +parseClientMessage _ v = fail $ unwords ["parseClientMessage expected object, got:",show v] + +-- --------------------------------------------------------------------- +-- Helper Utilities +-- --------------------------------------------------------------------- + +{-# INLINE clientResponseJSON #-} +clientResponseJSON :: SClientMethod m -> (HasJSON (ResponseMessage m) => x) -> x +clientResponseJSON m x = case splitClientMethod m of + IsClientReq -> x + IsClientEither -> x + +{-# INLINE serverResponseJSON #-} +serverResponseJSON :: SServerMethod m -> (HasJSON (ResponseMessage m) => x) -> x +serverResponseJSON m x = case splitServerMethod m of + IsServerReq -> x + IsServerEither -> x + +{-# INLINE clientMethodJSON#-} +clientMethodJSON :: SClientMethod m -> (ToJSON (ClientMessage m) => x) -> x +clientMethodJSON m x = + case splitClientMethod m of + IsClientNot -> x + IsClientReq -> x + IsClientEither -> x + +{-# INLINE serverMethodJSON #-} +serverMethodJSON :: SServerMethod m -> (ToJSON (ServerMessage m) => x) -> x +serverMethodJSON m x = + case splitServerMethod m of + IsServerNot -> x + IsServerReq -> x + IsServerEither -> x + +type HasJSON a = (ToJSON a,FromJSON a,Eq a) + +-- Reify universal properties about Client/Server Messages + +data ClientNotOrReq (m :: Method FromClient t) where + IsClientNot + :: ( HasJSON (ClientMessage m) + , Message m ~ NotificationMessage m) + => ClientNotOrReq (m :: Method FromClient Notification) + IsClientReq + :: forall (m :: Method FromClient Request). + ( HasJSON (ClientMessage m) + , HasJSON (ResponseMessage m) + , Message m ~ RequestMessage m) + => ClientNotOrReq m + IsClientEither + :: ClientNotOrReq CustomMethod + +data ServerNotOrReq (m :: Method FromServer t) where + IsServerNot + :: ( HasJSON (ServerMessage m) + , Message m ~ NotificationMessage m) + => ServerNotOrReq (m :: Method FromServer Notification) + IsServerReq + :: forall (m :: Method FromServer Request). + ( HasJSON (ServerMessage m) + , HasJSON (ResponseMessage m) + , Message m ~ RequestMessage m) + => ServerNotOrReq m + IsServerEither + :: ServerNotOrReq CustomMethod + +{-# INLINE splitClientMethod #-} +splitClientMethod :: SClientMethod m -> ClientNotOrReq m +splitClientMethod SInitialize = IsClientReq +splitClientMethod SInitialized = IsClientNot +splitClientMethod SShutdown = IsClientReq +splitClientMethod SExit = IsClientNot +splitClientMethod SWorkspaceDidChangeWorkspaceFolders = IsClientNot +splitClientMethod SWorkspaceDidChangeConfiguration = IsClientNot +splitClientMethod SWorkspaceDidChangeWatchedFiles = IsClientNot +splitClientMethod SWorkspaceSymbol = IsClientReq +splitClientMethod SWorkspaceExecuteCommand = IsClientReq +splitClientMethod SWindowWorkDoneProgressCancel = IsClientNot +splitClientMethod STextDocumentDidOpen = IsClientNot +splitClientMethod STextDocumentDidChange = IsClientNot +splitClientMethod STextDocumentWillSave = IsClientNot +splitClientMethod STextDocumentWillSaveWaitUntil = IsClientReq +splitClientMethod STextDocumentDidSave = IsClientNot +splitClientMethod STextDocumentDidClose = IsClientNot +splitClientMethod STextDocumentCompletion = IsClientReq +splitClientMethod SCompletionItemResolve = IsClientReq +splitClientMethod STextDocumentHover = IsClientReq +splitClientMethod STextDocumentSignatureHelp = IsClientReq +splitClientMethod STextDocumentDeclaration = IsClientReq +splitClientMethod STextDocumentDefinition = IsClientReq +splitClientMethod STextDocumentTypeDefinition = IsClientReq +splitClientMethod STextDocumentImplementation = IsClientReq +splitClientMethod STextDocumentReferences = IsClientReq +splitClientMethod STextDocumentDocumentHighlight = IsClientReq +splitClientMethod STextDocumentDocumentSymbol = IsClientReq +splitClientMethod STextDocumentCodeAction = IsClientReq +splitClientMethod STextDocumentCodeLens = IsClientReq +splitClientMethod SCodeLensResolve = IsClientReq +splitClientMethod STextDocumentDocumentLink = IsClientReq +splitClientMethod SDocumentLinkResolve = IsClientReq +splitClientMethod STextDocumentDocumentColor = IsClientReq +splitClientMethod STextDocumentColorPresentation = IsClientReq +splitClientMethod STextDocumentFormatting = IsClientReq +splitClientMethod STextDocumentRangeFormatting = IsClientReq +splitClientMethod STextDocumentOnTypeFormatting = IsClientReq +splitClientMethod STextDocumentRename = IsClientReq +splitClientMethod STextDocumentPrepareRename = IsClientReq +splitClientMethod STextDocumentFoldingRange = IsClientReq +splitClientMethod STextDocumentSelectionRange = IsClientReq +splitClientMethod SCancelRequest = IsClientNot +splitClientMethod SCustomMethod{} = IsClientEither + +{-# INLINE splitServerMethod #-} +splitServerMethod :: SServerMethod m -> ServerNotOrReq m +splitServerMethod SWindowShowMessage = IsServerNot +splitServerMethod SWindowShowMessageRequest = IsServerReq +splitServerMethod SWindowLogMessage = IsServerNot +splitServerMethod SWindowWorkDoneProgressCreate = IsServerReq +splitServerMethod SProgress = IsServerNot +splitServerMethod STelemetryEvent = IsServerNot +splitServerMethod SClientRegisterCapability = IsServerReq +splitServerMethod SClientUnregisterCapability = IsServerReq +splitServerMethod SWorkspaceWorkspaceFolders = IsServerReq +splitServerMethod SWorkspaceConfiguration = IsServerReq +splitServerMethod SWorkspaceApplyEdit = IsServerReq +splitServerMethod STextDocumentPublishDiagnostics = IsServerNot +splitServerMethod SCancelRequest = IsServerNot +splitServerMethod SCustomMethod{} = IsServerEither + +-- | Given a witness that two custom methods are of the same type, produce a witness that the methods are the same +data CustomEq m1 m2 where + CustomEq + :: (m1 ~ (CustomMethod :: Method f t1), m2 ~ (CustomMethod :: Method f t2)) + => { runCustomEq :: (t1 ~ t2 => m1 :~~: m2) } + -> CustomEq m1 m2 + +runEq :: (t1 ~ t2) + => (SMethod m1 -> SMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2))) + -> SMethod (m1 :: Method f t1) + -> SMethod (m2 :: Method f t2) + -> Maybe (m1 :~~: m2) +runEq f m1 m2 = do + res <- f m1 m2 + pure $ case res of + Right eq -> eq + Left ceq -> runCustomEq ceq + +-- | Heterogeneous equality on singleton server methods +mEqServer :: SServerMethod m1 -> SServerMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2)) +mEqServer m1 m2 = go (splitServerMethod m1) (splitServerMethod m2) + where + go IsServerNot IsServerNot = do + Refl <- geq m1 m2 + pure $ Right HRefl + go IsServerReq IsServerReq = do + Refl <- geq m1 m2 + pure $ Right HRefl + go IsServerEither IsServerEither + | SCustomMethod c1 <- m1 + , SCustomMethod c2 <- m2 + , c1 == c2 + = Just $ Left $ CustomEq HRefl + go _ _ = Nothing + +-- | Heterogeneous equality on singleton client methods +mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2)) +mEqClient m1 m2 = go (splitClientMethod m1) (splitClientMethod m2) + where + go IsClientNot IsClientNot = do + Refl <- geq m1 m2 + pure $ Right HRefl + go IsClientReq IsClientReq = do + Refl <- geq m1 m2 + pure $ Right HRefl + go IsClientEither IsClientEither + | SCustomMethod c1 <- m1 + , SCustomMethod c2 <- m2 + , c1 == c2 + = Just $ Left $ CustomEq HRefl + go _ _ = Nothing diff --git a/src/Language/LSP/Types/Progress.hs b/src/Language/LSP/Types/Progress.hs --- a/src/Language/LSP/Types/Progress.hs +++ b/src/Language/LSP/Types/Progress.hs @@ -6,7 +6,6 @@ module Language.LSP.Types.Progress where -import Control.Applicative import Control.Monad (unless) import qualified Data.Aeson as A import Data.Aeson.TH @@ -22,14 +21,7 @@ | ProgressTextToken Text deriving (Show, Read, Eq, Ord) -instance A.ToJSON ProgressToken where - toJSON (ProgressNumericToken i) = A.toJSON i - toJSON (ProgressTextToken t) = A.toJSON t - -instance A.FromJSON ProgressToken where - parseJSON (A.String t) = pure $ ProgressTextToken t - parseJSON (A.Number i) = ProgressNumericToken <$> A.parseJSON (A.Number i) - parseJSON v = fail $ "Invalid progress token: " ++ show v +deriveJSON lspOptionsUntagged ''ProgressToken -- | Parameters for a $/progress notification. data ProgressParams t = @@ -40,23 +32,6 @@ deriveJSON lspOptions ''ProgressParams -data SomeProgressParams - = Begin WorkDoneProgressBeginParams - | Report WorkDoneProgressReportParams - | End WorkDoneProgressEndParams - deriving Eq - -instance A.FromJSON SomeProgressParams where - parseJSON x = - (Begin <$> A.parseJSON x) - <|> (Report <$> A.parseJSON x) - <|> (End <$> A.parseJSON x) - -instance A.ToJSON SomeProgressParams where - toJSON (Begin x) = A.toJSON x - toJSON (Report x) = A.toJSON x - toJSON (End x) = A.toJSON x - -- | Parameters for 'WorkDoneProgressBeginNotification'. -- -- @since 0.10.0.0 @@ -220,6 +195,14 @@ _workDoneToken :: Maybe ProgressToken } deriving (Read,Show,Eq) deriveJSON lspOptions ''WorkDoneProgressParams + +data SomeProgressParams + = Begin WorkDoneProgressBeginParams + | Report WorkDoneProgressReportParams + | End WorkDoneProgressEndParams + deriving Eq + +deriveJSON lspOptionsUntagged ''SomeProgressParams data PartialResultParams = PartialResultParams 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 @@ -3,14 +3,29 @@ module Language.LSP.Types.Rename where +import Data.Aeson import Data.Aeson.TH import Data.Text (Text) +import Data.Scientific (Scientific) import Language.LSP.Types.Location import Language.LSP.Types.TextDocument import Language.LSP.Types.Progress import Language.LSP.Types.Utils +data PrepareSupportDefaultBehavior = + PsIdentifier | + PsUnknown Scientific + deriving (Read, Show, Eq) + +instance ToJSON PrepareSupportDefaultBehavior where + toJSON PsIdentifier = Number 1 + toJSON (PsUnknown i) = Number i + +instance FromJSON PrepareSupportDefaultBehavior where + parseJSON (Number 1) = pure PsIdentifier + parseJSON _ = mempty + data RenameClientCapabilities = RenameClientCapabilities { -- | Whether rename supports dynamic registration. @@ -20,6 +35,21 @@ -- -- Since LSP 3.12.0 , _prepareSupport :: Maybe Bool + -- | Client supports the default behavior result + -- (`{ defaultBehavior: boolean }`). + -- + -- The value indicates the default behavior used by the client. + -- + -- @since 3.16.0 + , prepareSupportDefaultBehavior :: Maybe PrepareSupportDefaultBehavior + -- | Whether the client honors the change annotations in + -- text edits and resource operations returned via the + -- rename request's workspace edit by for example presenting + -- the workspace edit in the user interface and asking + -- for confirmation. + -- + -- @since 3.16.0 + , honorsChangeAnnotations :: Maybe Bool } deriving (Show, Read, Eq) deriveJSON lspOptions ''RenameClientCapabilities 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 @@ -12,6 +12,7 @@ import Language.LSP.Types.Progress import Language.LSP.Types.TextDocument import Language.LSP.Types.Utils +import Control.Applicative (Alternative((<|>))) -- ------------------------------------- @@ -33,6 +34,11 @@ _documentationFormat :: Maybe (List MarkupKind) -- | Client capabilities specific to parameter information. , _parameterInformation :: Maybe SignatureHelpParameterInformation + -- | The client supports the `activeParameter` property on + -- 'SignatureInformation' literal. + -- + -- @since 3.16.0 + , _activeParameterSuport :: Maybe Bool } deriving (Show, Read, Eq) @@ -72,38 +78,83 @@ -- ------------------------------------- +data SignatureHelpDoc = SignatureHelpDocString Text | SignatureHelpDocMarkup MarkupContent + deriving (Read,Show,Eq) + +deriveJSON lspOptionsUntagged ''SignatureHelpDoc + +-- ------------------------------------- + +data ParameterLabel = ParameterLabelString Text | ParameterLabelOffset Int Int + deriving (Read,Show,Eq) + +instance ToJSON ParameterLabel where + toJSON (ParameterLabelString t) = toJSON t + toJSON (ParameterLabelOffset l h) = toJSON [l, h] + +instance FromJSON ParameterLabel where + parseJSON x = ParameterLabelString <$> parseJSON x <|> parseInterval x + where + parseInterval v@(Array _) = do + is <- parseJSON v + case is of + [l, h] -> pure $ ParameterLabelOffset l h + _ -> mempty + parseInterval _ = mempty + +-- ------------------------------------- + +{-| +Represents a parameter of a callable-signature. A parameter can +have a label and a doc-comment. +-} data ParameterInformation = ParameterInformation - { _label :: Text - , _documentation :: Maybe Text + { _label :: ParameterLabel -- ^ The label of this parameter information. + , _documentation :: Maybe SignatureHelpDoc -- ^ The human-readable doc-comment of this parameter. } deriving (Read,Show,Eq) deriveJSON lspOptions ''ParameterInformation -- ------------------------------------- +{-| +Represents the signature of something callable. A signature +can have a label, like a function-name, a doc-comment, and +a set of parameters. +-} data SignatureInformation = SignatureInformation - { _label :: Text - , _documentation :: Maybe Text - , _parameters :: Maybe (List ParameterInformation) + { _label :: Text -- ^ The label of the signature. + , _documentation :: Maybe SignatureHelpDoc -- ^ The human-readable doc-comment of this signature. + , _parameters :: Maybe (List ParameterInformation) -- ^ The parameters of this signature. + , _activeParameter :: Maybe Int -- ^ The index of the active parameter. } deriving (Read,Show,Eq) deriveJSON lspOptions ''SignatureInformation + +{-| +Signature help represents the signature of something +callable. There can be multiple signature but only one +active and only one active parameter. +-} data SignatureHelp = SignatureHelp - { _signatures :: List SignatureInformation - , _activeSignature :: Maybe Int -- ^ The active signature - , _activeParameter :: Maybe Int -- ^ The active parameter of the active signature + { _signatures :: List SignatureInformation -- ^ One or more signatures. + , _activeSignature :: Maybe Int -- ^ The active signature. + , _activeParameter :: Maybe Int -- ^ The active parameter of the active signature. } deriving (Read,Show,Eq) deriveJSON lspOptions ''SignatureHelp -- ------------------------------------- -data SignatureHelpTriggerKind = SHTKInvoked - | SHTKTriggerCharacter - | SHTKContentChange +-- | How a signature help was triggered. +-- +-- @since 3.15.0 +data SignatureHelpTriggerKind = SHTKInvoked -- ^ Signature help was invoked manually by the user or by a command. + | SHTKTriggerCharacter -- ^ Signature help was triggered by a trigger character. + | SHTKContentChange -- ^ Signature help was triggered by the cursor moving or by the document content changing. deriving (Read,Show,Eq) instance ToJSON SignatureHelpTriggerKind where @@ -119,6 +170,8 @@ -- | Additional information about the context in which a signature help request -- was triggered. +-- +-- @since 3.15.0 data SignatureHelpContext = SignatureHelpContext { -- | Action that caused signature help to be 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 @@ -162,12 +162,12 @@ deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions -{-# DEPRECATED _rangeLength "Use _range instead" #-} data TextDocumentContentChangeEvent = TextDocumentContentChangeEvent { -- | The range of the document that changed. _range :: Maybe Range -- | The optional length of the range that got replaced. + -- Deprecated, use _range instead , _rangeLength :: Maybe Int -- | The new text for the provided range, if provided. -- Otherwise the new text of the whole document. 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 @@ -8,6 +8,7 @@ , makeRegHelper , makeExtendingDatatype , lspOptions + , lspOptionsUntagged ) where import Control.Monad @@ -115,4 +116,8 @@ modifier "_xdata" = "data" modifier "_xtype" = "type" modifier xs = drop 1 xs + +-- | Standard options for use when generating JSON instances for an untagged union +lspOptionsUntagged :: Options +lspOptionsUntagged = lspOptions { sumEncoding = UntaggedValue } 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 @@ -3,6 +3,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.LSP.Types.WorkspaceEdit where @@ -13,6 +14,7 @@ import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T +import Data.Hashable import Language.LSP.Types.Common import Language.LSP.Types.Location @@ -30,13 +32,47 @@ deriveJSON lspOptions ''TextEdit +-- --------------------------------------------------------------------- +{-| +Additional information that describes document changes. + +@since 3.16.0 +-} +data ChangeAnnotation = + ChangeAnnotation + { -- | A human-readable string describing the actual change. The string + -- is rendered prominent in the user interface. + _label :: Text + -- | A flag which indicates that user confirmation is needed + -- before applying the change. + , _needsConfirmation :: Maybe Bool + -- | A human-readable string which is rendered less prominent in + -- the user interface. + , _description :: Maybe Text + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ChangeAnnotation + +{-| +An identifier referring to a change annotation managed by a workspace +edit. + +@since 3.16.0 +-} +newtype ChangeAnnotationIdentifier = ChangeAnnotationIdentifierId Text + deriving (Show, Read, Eq, FromJSON, ToJSON, ToJSONKey, FromJSONKey, Hashable) + +makeExtendingDatatype "AnnotatedTextEdit" [''TextEdit] + [("_annotationId", [t| ChangeAnnotationIdentifier |]) ] +deriveJSON lspOptions ''AnnotatedTextEdit + -- --------------------------------------------------------------------- data TextDocumentEdit = TextDocumentEdit { _textDocument :: VersionedTextDocumentIdentifier - , _edits :: List TextEdit + , _edits :: List (TextEdit |? AnnotatedTextEdit) } deriving (Show, Read, Eq) deriveJSON lspOptions ''TextDocumentEdit @@ -61,6 +97,10 @@ _uri :: Uri -- | Additional options , _options :: Maybe CreateFileOptions + -- | An optional annotation identifer describing the operation. + -- + -- @since 3.16.0 + , _annotationId :: Maybe ChangeAnnotationIdentifier } deriving (Show, Read, Eq) instance ToJSON CreateFile where @@ -69,6 +109,7 @@ [ Just $ "kind" .= ("create" :: Text) , Just $ "uri" .= _uri , ("options" .=) <$> _options + , ("annotationId" .=) <$> _annotationId ] instance FromJSON CreateFile where @@ -78,6 +119,7 @@ $ fail $ "Expected kind \"create\" but got " ++ show kind _uri <- o .: "uri" _options <- o .:? "options" + _annotationId <- o .:? "annotationId" pure CreateFile{..} -- Rename file options @@ -100,6 +142,10 @@ , _newUri :: Uri -- | Rename options. , _options :: Maybe RenameFileOptions + -- | An optional annotation identifer describing the operation. + -- + -- @since 3.16.0 + , _annotationId :: Maybe ChangeAnnotationIdentifier } deriving (Show, Read, Eq) instance ToJSON RenameFile where @@ -109,6 +155,7 @@ , Just $ "oldUri" .= _oldUri , Just $ "newUri" .= _newUri , ("options" .=) <$> _options + , ("annotationId" .=) <$> _annotationId ] instance FromJSON RenameFile where @@ -119,6 +166,7 @@ _oldUri <- o .: "oldUri" _newUri <- o .: "newUri" _options <- o .:? "options" + _annotationId <- o .:? "annotationId" pure RenameFile{..} -- Delete file options @@ -139,6 +187,10 @@ _uri :: Uri -- | Delete options. , _options :: Maybe DeleteFileOptions + -- | An optional annotation identifer describing the operation. + -- + -- @since 3.16.0 + , _annotationId :: Maybe ChangeAnnotationIdentifier } deriving (Show, Read, Eq) instance ToJSON DeleteFile where @@ -147,6 +199,7 @@ [ Just $ "kind" .= ("delete" :: Text) , Just $ "uri" .= _uri , ("options" .=) <$> _options + , ("annotationId" .=) <$> _annotationId ] instance FromJSON DeleteFile where @@ -156,9 +209,9 @@ $ fail $ "Expected kind \"delete\" but got " ++ show kind _uri <- o .: "uri" _options <- o .:? "options" + _annotationId <- o .:? "annotationId" pure DeleteFile{..} - -- --------------------------------------------------------------------- -- | `TextDocumentEdit |? CreateFile |? RenameFile |? DeleteFile` is a bit mouthful, here's the synonym @@ -167,17 +220,42 @@ -- --------------------------------------------------------------------- type WorkspaceEditMap = H.HashMap Uri (List TextEdit) +type ChangeAnnotationMap = H.HashMap ChangeAnnotationIdentifier ChangeAnnotation data WorkspaceEdit = WorkspaceEdit - { _changes :: Maybe WorkspaceEditMap - , _documentChanges :: Maybe (List DocumentChange) + { + -- | Holds changes to existing resources. + _changes :: Maybe WorkspaceEditMap + -- | Depending on the client capability + -- `workspace.workspaceEdit.resourceOperations` document changes are either + -- an array of `TextDocumentEdit`s to express changes to n different text + -- documents where each text document edit addresses a specific version of + -- a text document. Or it can contain above `TextDocumentEdit`s mixed with + -- create, rename and delete file / folder operations. + -- + -- Whether a client supports versioned document edits is expressed via + -- `workspace.workspaceEdit.documentChanges` client capability. + -- + -- If a client neither supports `documentChanges` nor + -- `workspace.workspaceEdit.resourceOperations` then only plain `TextEdit`s + -- using the `changes` property are supported. + , _documentChanges :: Maybe (List DocumentChange) + -- | A map of change annotations that can be referenced in + -- `AnnotatedTextEdit`s or create, rename and delete file / folder + -- operations. + -- + -- Whether clients honor this property depends on the client capability + -- `workspace.changeAnnotationSupport`. + -- + -- @since 3.16.0 + , _changeAnnotations :: Maybe ChangeAnnotationMap } deriving (Show, Read, Eq) instance Semigroup WorkspaceEdit where - (WorkspaceEdit a b) <> (WorkspaceEdit c d) = WorkspaceEdit (a <> c) (b <> d) + (WorkspaceEdit a b c) <> (WorkspaceEdit a' b' c') = WorkspaceEdit (a <> a') (b <> b') (c <> c') instance Monoid WorkspaceEdit where - mempty = WorkspaceEdit Nothing Nothing + mempty = WorkspaceEdit Nothing Nothing Nothing deriveJSON lspOptions ''WorkspaceEdit @@ -220,6 +298,17 @@ parseJSON (String "undo") = pure FailureHandlingUndo parseJSON _ = mempty +data WorkspaceEditChangeAnnotationClientCapabilities = + WorkspaceEditChangeAnnotationClientCapabilities + { + -- | Whether the client groups edits with equal labels into tree nodes, + -- for instance all edits labelled with "Changes in Strings" would + -- be a tree node. + groupsOnLabel :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''WorkspaceEditChangeAnnotationClientCapabilities + data WorkspaceEditClientCapabilities = WorkspaceEditClientCapabilities { _documentChanges :: Maybe Bool -- ^The client supports versioned document @@ -230,6 +319,19 @@ -- | The failure handling strategy of a client if applying the workspace edit -- fails. , _failureHandling :: Maybe FailureHandlingKind + -- | Whether the client normalizes line endings to the client specific + -- setting. + -- + -- If set to `true` the client will normalize line ending characters + -- in a workspace edit to the client specific new line character(s). + -- + -- @since 3.16.0 + , _normalizesLineEndings :: Maybe Bool + -- | Whether the client in general supports change annotations on text edits, + -- create file, rename file and delete file changes. + -- + -- @since 3.16.0 + , _changeAnnotationSupport :: Maybe WorkspaceEditChangeAnnotationClientCapabilities } deriving (Show, Read, Eq) deriveJSON lspOptions ''WorkspaceEditClientCapabilities @@ -274,6 +376,9 @@ where splitAtPos :: Position -> Text -> (Text, Text) splitAtPos (Position sl sc) t = + -- If we are looking for a line beyond the end of the text, this will give us an index + -- past the end. Fortunately, T.splitAt is fine with this, and just gives us the whole + -- string and an empty string, which is what we want. let index = sc + startLineIndex sl t in T.splitAt index t @@ -282,7 +387,9 @@ startLineIndex line t' = case T.findIndex (== '\n') t' of Just i -> i + 1 + startLineIndex (line - 1) (T.drop (i + 1) t') - Nothing -> 0 + -- i != 0, and there are no newlines, so this is a line beyond the end of the text. + -- In this case give the "start index" as the end, so we will at least append the text. + Nothing -> T.length t' -- | 'editTextEdit' @outer@ @inner@ applies @inner@ to the text inside @outer@. editTextEdit :: TextEdit -> TextEdit -> TextEdit diff --git a/src/Language/LSP/Types/WorkspaceSymbol.hs b/src/Language/LSP/Types/WorkspaceSymbol.hs --- a/src/Language/LSP/Types/WorkspaceSymbol.hs +++ b/src/Language/LSP/Types/WorkspaceSymbol.hs @@ -26,6 +26,15 @@ deriveJSON lspOptions ''WorkspaceSymbolKindClientCapabilities +data WorkspaceSymbolTagClientCapabilities = + WorkspaceSymbolTagClientCapabilities + { -- | The tags supported by the client. + _valueSet :: Maybe (List SymbolTag) + } + deriving (Show, Read, Eq) + +deriveJSON lspOptions ''WorkspaceSymbolTagClientCapabilities + instance Default WorkspaceSymbolKindClientCapabilities where def = WorkspaceSymbolKindClientCapabilities (Just $ List allKinds) where allKinds = [ SkFile @@ -53,6 +62,11 @@ { _dynamicRegistration :: Maybe Bool -- ^Symbol request supports dynamic -- registration. , _symbolKind :: Maybe WorkspaceSymbolKindClientCapabilities -- ^ Specific capabilities for the `SymbolKind`. + -- | The client supports tags on `SymbolInformation`. + -- Clients supporting tags have to handle unknown tags gracefully. + -- + -- @since 3.16.0 + , _tagSupport :: Maybe WorkspaceSymbolTagClientCapabilities } deriving (Show, Read, Eq) deriveJSON lspOptions ''WorkspaceSymbolClientCapabilities diff --git a/src/Language/LSP/VFS.hs b/src/Language/LSP/VFS.hs --- a/src/Language/LSP/VFS.hs +++ b/src/Language/LSP/VFS.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} {-| Handles the "Language.LSP.Types.TextDocumentDidChange" \/ @@ -48,7 +49,7 @@ import Data.List import Data.Ord import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import Data.Maybe import Data.Rope.UTF16 ( Rope ) import qualified Data.Rope.UTF16 as Rope @@ -71,14 +72,14 @@ _lsp_version :: !Int -- ^ The LSP version of the document , _file_version :: !Int -- ^ This number is only incremented whilst the file -- remains in the map. - , _text :: Rope -- ^ The full contents of the document + , _text :: !Rope -- ^ The full contents of the document } deriving (Show) type VFSMap = Map.Map J.NormalizedUri VirtualFile -data VFS = VFS { vfsMap :: Map.Map J.NormalizedUri VirtualFile - , vfsTempDir :: FilePath -- ^ This is where all the temporary files will be written to +data VFS = VFS { vfsMap :: !(Map.Map J.NormalizedUri VirtualFile) + , vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to } deriving Show --- @@ -130,7 +131,7 @@ -- --------------------------------------------------------------------- applyCreateFile :: J.CreateFile -> VFS -> VFS -applyCreateFile (J.CreateFile uri options) = +applyCreateFile (J.CreateFile uri options _ann) = updateVFS $ Map.insertWith (\ new old -> if shouldOverwrite then new else old) (J.toNormalizedUri uri) @@ -150,7 +151,7 @@ Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyRenameFile :: J.RenameFile -> VFS -> VFS -applyRenameFile (J.RenameFile oldUri' newUri' options) vfs = +applyRenameFile (J.RenameFile oldUri' newUri' options _ann) vfs = let oldUri = J.toNormalizedUri oldUri' newUri = J.toNormalizedUri newUri' in case Map.lookup oldUri (vfsMap vfs) of @@ -178,7 +179,7 @@ -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory applyDeleteFile :: J.DeleteFile -> VFS -> VFS -applyDeleteFile (J.DeleteFile uri _options) = +applyDeleteFile (J.DeleteFile uri _options _ann) = updateVFS $ Map.delete (J.toNormalizedUri uri) @@ -186,7 +187,7 @@ applyTextDocumentEdit (J.TextDocumentEdit vid (J.List edits)) vfs = do -- all edits are supposed to be applied at once -- so apply from bottom up so they don't affect others - let sortedEdits = sortOn (Down . (^. J.range)) edits + let sortedEdits = sortOn (Down . editRange) edits changeEvents = map editToChangeEvent sortedEdits ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) notif = J.NotificationMessage "" J.STextDocumentDidChange ps @@ -194,9 +195,15 @@ mapM_ (debugM "haskell-lsp.applyTextDocumentEdit") ls return vfs' - where - editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text + where + editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range + editRange (J.InR e) = e ^. J.range + editRange (J.InL e) = e ^. J.range + editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent + editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) + editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) + applyDocumentChange :: J.DocumentChange -> VFS -> IO VFS applyDocumentChange (J.InL change) = applyTextDocumentEdit change applyDocumentChange (J.InR (J.InL change)) = return . applyCreateFile change @@ -207,7 +214,7 @@ changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do let J.ApplyWorkspaceEditParams _label edit = params - J.WorkspaceEdit mChanges mDocChanges = edit + J.WorkspaceEdit mChanges mDocChanges _anns = edit case mDocChanges of Just (J.List docChanges) -> applyDocumentChanges docChanges Nothing -> case mChanges of @@ -218,7 +225,7 @@ where changeToTextDocumentEdit acc uri edits = - acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits] + acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) (fmap J.InL edits)] applyDocumentChanges :: [J.DocumentChange] -> IO VFS applyDocumentChanges = foldM (flip applyDocumentChange) initVfs . sortOn project @@ -318,19 +325,19 @@ -- TODO:AZ:move this to somewhere sane -- | Describes the line at the current cursor position data PosPrefixInfo = PosPrefixInfo - { fullLine :: T.Text + { fullLine :: !T.Text -- ^ The full contents of the line the cursor is at - , prefixModule :: T.Text + , prefixModule :: !T.Text -- ^ If any, the module name that was typed right before the cursor position. -- For example, if the user has typed "Data.Maybe.from", then this property -- will be "Data.Maybe" - , prefixText :: T.Text + , prefixText :: !T.Text -- ^ The word right before the cursor position, after removing the module part. -- For example if the user has typed "Data.Maybe.from", -- then this property will be "from" - , cursorPos :: J.Position + , cursorPos :: !J.Position -- ^ The cursor position } deriving (Show,Eq)