Merge pull request #362 from michaelpj/mpj/more-caps

Add `window/showDocument` and some missing capabilities

Author: michaelpj

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'

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)) ()

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)

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

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
@@ -335,6 +342,8 @@ makeFieldsNoPrefix ''TypeDefinitionClientCapabilities
 makeFieldsNoPrefix ''ShowMessageParams
 makeFieldsNoPrefix ''MessageActionItem
 makeFieldsNoPrefix ''ShowMessageRequestParams
+makeFieldsNoPrefix ''ShowDocumentParams
+makeFieldsNoPrefix ''ShowDocumentResult
 makeFieldsNoPrefix ''LogMessageParams
 makeFieldsNoPrefix ''ProgressParams
 makeFieldsNoPrefix ''WorkDoneProgressBeginParams

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

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

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"

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

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

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 #-}

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