Merge pull request #518 from haskell/mpj/caps

Fill in remaining capabilities and dynamic registration options
haskell · Aug 26, 2023 · 1c40fbf · 1c40fbf
2 parents 6ed8fe8 + d8fcd36
commit 1c40fbf
Show file tree

Hide file tree

Showing 5 changed files with 120 additions and 87 deletions.
diff --git a/lsp-types/ChangeLog.md b/lsp-types/ChangeLog.md
@@ -1,5 +1,10 @@
 # Revision history for lsp-types
 
+## Unreleased
+
+- Add `dynamicRegistrationSupported` to `Capabilities`.
+- Fully update `fullCaps` for recent spec versions.
+
 ## 2.0.2.0
 
 - Add `Language.LSP.Protocol.Utils.Misc.prettyJSON :: Value -> Doc ann` for prettyprinting JSON, 

diff --git a/lsp-types/src/Language/LSP/Protocol/Capabilities.hs b/lsp-types/src/Language/LSP/Protocol/Capabilities.hs
@@ -1,42 +1,38 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedLabels      #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
 module Language.LSP.Protocol.Capabilities
   (
     fullCaps
   , LSPVersion(..)
   , capsForVersion
+  , dynamicRegistrationSupported
   ) where
 
+import           Control.Lens
 import           Data.Row
 import qualified Data.Set                          as Set
+import           Data.Maybe
 import           Language.LSP.Protocol.Types
+import           Language.LSP.Protocol.Message
+import qualified Language.LSP.Protocol.Lens as L
 import           Prelude                           hiding (min)
 
 {-
 TODO: this is out-of-date/needs an audit
 TODO: can we generate this? process the 'since' annotations in the metamodel?
 -}
 
--- | Capabilities for full conformance to the current (v3.15) LSP specification.
+-- | Capabilities for full conformance to the current LSP specification.
 fullCaps :: ClientCapabilities
 fullCaps = capsForVersion (LSPVersion maxBound maxBound)
 
 -- | A specific version of the LSP specification.
-data LSPVersion = LSPVersion Int Int -- ^ Construct a major.minor version
+data LSPVersion = LSPVersion Int Int
 
 -- | Capabilities for full conformance to the LSP specification up until a version.
--- Some important milestones:
---
--- * 3.12 textDocument/prepareRename request
--- * 3.11 CodeActionOptions provided by the server
--- * 3.10 hierarchical document symbols, folding ranges
--- * 3.9 completion item preselect
--- * 3.8 codeAction literals
--- * 3.7 related information in diagnostics
--- * 3.6 workspace folders, colors, goto type/implementation
--- * 3.4 extended completion item and symbol item kinds
--- * 3.0 dynamic registration
 capsForVersion :: LSPVersion -> ClientCapabilities
 capsForVersion (LSPVersion maj min) = caps
   where
@@ -45,9 +41,8 @@ capsForVersion (LSPVersion maj min) = caps
       , _textDocument=Just td
       , _window=Just window
       , _general=since 3 16 general
+      , _notebookDocument=since 3 17 $ NotebookDocumentClientCapabilities $ NotebookDocumentSyncClientCapabilities dynamicReg (Just True)
       , _experimental=Nothing
-      -- TODO
-      , _notebookDocument=Nothing
       }
     w = WorkspaceClientCapabilities {
       _applyEdit = Just True
@@ -61,15 +56,14 @@ capsForVersion (LSPVersion maj min) = caps
       , _didChangeWatchedFiles = Just (DidChangeWatchedFilesClientCapabilities dynamicReg (Just True))
       , _symbol = Just symbolCapabilities
       , _executeCommand = Just (ExecuteCommandClientCapabilities dynamicReg)
+      , _codeLens = Just (CodeLensWorkspaceClientCapabilities $ Just True)
       , _workspaceFolders = since 3 6 True
       , _configuration = since 3 6 True
       , _semanticTokens = since 3 16 (SemanticTokensWorkspaceClientCapabilities $ Just True)
-      , _inlayHint = since 3 17 inlayHint
-      -- TODO
-      , _codeLens = Nothing
-      , _fileOperations = Nothing
-      , _inlineValue = Nothing
-      , _diagnostics = Nothing
+      , _inlayHint = since 3 17 (InlayHintWorkspaceClientCapabilities $ Just True)
+      , _fileOperations = since 3 16 fileOperations
+      , _inlineValue = since 3 17 (InlineValueWorkspaceClientCapabilities $ Just True)
+      , _diagnostics = since 3 17 (DiagnosticWorkspaceClientCapabilities $ Just True)
       }
 
     resourceOperations =
@@ -78,6 +72,15 @@ capsForVersion (LSPVersion maj min) = caps
       , ResourceOperationKind_Rename
       ]
 
+    fileOperations = FileOperationClientCapabilities
+      dynamicReg
+      (Just True)
+      (Just True)
+      (Just True)
+      (Just True)
+      (Just True)
+      (Just True)
+
     symbolCapabilities = WorkspaceSymbolClientCapabilities
       dynamicReg
       (since 3 4 (#valueSet .== Just sKs))
@@ -158,13 +161,12 @@ capsForVersion (LSPVersion maj min) = caps
           , _selectionRange=since 3 5 (SelectionRangeClientCapabilities dynamicReg)
           , _callHierarchy=since 3 16 (CallHierarchyClientCapabilities dynamicReg)
           , _semanticTokens=since 3 16 semanticTokensCapabilities
+          , _linkedEditingRange=since 3 16 (LinkedEditingRangeClientCapabilities dynamicReg)
+          , _moniker=since 3 16 (MonikerClientCapabilities dynamicReg)
           , _inlayHint=since 3 17 inlayHintCapabilities
-          -- TODO
-          , _linkedEditingRange=Nothing
-          , _moniker=Nothing
-          , _typeHierarchy=Nothing
-          , _inlineValue=Nothing
-          , _diagnostic=Nothing
+          , _typeHierarchy=since 3 17 (TypeHierarchyClientCapabilities dynamicReg)
+          , _inlineValue=since 3 17 (InlineValueClientCapabilities dynamicReg)
+          , _diagnostic=since 3 17 (DiagnosticClientCapabilities dynamicReg (Just True))
         }
 
     sync =
@@ -184,16 +186,11 @@ capsForVersion (LSPVersion maj min) = caps
         , _contextSupport=since 3 3 True
         , _completionList=since 3 17 (#itemDefaults .== Just [])
         }
-
-    inlayHint =
-      InlayHintWorkspaceClientCapabilities{
-        _refreshSupport=since 3 17 True
-      }
-
+
     inlayHintCapabilities =
       InlayHintClientCapabilities{
         _dynamicRegistration=dynamicReg,
-        _resolveSupport= since 3 17 (#properties .== [])
+        _resolveSupport=Just (#properties .== [])
       }
 
     completionItemCapabilities =
@@ -312,8 +309,63 @@ capsForVersion (LSPVersion maj min) = caps
       _staleRequestSupport=since 3 16 (#cancel .== True .+ #retryOnContentModified .== [])
       , _regularExpressions=since 3 16 $ RegularExpressionsClientCapabilities "" Nothing
       , _markdown=since 3 16 $ MarkdownClientCapabilities "" Nothing (Just [])
-      -- TODO
-      , _positionEncodings=Nothing
+      , _positionEncodings=since 3 17 [PositionEncodingKind_UTF16]
       }
 
     allMarkups = [MarkupKind_PlainText, MarkupKind_Markdown]
+
+-- | Whether the client supports dynamic registration for the given method.
+dynamicRegistrationSupported :: SMethod m -> ClientCapabilities -> Bool
+dynamicRegistrationSupported method caps = fromMaybe False $ case method of
+  SMethod_WorkspaceDidChangeConfiguration  -> caps ^? ws . L.didChangeConfiguration . _Just . dyn
+  SMethod_WorkspaceDidChangeWatchedFiles   -> caps ^? ws . L.didChangeWatchedFiles . _Just . dyn
+  SMethod_WorkspaceSymbol                  -> caps ^? ws . L.symbol . _Just . dyn
+  SMethod_WorkspaceExecuteCommand          -> caps ^? ws . L.executeCommand . _Just . dyn
+  SMethod_WorkspaceWillCreateFiles         -> caps ^? ws . L.fileOperations . _Just . dyn
+  SMethod_WorkspaceDidCreateFiles          -> caps ^? ws . L.fileOperations . _Just . dyn
+  SMethod_WorkspaceWillDeleteFiles         -> caps ^? ws . L.fileOperations . _Just . dyn
+  SMethod_WorkspaceDidDeleteFiles          -> caps ^? ws . L.fileOperations . _Just . dyn
+  SMethod_TextDocumentDidOpen              -> caps ^? td . L.synchronization . _Just . dyn
+  SMethod_TextDocumentDidChange            -> caps ^? td . L.synchronization . _Just . dyn
+  SMethod_TextDocumentDidClose             -> caps ^? td . L.synchronization . _Just . dyn
+  SMethod_TextDocumentCompletion           -> caps ^? td . L.completion . _Just . dyn
+  SMethod_TextDocumentHover                -> caps ^? td . L.hover . _Just . dyn
+  SMethod_TextDocumentSignatureHelp        -> caps ^? td . L.signatureHelp . _Just . dyn
+  SMethod_TextDocumentDeclaration          -> caps ^? td . L.declaration . _Just . dyn
+  SMethod_TextDocumentDefinition           -> caps ^? td . L.definition . _Just . dyn
+  SMethod_TextDocumentTypeDefinition       -> caps ^? td . L.typeDefinition . _Just . dyn
+  SMethod_TextDocumentImplementation       -> caps ^? td . L.implementation . _Just . dyn
+  SMethod_TextDocumentReferences           -> caps ^? td . L.references . _Just . dyn
+  SMethod_TextDocumentDocumentHighlight    -> caps ^? td . L.documentHighlight . _Just . dyn
+  SMethod_TextDocumentDocumentSymbol       -> caps ^? td . L.documentSymbol . _Just . dyn
+  SMethod_TextDocumentCodeAction           -> caps ^? td . L.codeAction . _Just . dyn
+  SMethod_TextDocumentCodeLens             -> caps ^? td . L.codeLens . _Just . dyn
+  SMethod_TextDocumentDocumentLink         -> caps ^? td . L.documentLink . _Just . dyn
+  SMethod_TextDocumentDocumentColor        -> caps ^? td . L.colorProvider . _Just . dyn
+  SMethod_TextDocumentColorPresentation    -> caps ^? td . L.colorProvider . _Just . dyn
+  SMethod_TextDocumentFormatting           -> caps ^? td . L.formatting . _Just . dyn
+  SMethod_TextDocumentRangeFormatting      -> caps ^? td . L.rangeFormatting . _Just . dyn
+  SMethod_TextDocumentOnTypeFormatting     -> caps ^? td . L.onTypeFormatting . _Just . dyn
+  SMethod_TextDocumentRename               -> caps ^? td . L.rename . _Just . dyn
+  SMethod_TextDocumentFoldingRange         -> caps ^? td . L.foldingRange . _Just . dyn
+  SMethod_TextDocumentSelectionRange       -> caps ^? td . L.selectionRange . _Just . dyn
+  SMethod_TextDocumentLinkedEditingRange   -> caps ^? td . L.linkedEditingRange . _Just . dyn
+  SMethod_TextDocumentPrepareCallHierarchy -> caps ^? td . L.callHierarchy . _Just . dyn
+  SMethod_TextDocumentInlayHint            -> caps ^? td . L.inlayHint . _Just . dyn
+  SMethod_TextDocumentInlineValue          -> caps ^? td . L.inlineValue . _Just . dyn
+  SMethod_TextDocumentMoniker              -> caps ^? td . L.moniker . _Just . dyn
+  SMethod_TextDocumentPrepareTypeHierarchy -> caps ^? td . L.typeHierarchy . _Just . dyn
+  SMethod_TextDocumentDiagnostic           -> caps ^? td . L.diagnostic . _Just . dyn
+  -- semantic tokens is messed up due to it having you register with an otherwise non-existent method
+  --SMethod_TextDocumentSemanticTokens       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.semanticTokens . _Just
+  -- Notebook document methods alway support dynamic registration, it seems?
+  _                                        -> Just False
+  where
+    td :: Traversal' ClientCapabilities TextDocumentClientCapabilities
+    td = L.textDocument . _Just
+
+    ws :: Traversal' ClientCapabilities WorkspaceClientCapabilities
+    ws = L.workspace . _Just
+
+    dyn :: L.HasDynamicRegistration a (Maybe Bool) => Traversal' a Bool
+    dyn = L.dynamicRegistration . _Just
diff --git a/lsp/ChangeLog.md b/lsp/ChangeLog.md
@@ -1,5 +1,9 @@
 # Revision history for lsp
 
+## Unreleased
+
+- Fix inference of server capabilities for newer methods (except notebook methods).
+
 ## 2.2.0.0
 
 - Many changes relating to client configuration

diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs
@@ -54,6 +54,7 @@ import           Data.Text                              (Text)
 import qualified Data.Text                              as T
 import qualified Data.UUID                              as UUID
 import           Language.LSP.Diagnostics
+import           Language.LSP.Protocol.Capabilities
 import qualified Language.LSP.Protocol.Lens             as L
 import           Language.LSP.Protocol.Message
 import qualified Language.LSP.Protocol.Message          as L
@@ -551,7 +552,7 @@ registerCapability method regOpts f = do
     go _clientCaps True = pure Nothing
     go clientCaps  False
       -- First, check to see if the client supports dynamic registration on this method
-      | dynamicSupported clientCaps = do
+      | dynamicRegistrationSupported method clientCaps = do
           uuid <- liftIO $ UUID.toText <$> getStdRandom random
           let registration = L.TRegistration uuid method (Just regOpts)
               params = L.RegistrationParams [toUntypedRegistration registration]
@@ -572,47 +573,6 @@ registerCapability method regOpts f = do
           pure (Just (RegistrationToken method regId))
       | otherwise        = pure Nothing
 
-    -- Also I'm thinking we should move this function to somewhere in messages.hs so
-    -- we don't forget to update it when adding new methods...
-    capDyn :: L.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool
-    capDyn (Just x) = fromMaybe False $ x ^. L.dynamicRegistration
-    capDyn Nothing  = False
-
-    -- | Checks if client capabilities declares that the method supports dynamic registration
-    dynamicSupported clientCaps = case method of
-      SMethod_WorkspaceDidChangeConfiguration  -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeConfiguration . _Just
-      SMethod_WorkspaceDidChangeWatchedFiles   -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just
-      SMethod_WorkspaceSymbol                  -> capDyn $ clientCaps ^? L.workspace . _Just . L.symbol . _Just
-      SMethod_WorkspaceExecuteCommand          -> capDyn $ clientCaps ^? L.workspace . _Just . L.executeCommand . _Just
-      SMethod_TextDocumentDidOpen              -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just
-      SMethod_TextDocumentDidChange            -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just
-      SMethod_TextDocumentDidClose             -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just
-      SMethod_TextDocumentCompletion           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.completion . _Just
-      SMethod_TextDocumentHover                -> capDyn $ clientCaps ^? L.textDocument . _Just . L.hover . _Just
-      SMethod_TextDocumentSignatureHelp        -> capDyn $ clientCaps ^? L.textDocument . _Just . L.signatureHelp . _Just
-      SMethod_TextDocumentDeclaration          -> capDyn $ clientCaps ^? L.textDocument . _Just . L.declaration . _Just
-      SMethod_TextDocumentDefinition           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.definition . _Just
-      SMethod_TextDocumentTypeDefinition       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.typeDefinition . _Just
-      SMethod_TextDocumentImplementation       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.implementation . _Just
-      SMethod_TextDocumentReferences           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.references . _Just
-      SMethod_TextDocumentDocumentHighlight    -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentHighlight . _Just
-      SMethod_TextDocumentDocumentSymbol       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentSymbol . _Just
-      SMethod_TextDocumentCodeAction           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeAction . _Just
-      SMethod_TextDocumentCodeLens             -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeLens . _Just
-      SMethod_TextDocumentDocumentLink         -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentLink . _Just
-      SMethod_TextDocumentDocumentColor        -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just
-      SMethod_TextDocumentColorPresentation    -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just
-      SMethod_TextDocumentFormatting           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.formatting . _Just
-      SMethod_TextDocumentRangeFormatting      -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rangeFormatting . _Just
-      SMethod_TextDocumentOnTypeFormatting     -> capDyn $ clientCaps ^? L.textDocument . _Just . L.onTypeFormatting . _Just
-      SMethod_TextDocumentRename               -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rename . _Just
-      SMethod_TextDocumentFoldingRange         -> capDyn $ clientCaps ^? L.textDocument . _Just . L.foldingRange . _Just
-      SMethod_TextDocumentSelectionRange       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.selectionRange . _Just
-      SMethod_TextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? L.textDocument . _Just . L.callHierarchy . _Just
-      SMethod_TextDocumentInlayHint            -> capDyn $ clientCaps ^? L.textDocument . _Just . L.inlayHint . _Just
-      --SMethod_TextDocumentSemanticTokens       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.semanticTokens . _Just
-      _                                        -> False
-
 -- | Sends a @client/unregisterCapability@ request and removes the handler
 -- for that associated registration.
 unregisterCapability :: MonadLsp config f => RegistrationToken m -> f ()

diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs
@@ -220,16 +220,20 @@ inferServerCapabilities clientCaps o h =
     , _semanticTokensProvider           = semanticTokensProvider
     , _workspaceSymbolProvider          = supportedBool SMethod_WorkspaceSymbol
     , _workspace                        = Just workspace
-    -- TODO: Add something for experimental
     , _experimental                     = Nothing :: Maybe Value
-    -- TODO
-    , _positionEncoding  = Nothing
-    , _notebookDocumentSync  = Nothing
-    , _linkedEditingRangeProvider  = Nothing
-    , _monikerProvider  = Nothing
-    , _typeHierarchyProvider  = Nothing
-    , _inlineValueProvider  = Nothing
-    , _diagnosticProvider  = Nothing
+    -- The only encoding the VFS supports is the legacy UTF16 option at the moment
+    , _positionEncoding                 = Just PositionEncodingKind_UTF16
+    , _linkedEditingRangeProvider       = supported' SMethod_TextDocumentLinkedEditingRange $
+                                              InR $ InL $ LinkedEditingRangeOptions { _workDoneProgress=Nothing }
+    , _monikerProvider                  = supported' SMethod_TextDocumentMoniker $
+                                              InR $ InL $ MonikerOptions { _workDoneProgress=Nothing }
+    , _typeHierarchyProvider            = supported' SMethod_TextDocumentPrepareTypeHierarchy $
+                                              InR $ InL $ TypeHierarchyOptions { _workDoneProgress=Nothing }
+    , _inlineValueProvider              = supported' SMethod_TextDocumentInlineValue $
+                                              InR $ InL $ InlineValueOptions { _workDoneProgress=Nothing }
+    , _diagnosticProvider               = diagnosticProvider
+    -- TODO: super unclear what to do about notebooks in general
+    , _notebookDocumentSync             = Nothing
     }
   where
 
@@ -343,6 +347,14 @@ inferServerCapabilities clientCaps o h =
         -- sign up to receive notifications
         WorkspaceFoldersServerCapabilities (Just True) (Just (InR True))
 
+    diagnosticProvider = supported' SMethod_TextDocumentDiagnostic $ InL $ DiagnosticOptions
+      { _workDoneProgress=Nothing
+      , _identifier=Nothing
+      -- TODO: this is a conservative but maybe inaccurate, unclear how much it matters
+      , _interFileDependencies=True
+      , _workspaceDiagnostics=supported_b SMethod_WorkspaceDiagnostic
+      }
+
 -- | Invokes the registered dynamic or static handlers for the given message and
 -- method, as well as doing some bookkeeping.
 handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m ()