From a8bb352f2a0172ed24b535406986e38375c9f689 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Sat, 30 Oct 2021 20:19:38 +0100 Subject: [PATCH 1/2] More capabilities --- .../src/Language/LSP/Types/Capabilities.hs | 13 ++- .../Language/LSP/Types/ClientCapabilities.hs | 108 +++++++++++++++++- lsp-types/src/Language/LSP/Types/Lens.hs | 7 ++ .../src/Language/LSP/Types/MarkupContent.hs | 9 ++ lsp/src/Language/LSP/Server/Core.hs | 6 +- lsp/test/CapabilitiesSpec.hs | 4 +- 6 files changed, 134 insertions(+), 13 deletions(-) diff --git a/lsp-types/src/Language/LSP/Types/Capabilities.hs b/lsp-types/src/Language/LSP/Types/Capabilities.hs index 2ddd05829..f20817ed2 100644 --- a/lsp-types/src/Language/LSP/Types/Capabilities.hs +++ b/lsp-types/src/Language/LSP/Types/Capabilities.hs @@ -35,7 +35,7 @@ data LSPVersion = LSPVersion Int Int -- ^ Construct a major.minor version -- * 3.4 extended completion item and symbol item kinds -- * 3.0 dynamic registration capsForVersion :: LSPVersion -> ClientCapabilities -capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Just window) Nothing +capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Just window) (since 3 16 general) Nothing where w = WorkspaceClientCapabilities (Just True) @@ -278,4 +278,13 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Jus | maj >= x && min >= y = Just a | otherwise = Nothing - window = WindowClientCapabilities (since 3 15 True) + window = + WindowClientCapabilities + (since 3 15 True) + (since 3 16 $ ShowMessageRequestClientCapabilities Nothing) + (since 3 16 $ ShowDocumentClientCapabilities True) + + general = GeneralClientCapabilities + (since 3 16 $ StaleRequestClientCapabilities True (List [])) + (since 3 16 $ RegularExpressionsClientCapabilities "" Nothing) + (since 3 16 $ MarkdownClientCapabilities "" Nothing) diff --git a/lsp-types/src/Language/LSP/Types/ClientCapabilities.hs b/lsp-types/src/Language/LSP/Types/ClientCapabilities.hs index ed427a3b8..7c1288959 100644 --- a/lsp-types/src/Language/LSP/Types/ClientCapabilities.hs +++ b/lsp-types/src/Language/LSP/Types/ClientCapabilities.hs @@ -6,6 +6,8 @@ module Language.LSP.Types.ClientCapabilities where import Data.Aeson.TH import qualified Data.Aeson as A import Data.Default +import Data.Text (Text) + import Language.LSP.Types.CallHierarchy import Language.LSP.Types.CodeAction import Language.LSP.Types.CodeLens @@ -34,6 +36,8 @@ import Language.LSP.Types.Utils import Language.LSP.Types.WatchedFiles import Language.LSP.Types.WorkspaceEdit import Language.LSP.Types.WorkspaceSymbol +import Language.LSP.Types.MarkupContent (MarkdownClientCapabilities) +import Language.LSP.Types.Common (List) data WorkspaceClientCapabilities = @@ -170,30 +174,122 @@ instance Default TextDocumentClientCapabilities where -- --------------------------------------------------------------------- +-- | Capabilities specific to the `MessageActionItem` type. +data MessageActionItemClientCapabilities = + MessageActionItemClientCapabilities + { + -- | Whether the client supports additional attributes which + -- are preserved and sent back to the server in the + -- request's response. + _additionalPropertiesSupport :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''MessageActionItemClientCapabilities + +-- | Show message request client capabilities +data ShowMessageRequestClientCapabilities = + ShowMessageRequestClientCapabilities + { -- | Capabilities specific to the `MessageActionItem` type. + _messageActionItem :: Maybe MessageActionItemClientCapabilities + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ShowMessageRequestClientCapabilities + +-- | Client capabilities for the show document request. +-- +-- @since 3.16.0 +data ShowDocumentClientCapabilities = + ShowDocumentClientCapabilities + { -- | The client has support for the show document request + _support :: Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ShowDocumentClientCapabilities + -- | Window specific client capabilities. data WindowClientCapabilities = WindowClientCapabilities { -- | Whether client supports handling progress notifications. + -- + -- @since 3.15.0 _workDoneProgress :: Maybe Bool + -- | Capabilities specific to the showMessage request + -- + -- @since 3.16.0 + , _showMessage :: Maybe ShowMessageRequestClientCapabilities + -- | Capabilities specific to the showDocument request + -- + -- @since 3.16.0 + , _showDocument :: Maybe ShowDocumentClientCapabilities } deriving (Show, Read, Eq) deriveJSON lspOptions ''WindowClientCapabilities instance Default WindowClientCapabilities where - def = WindowClientCapabilities def + def = WindowClientCapabilities def def def + +-- --------------------------------------------------------------------- + +-- | Client capability that signals how the client +-- handles stale requests (e.g. a request +-- for which the client will not process the response +-- anymore since the information is outdated). +-- @since 3.17.0 +data StaleRequestClientCapabilities = + StaleRequestClientCapabilities + { _cancel :: Bool + , _retryOnContentModified :: List Text + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''StaleRequestClientCapabilities + +-- | Client capabilities specific to the used markdown parser. +-- @since 3.16.0 +data RegularExpressionsClientCapabilities = + RegularExpressionsClientCapabilities + { _engine :: Text + , _version :: Maybe Text + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''RegularExpressionsClientCapabilities + +-- | General client capabilities. +-- @since 3.16.0 +data GeneralClientCapabilities = + GeneralClientCapabilities + { + _staleRequestSupport :: Maybe StaleRequestClientCapabilities + -- | Client capabilities specific to regular expressions. + -- @since 3.16.0 + , _regularExpressions :: Maybe RegularExpressionsClientCapabilities + -- | Client capabilities specific to the client's markdown parser. + -- @since 3.16.0 + , _markdown :: Maybe MarkdownClientCapabilities + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''GeneralClientCapabilities + +instance Default GeneralClientCapabilities where + def = GeneralClientCapabilities def def def + +-- --------------------------------------------------------------------- data ClientCapabilities = ClientCapabilities - { _workspace :: Maybe WorkspaceClientCapabilities + { -- | Workspace specific client capabilities + _workspace :: Maybe WorkspaceClientCapabilities + -- | Text document specific client capabilities , _textDocument :: Maybe TextDocumentClientCapabilities - -- | Capabilities specific to `window/progress` requests. Experimental. - -- - -- @since 0.10.0.0 + -- | Window specific client capabilities. , _window :: Maybe WindowClientCapabilities + -- | General client capabilities. + -- @since 3.16.0 + , _general :: Maybe GeneralClientCapabilities + -- | Experimental client capabilities. , _experimental :: Maybe A.Object } deriving (Show, Read, Eq) deriveJSON lspOptions ''ClientCapabilities instance Default ClientCapabilities where - def = ClientCapabilities def def def def + def = ClientCapabilities def def def def def diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index 7ac82ad4d..5d2bd0eb8 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/lsp-types/src/Language/LSP/Types/Lens.hs @@ -57,6 +57,12 @@ import Control.Lens.TH -- TODO: This is out of date and very unmantainable, use TH to call all these!! -- client capabilities +makeFieldsNoPrefix ''MessageActionItemClientCapabilities +makeFieldsNoPrefix ''ShowMessageRequestClientCapabilities +makeFieldsNoPrefix ''ShowDocumentClientCapabilities +makeFieldsNoPrefix ''StaleRequestClientCapabilities +makeFieldsNoPrefix ''RegularExpressionsClientCapabilities +makeFieldsNoPrefix ''GeneralClientCapabilities makeFieldsNoPrefix ''WorkspaceClientCapabilities makeFieldsNoPrefix ''WindowClientCapabilities makeFieldsNoPrefix ''ClientCapabilities @@ -115,6 +121,7 @@ makeFieldsNoPrefix ''LocationLink -- Markup makeFieldsNoPrefix ''MarkupContent +makeFieldsNoPrefix ''MarkdownClientCapabilities -- Completion makeFieldsNoPrefix ''CompletionDoc diff --git a/lsp-types/src/Language/LSP/Types/MarkupContent.hs b/lsp-types/src/Language/LSP/Types/MarkupContent.hs index 0a616e6d6..f4f1e40da 100644 --- a/lsp-types/src/Language/LSP/Types/MarkupContent.hs +++ b/lsp-types/src/Language/LSP/Types/MarkupContent.hs @@ -100,3 +100,12 @@ instance Monoid MarkupContent where -- --------------------------------------------------------------------- +-- | Client capabilities specific to the used markdown parser. +-- @since 3.16.0 +data MarkdownClientCapabilities = + MarkdownClientCapabilities + { _parser :: Text + , _version :: Maybe Text + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''MarkdownClientCapabilities diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index c934bced7..d76e7d54a 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -473,7 +473,7 @@ getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) getWorkspaceFolders = do clientCaps <- getClientCapabilities let clientSupportsWfs = fromMaybe False $ do - let (J.ClientCapabilities mw _ _ _) = clientCaps + let (J.ClientCapabilities mw _ _ _ _) = clientCaps (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _ _) <- mw mwf if clientSupportsWfs @@ -654,8 +654,8 @@ withProgressBase indefinite title cancellable f = do WorkDoneProgressReportParams Nothing msg percentage clientSupportsProgress :: J.ClientCapabilities -> Bool -clientSupportsProgress (J.ClientCapabilities _ _ wc _) = fromMaybe False $ do - (J.WindowClientCapabilities mProgress) <- wc +clientSupportsProgress (J.ClientCapabilities _ _ wc _ _) = fromMaybe False $ do + (J.WindowClientCapabilities mProgress _ _) <- wc mProgress {-# INLINE clientSupportsProgress #-} diff --git a/lsp/test/CapabilitiesSpec.hs b/lsp/test/CapabilitiesSpec.hs index 5b8e7558e..a91e23019 100644 --- a/lsp/test/CapabilitiesSpec.hs +++ b/lsp/test/CapabilitiesSpec.hs @@ -7,10 +7,10 @@ import Test.Hspec spec :: Spec spec = describe "capabilities" $ do it "gives 3.10 capabilities" $ - let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 10) + let ClientCapabilities _ (Just tdcs) _ _ _ = capsForVersion (LSPVersion 3 10) Just (DocumentSymbolClientCapabilities _ _ mHierarchical _ _ ) = _documentSymbol tdcs in mHierarchical `shouldBe` Just True it "gives pre 3.10 capabilities" $ - let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 9) + let ClientCapabilities _ (Just tdcs) _ _ _ = capsForVersion (LSPVersion 3 9) Just (DocumentSymbolClientCapabilities _ _ mHierarchical _ _) = _documentSymbol tdcs in mHierarchical `shouldBe` Nothing From 4980d1069dd35f3b482449e4bcfddd53b50ead26 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Sat, 30 Oct 2021 22:56:47 +0100 Subject: [PATCH 2/2] Add window/showDocument --- lsp-test/src/Language/LSP/Test/Parsing.hs | 1 + lsp-test/src/Language/LSP/Test/Session.hs | 1 + lsp-types/src/Language/LSP/Types/Lens.hs | 2 + lsp-types/src/Language/LSP/Types/Message.hs | 2 + lsp-types/src/Language/LSP/Types/Method.hs | 4 ++ lsp-types/src/Language/LSP/Types/Parsing.hs | 1 + lsp-types/src/Language/LSP/Types/Window.hs | 43 +++++++++++++++++++++ 7 files changed, 54 insertions(+) diff --git a/lsp-test/src/Language/LSP/Test/Parsing.hs b/lsp-test/src/Language/LSP/Test/Parsing.hs index 35544b4cb..43ac49fe5 100644 --- a/lsp-test/src/Language/LSP/Test/Parsing.hs +++ b/lsp-test/src/Language/LSP/Test/Parsing.hs @@ -198,6 +198,7 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip shouldSkip (FromServerMess SWindowLogMessage _) = True shouldSkip (FromServerMess SWindowShowMessage _) = True shouldSkip (FromServerMess SWindowShowMessageRequest _) = True + shouldSkip (FromServerMess SWindowShowDocument _) = True shouldSkip _ = False -- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index cc8932ee4..f5e4aaab8 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/lsp-test/src/Language/LSP/Test/Session.hs @@ -231,6 +231,7 @@ runSessionMonad context state (Session session) = runReaderT (runStateT conduit isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowShowDocument _)) = True isLogNotification _ = False watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index 5d2bd0eb8..32e6c08d3 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/lsp-types/src/Language/LSP/Types/Lens.hs @@ -342,6 +342,8 @@ makeFieldsNoPrefix ''TypeDefinitionClientCapabilities makeFieldsNoPrefix ''ShowMessageParams makeFieldsNoPrefix ''MessageActionItem makeFieldsNoPrefix ''ShowMessageRequestParams +makeFieldsNoPrefix ''ShowDocumentParams +makeFieldsNoPrefix ''ShowDocumentResult makeFieldsNoPrefix ''LogMessageParams makeFieldsNoPrefix ''ProgressParams makeFieldsNoPrefix ''WorkDoneProgressBeginParams diff --git a/lsp-types/src/Language/LSP/Types/Message.hs b/lsp-types/src/Language/LSP/Types/Message.hs index f3277c519..6460907a6 100644 --- a/lsp-types/src/Language/LSP/Types/Message.hs +++ b/lsp-types/src/Language/LSP/Types/Message.hs @@ -136,6 +136,7 @@ type family MessageParams (m :: Method f t) :: Type where -- Window MessageParams WindowShowMessage = ShowMessageParams MessageParams WindowShowMessageRequest = ShowMessageRequestParams + MessageParams WindowShowDocument = ShowDocumentParams MessageParams WindowLogMessage = LogMessageParams -- Progress MessageParams WindowWorkDoneProgressCreate = WorkDoneProgressCreateParams @@ -219,6 +220,7 @@ type family ResponseResult (m :: Method f Request) :: Type where -- Server -- Window ResponseResult WindowShowMessageRequest = Maybe MessageActionItem + ResponseResult WindowShowDocument = ShowDocumentResult ResponseResult WindowWorkDoneProgressCreate = Empty -- Capability ResponseResult ClientRegisterCapability = Empty diff --git a/lsp-types/src/Language/LSP/Types/Method.hs b/lsp-types/src/Language/LSP/Types/Method.hs index 7a215f64f..93b057482 100644 --- a/lsp-types/src/Language/LSP/Types/Method.hs +++ b/lsp-types/src/Language/LSP/Types/Method.hs @@ -90,6 +90,7 @@ data Method (f :: From) (t :: MethodType) where -- Window WindowShowMessage :: Method FromServer Notification WindowShowMessageRequest :: Method FromServer Request + WindowShowDocument :: Method FromServer Request WindowLogMessage :: Method FromServer Notification WindowWorkDoneProgressCancel :: Method FromClient Notification WindowWorkDoneProgressCreate :: Method FromServer Request @@ -167,6 +168,7 @@ data SMethod (m :: Method f t) where SWindowShowMessage :: SMethod WindowShowMessage SWindowShowMessageRequest :: SMethod WindowShowMessageRequest + SWindowShowDocument :: SMethod WindowShowDocument SWindowLogMessage :: SMethod WindowLogMessage SWindowWorkDoneProgressCreate :: SMethod WindowWorkDoneProgressCreate SWindowWorkDoneProgressCancel :: SMethod WindowWorkDoneProgressCancel @@ -307,6 +309,7 @@ instance A.FromJSON SomeServerMethod where -- Window parseJSON (A.String "window/showMessage") = pure $ SomeServerMethod SWindowShowMessage parseJSON (A.String "window/showMessageRequest") = pure $ SomeServerMethod SWindowShowMessageRequest + parseJSON (A.String "window/showDocument") = pure $ SomeServerMethod SWindowShowDocument parseJSON (A.String "window/logMessage") = pure $ SomeServerMethod SWindowLogMessage parseJSON (A.String "window/workDoneProgress/create") = pure $ SomeServerMethod SWindowWorkDoneProgressCreate parseJSON (A.String "$/progress") = pure $ SomeServerMethod SProgress @@ -400,6 +403,7 @@ instance A.ToJSON (SMethod m) where -- Window toJSON SWindowShowMessage = A.String "window/showMessage" toJSON SWindowShowMessageRequest = A.String "window/showMessageRequest" + toJSON SWindowShowDocument = A.String "window/showDocument" toJSON SWindowLogMessage = A.String "window/logMessage" toJSON SWindowWorkDoneProgressCreate = A.String "window/workDoneProgress/create" toJSON SProgress = A.String "$/progress" diff --git a/lsp-types/src/Language/LSP/Types/Parsing.hs b/lsp-types/src/Language/LSP/Types/Parsing.hs index b1f6ac755..fbe2fa041 100644 --- a/lsp-types/src/Language/LSP/Types/Parsing.hs +++ b/lsp-types/src/Language/LSP/Types/Parsing.hs @@ -267,6 +267,7 @@ splitClientMethod SCustomMethod{} = IsClientEither splitServerMethod :: SServerMethod m -> ServerNotOrReq m splitServerMethod SWindowShowMessage = IsServerNot splitServerMethod SWindowShowMessageRequest = IsServerReq +splitServerMethod SWindowShowDocument = IsServerReq splitServerMethod SWindowLogMessage = IsServerNot splitServerMethod SWindowWorkDoneProgressCreate = IsServerReq splitServerMethod SProgress = IsServerNot diff --git a/lsp-types/src/Language/LSP/Types/Window.hs b/lsp-types/src/Language/LSP/Types/Window.hs index 43f6acffe..eeb20862d 100644 --- a/lsp-types/src/Language/LSP/Types/Window.hs +++ b/lsp-types/src/Language/LSP/Types/Window.hs @@ -8,6 +8,8 @@ import qualified Data.Aeson as A import Data.Aeson.TH import Data.Text (Text) import Language.LSP.Types.Utils +import Language.LSP.Types.Uri +import Language.LSP.Types.Location -- --------------------------------------------------------------------- @@ -62,6 +64,47 @@ deriveJSON lspOptions ''ShowMessageRequestParams -- --------------------------------------------------------------------- +-- | Params to show a document. +-- +-- @since 3.16.0 +data ShowDocumentParams = + ShowDocumentParams { + -- | The document uri to show. + _uri :: Uri + + -- | Indicates to show the resource in an external program. + -- To show for example `https://code.visualstudio.com/` + -- in the default WEB browser set `external` to `true`. + , _external :: Maybe Bool + + -- | An optional property to indicate whether the editor + -- showing the document should take focus or not. + -- Clients might ignore this property if an external + -- program is started. + , _takeFocus :: Maybe Bool + + -- | An optional selection range if the document is a text + -- document. Clients might ignore the property if an + -- external program is started or the file is not a text + -- file. + , _selection :: Maybe Range + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ShowDocumentParams + +-- | The result of an show document request. +-- +-- @since 3.16.0 +data ShowDocumentResult = + ShowDocumentResult { + -- | A boolean indicating if the show was successful. + _success :: Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ShowDocumentResult + +-- --------------------------------------------------------------------- + data LogMessageParams = LogMessageParams { _xtype :: MessageType