diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for lsp-test +## 0.17.0.0 + +- `ignoreRegistrationRequests` option to ignore `client/registerCapability` requests, on + by default. +- New functions `setIgnoringRegistrationRequests` to change whether such messages are + ignored during a `Session` without having to change the `SessionConfig`. +- `lsp-test` will no longer send `workspace/didChangConfiguration` notifications unless + the server dynamically registers for them. + ## 0.16.0.1 - Support newer versions of dependencies. diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -1,16 +1,21 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} module Main where +import Colog.Core import Colog.Core qualified as L import Control.Applicative.Combinators import Control.Exception import Control.Lens hiding (Iso, List) import Control.Monad import Control.Monad.IO.Class +import Data.Aeson qualified as J import Data.Maybe +import Data.Proxy +import Data.Set qualified as Set import Language.LSP.Protocol.Lens qualified as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -23,14 +28,138 @@ import UnliftIO import UnliftIO.Concurrent -main :: IO () -main = hspec $ do +runSessionWithServer :: + LogAction IO (WithSeverity LspServerLog) -> + ServerDefinition config -> + Test.SessionConfig -> + ClientCapabilities -> + FilePath -> + Test.Session a -> + IO a +runSessionWithServer logger defn testConfig caps root session = do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite defn + + res <- Test.runSessionWithHandles hinWrite houtRead testConfig caps root session + + timeout 3000000 $ do + Left (fromException -> Just ExitSuccess) <- waitCatch server + pure () + + pure res + +spec :: Spec +spec = do let logger = L.cmap show L.logStringStderr - describe "progress reporting" $ - it "sends end notification if thread is killed" $ do - (hinRead, hinWrite) <- createPipe - (houtRead, houtWrite) <- createPipe + describe "server-initiated progress reporting" $ do + it "sends updates" $ do + startBarrier <- newEmptyMVar + let definition = + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } + + handlers :: Handlers (LspM ()) + handlers = + requestHandler (SMethod_CustomMethod (Proxy @"something")) $ \_req resp -> void $ forkIO $ do + withProgress "Doing something" Nothing NotCancellable $ \updater -> do + takeMVar startBarrier + updater $ ProgressAmount (Just 25) (Just "step1") + updater $ ProgressAmount (Just 50) (Just "step2") + updater $ ProgressAmount (Just 75) (Just "step3") + + runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do + Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null + + -- Wait until we have seen a begin messsage. This means that the token setup + -- has happened and the server has been able to send us a begin message + skipManyTill Test.anyMessage $ do + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressBegin) x + + -- allow the hander to send us updates + putMVar startBarrier () + + do + u <- Test.message SMethod_Progress + liftIO $ do + u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1") + u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25) + + do + u <- Test.message SMethod_Progress + liftIO $ do + u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2") + u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50) + + do + u <- Test.message SMethod_Progress + liftIO $ do + u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3") + u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75) + + -- Then make sure we get a $/progress end notification + skipManyTill Test.anyMessage $ do + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressEnd) x + + it "handles cancellation" $ do + wasCancelled <- newMVar False + + let definition = + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } + + handlers :: Handlers (LspM ()) + handlers = + requestHandler (SMethod_CustomMethod (Proxy @"something")) $ \_req resp -> void $ forkIO $ do + -- Doesn't matter what cancellability we set here! + withProgress "Doing something" Nothing NotCancellable $ \updater -> do + -- Wait around to be cancelled, set the MVar only if we are + liftIO $ threadDelay (1 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True)) + + runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do + Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null + + -- Wait until we have created the progress so the updates will be sent individually + token <- skipManyTill Test.anyMessage $ do + x <- Test.message SMethod_WindowWorkDoneProgressCreate + pure $ x ^. L.params . L.token + + -- First make sure that we get a $/progress begin notification + skipManyTill Test.anyMessage $ do + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressBegin) x + + Test.sendNotification SMethod_WindowWorkDoneProgressCancel (WorkDoneProgressCancelParams token) + + -- Then make sure we still get a $/progress end notification + skipManyTill Test.anyMessage $ do + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressEnd) x + + c <- readMVar wasCancelled + c `shouldBe` True + + it "sends end notification if thread is killed" $ do killVar <- newEmptyMVar let definition = @@ -47,19 +176,13 @@ handlers :: MVar () -> Handlers (LspM ()) handlers killVar = - notificationHandler SMethod_Initialized $ \noti -> do - tid <- withRunInIO $ \runInIO -> - forkIO $ - runInIO $ - withProgress "Doing something" NotCancellable $ \updater -> - liftIO $ threadDelay (1 * 1000000) - liftIO $ void $ forkIO $ do - takeMVar killVar - killThread tid - - forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition + notificationHandler SMethod_Initialized $ \noti -> void $ + forkIO $ + withProgress "Doing something" Nothing NotCancellable $ \updater -> liftIO $ do + takeMVar killVar + Control.Exception.throwIO AsyncCancelled - Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do + runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do -- First make sure that we get a $/progress begin notification skipManyTill Test.anyMessage $ do x <- Test.message SMethod_Progress @@ -73,11 +196,61 @@ x <- Test.message SMethod_Progress guard $ has (L.params . L.value . _workDoneProgressEnd) x + describe "client-initiated progress reporting" $ do + it "sends updates" $ do + let definition = + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions{optSupportClientInitiatedProgress = True} + } + + handlers :: Handlers (LspM ()) + handlers = + requestHandler SMethod_TextDocumentCodeLens $ \req resp -> void $ forkIO $ do + withProgress "Doing something" (req ^. L.params . L.workDoneToken) NotCancellable $ \updater -> do + updater $ ProgressAmount (Just 25) (Just "step1") + updater $ ProgressAmount (Just 50) (Just "step2") + updater $ ProgressAmount (Just 75) (Just "step3") + + runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do + Test.sendRequest SMethod_TextDocumentCodeLens (CodeLensParams (Just $ ProgressToken $ InR "hello") Nothing (TextDocumentIdentifier $ Uri ".")) + + -- First make sure that we get a $/progress begin notification + skipManyTill Test.anyMessage $ do + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressBegin) x + + do + u <- Test.message SMethod_Progress + liftIO $ do + u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1") + u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25) + + do + u <- Test.message SMethod_Progress + liftIO $ do + u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2") + u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50) + + do + u <- Test.message SMethod_Progress + liftIO $ do + u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3") + u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75) + + -- Then make sure we get a $/progress end notification + skipManyTill Test.anyMessage $ do + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressEnd) x + describe "workspace folders" $ it "keeps track of open workspace folders" $ do - (hinRead, hinWrite) <- createPipe - (houtRead, houtWrite) <- createPipe - countVar <- newMVar 0 let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace" @@ -116,21 +289,16 @@ _ -> error "Shouldn't be here" ] - server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition - - let config = - Test.defaultConfig - { Test.initialWorkspaceFolders = Just [wf0] - } + let config = Test.defaultConfig{Test.initialWorkspaceFolders = Just [wf0]} changeFolders add rmv = let ev = WorkspaceFoldersChangeEvent add rmv ps = DidChangeWorkspaceFoldersParams ev in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps - Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do + runSessionWithServer logger definition config Test.fullCaps "." $ do changeFolders [wf1] [] changeFolders [wf2] [wf1] - Left e <- waitCatch server - fromException e `shouldBe` Just ExitSuccess +main :: IO () +main = hspec spec diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test -version: 0.16.0.1 +version: 0.17.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -33,8 +33,7 @@ library hs-source-dirs: src - default-language: Haskell2010 - default-extensions: ImportQualifiedPost + default-language: GHC2021 exposed-modules: Language.LSP.Test reexported-modules: lsp-types:Language.LSP.Protocol.Types @@ -43,37 +42,39 @@ , parser-combinators:Control.Applicative.Combinators build-depends: - , aeson - , aeson-pretty - , ansi-terminal - , async >=2.0 - , base >=4.10 && <5 - , bytestring - , co-log-core - , conduit - , conduit-parse ^>=0.2 - , containers >=0.5.9 - , data-default - , Diff >=0.3 - , directory - , exceptions - , filepath - , Glob >=0.9 && <0.11 - , lens - , lens-aeson - , lsp ^>=2.3 - , lsp-types ^>=2.1 - , mtl <2.4 - , parser-combinators >=1.2 - , process >=1.6 - , row-types - , some - , text - , time - , transformers + , aeson >=2 && <2.3 + , aeson-pretty ^>=0.8 + , ansi-terminal >=0.10 && <1.1 + , async ^>=2.2 + , base >=4.10 && <5 + , bytestring >=0.10 && <0.13 + , co-log-core ^>=0.3 + , conduit ^>=1.3 + , conduit-parse ^>=0.2 + , containers ^>=0.6 + , data-default ^>=0.7 + , Diff >=0.4 && <0.6 + , directory ^>=1.3 + , exceptions ^>=0.10 + , extra ^>=1.7 + , filepath >=1.4 && < 1.6 + , Glob >=0.9 && <0.11 + , lens >=5.1 && <5.3 + , lens-aeson ^>=1.2 + , lsp ^>=2.4 + , lsp-types ^>=2.1 + , mtl >=2.2 && <2.4 + , parser-combinators ^>=1.3 + , process ^>=1.6 + , row-types ^>=1.0 + , some ^>=1.0 + , text >=1 && <2.2 + , time >=1.10 && <1.13 + , transformers >=0.5 && <0.7 if os(windows) build-depends: Win32 + else build-depends: unix @@ -89,40 +90,40 @@ ghc-options: -W test-suite tests - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Test.hs - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - ghc-options: -W - other-modules: DummyServer + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + default-language: GHC2021 + ghc-options: -W + other-modules: DummyServer build-depends: , aeson - , base >=4.10 && <5 + , base , containers , data-default , directory + , extra , filepath , hspec , lens - , lsp ^>=2.3 + , lsp , lsp-test - , mtl <2.4 + , mtl , parser-combinators , process , text , unliftio - test-suite func-test - type: exitcode-stdio-1.0 - hs-source-dirs: func-test - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - main-is: FuncTest.hs + type: exitcode-stdio-1.0 + hs-source-dirs: func-test + default-language: GHC2021 + main-is: FuncTest.hs build-depends: , base + , aeson , co-log-core + , containers , hspec , lens , lsp @@ -131,30 +132,27 @@ , process , unliftio - test-suite example type: exitcode-stdio-1.0 hs-source-dirs: example - default-language: Haskell2010 - default-extensions: ImportQualifiedPost + default-language: GHC2021 main-is: Test.hs build-depends: , base , lsp-test , parser-combinators + build-tool-depends: lsp:lsp-demo-reactor-server benchmark simple-bench - type: exitcode-stdio-1.0 - hs-source-dirs: bench - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - main-is: SimpleBench.hs - ghc-options: -Wall -O2 -eventlog -rtsopts + type: exitcode-stdio-1.0 + hs-source-dirs: bench + default-language: GHC2021 + main-is: SimpleBench.hs + ghc-options: -Wall -O2 -eventlog -rtsopts build-depends: , base , extra , lsp , lsp-test , process - diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- a/src/Language/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -1,13 +1,8 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} {- | Module : Language.LSP.Test @@ -30,6 +25,7 @@ runSessionWithHandles', setIgnoringLogNotifications, setIgnoringConfigurationRequests, + setIgnoringRegistrationRequests, -- ** Config SessionConfig (..), @@ -149,8 +145,10 @@ import Control.Monad.State (execState) import Data.Aeson hiding (Null) import Data.Aeson qualified as J +import Data.Aeson.KeyMap qualified as J import Data.Default import Data.List +import Data.List.Extra (firstJust) import Data.Map.Strict qualified as Map import Data.Maybe import Data.Set qualified as Set @@ -481,6 +479,10 @@ setIgnoringConfigurationRequests value = do modify (\ss -> ss{ignoringConfigurationRequests = value}) +setIgnoringRegistrationRequests :: Bool -> Session () +setIgnoringRegistrationRequests value = do + modify (\ss -> ss{ignoringRegistrationRequests = value}) + {- | Modify the client config. This will send a notification to the server that the config has changed. -} @@ -490,12 +492,26 @@ let newConfig = f oldConfig modify (\ss -> ss{curLspConfig = newConfig}) - caps <- asks sessionCapabilities - let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just - -- TODO: make this configurable? - -- if they support workspace/configuration then be annoying and don't send the full config so - -- they have to request it - configToSend = if supportsConfiguration then J.Null else Object newConfig + -- We're going to be difficult and follow the new direction of the spec as much + -- as possible. That means _not_ sending didChangeConfiguration notifications + -- unless the server has registered for them + registeredCaps <- getRegisteredCapabilities + let + requestedSections :: Maybe [T.Text] + requestedSections = flip firstJust registeredCaps $ \(SomeRegistration (TRegistration _ regMethod regOpts)) -> + case regMethod of + SMethod_WorkspaceDidChangeConfiguration -> case regOpts of + Just (DidChangeConfigurationRegistrationOptions{_section = section}) -> case section of + Just (InL s) -> Just [s] + Just (InR ss) -> Just ss + Nothing -> Nothing + _ -> Nothing + _ -> Nothing + requestedSectionKeys :: Maybe [J.Key] + requestedSectionKeys = (fmap . fmap) (fromString . T.unpack) requestedSections + let configToSend = case requestedSectionKeys of + Just ss -> Object $ J.filterWithKey (\k _ -> k `elem` ss) newConfig + Nothing -> Object newConfig sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams configToSend {- | Set the client config. This will send a notification to the server that the @@ -753,7 +769,7 @@ let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) --- |Resolves the provided code action. +-- | Resolves the provided code action. resolveCodeAction :: CodeAction -> Session CodeAction resolveCodeAction ca = do rsp <- request SMethod_CodeActionResolve ca @@ -761,7 +777,7 @@ Right ca -> return ca Left er -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) er) -{- |If a code action contains a _data_ field: resolves the code action, then +{- | If a code action contains a _data_ field: resolves the code action, then executes it. Otherwise, just executes it. -} resolveAndExecuteCodeAction :: CodeAction -> Session () @@ -821,7 +837,7 @@ items <- getCompletions doc pos for items $ \item -> if isJust (item ^. L.data_) then resolveCompletion item else pure item --- |Resolves the provided completion item. +-- | Resolves the provided completion item. resolveCompletion :: CompletionItem -> Session CompletionItem resolveCompletion ci = do rsp <- request SMethod_CompletionItemResolve ci @@ -956,7 +972,7 @@ codeLenses <- getCodeLenses tId for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens --- |Resolves the provided code lens. +-- | Resolves the provided code lens. resolveCodeLens :: CodeLens -> Session CodeLens resolveCodeLens cl = do rsp <- request SMethod_CodeLensResolve cl @@ -985,7 +1001,7 @@ rsp <- request method params pure $ absorbNull $ getResponseResult rsp --- | Pass a param and return the response from `prepareCallHierarchy` +-- | Pass a param and return the response from `semanticTokensFull` getSemanticTokens :: TextDocumentIdentifier -> Session (SemanticTokens |? Null) getSemanticTokens doc = do let params = SemanticTokensParams Nothing Nothing doc diff --git a/src/Language/LSP/Test/Compat.hs b/src/Language/LSP/Test/Compat.hs --- a/src/Language/LSP/Test/Compat.hs +++ b/src/Language/LSP/Test/Compat.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -- For some reason ghc warns about not using -- Control.Monad.IO.Class but it's needed for -- MonadIO diff --git a/src/Language/LSP/Test/Files.hs b/src/Language/LSP/Test/Files.hs --- a/src/Language/LSP/Test/Files.hs +++ b/src/Language/LSP/Test/Files.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} module Language.LSP.Test.Files ( swapFiles, diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -1,9 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-} module Language.LSP.Test.Parsing ( diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- a/src/Language/LSP/Test/Session.hs +++ b/src/Language/LSP/Test/Session.hs @@ -3,15 +3,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} module Language.LSP.Test.Session ( Session(..) @@ -130,6 +123,9 @@ , ignoreConfigurationRequests :: Bool -- ^ Whether or not to ignore @workspace/configuration@ requests from the server, -- defaults to True. + , ignoreRegistrationRequests :: Bool + -- ^ Whether or not to ignore @client/registerCapability@ and @client/unregisterCapability@ + -- requests from the server, defaults to True. , initialWorkspaceFolders :: Maybe [WorkspaceFolder] -- ^ The initial workspace folders to send in the @initialize@ request. -- Defaults to Nothing. @@ -137,7 +133,7 @@ -- | The configuration used in 'Language.LSP.Test.runSession'. defaultConfig :: SessionConfig -defaultConfig = SessionConfig 60 False False True mempty True True Nothing +defaultConfig = SessionConfig 60 False False True mempty True True True Nothing instance Default SessionConfig where def = defaultConfig @@ -197,6 +193,7 @@ , curProgressSessions :: !(Set.Set ProgressToken) , ignoringLogNotifications :: Bool , ignoringConfigurationRequests :: Bool + , ignoringRegistrationRequests :: Bool } class Monad m => HasState s m where @@ -281,8 +278,27 @@ mainThreadId <- myThreadId - let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState = SessionState 0 emptyVFS mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config) + let context = SessionContext + serverIn + absRootDir + messageChan + timeoutIdVar + reqMap + initRsp + config + caps + initState = SessionState + 0 + emptyVFS + mempty + False + Nothing + mempty + (lspConfig config) + mempty + (ignoreLogNotifications config) + (ignoreConfigurationRequests config) + (ignoreRegistrationRequests config) runSession' = runSessionMonad context initState errorHandler = throwTo mainThreadId :: SessionException -> IO () @@ -330,12 +346,15 @@ let (errs, configs) = partitionEithers configsOrErrs -- we have to return exactly the number of sections requested, so if we can't find all of them then that's an error - if null errs - then sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right configs) - else sendMessage @_ @(TResponseError Method_WorkspaceConfiguration) $ - TResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing + sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) $ + if null errs + then (Right configs) + else Left $ ResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing _ -> pure () - unless ((ignoringLogNotifications state && isLogNotification msg) || (ignoringConfigurationRequests state && isConfigRequest msg)) $ + unless ( + (ignoringLogNotifications state && isLogNotification msg) + || (ignoringConfigurationRequests state && isConfigRequest msg) + || (ignoringRegistrationRequests state && isRegistrationRequest msg)) $ yield msg where @@ -347,6 +366,10 @@ isConfigRequest (FromServerMess SMethod_WorkspaceConfiguration _) = True isConfigRequest _ = False + + isRegistrationRequest (FromServerMess SMethod_ClientRegisterCapability _) = True + isRegistrationRequest (FromServerMess SMethod_ClientUnregisterCapability _) = True + isRegistrationRequest _ = False -- extract Uri out from DocumentChange -- didn't put this in `lsp-types` because TH was getting in the way diff --git a/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeInType #-} module DummyServer where @@ -124,7 +123,7 @@ (Just WatchKind_Create) ] Just token <- runInIO $ - registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ + registerCapability mempty SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti -> sendNotification SMethod_WindowLogMessage $ LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" @@ -139,7 +138,7 @@ (Just WatchKind_Create) ] Just token <- runInIO $ - registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ + registerCapability mempty SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti -> sendNotification SMethod_WindowLogMessage $ LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeInType #-} import Control.Applicative.Combinators @@ -14,11 +12,11 @@ import Data.Aeson qualified as J import Data.Default import Data.Either +import Data.List.Extra import Data.Map.Strict qualified as M import Data.Maybe import Data.Proxy import Data.Text qualified as T -import Data.Type.Equality import DummyServer import Language.LSP.Protocol.Lens qualified as L import Language.LSP.Protocol.Message @@ -370,25 +368,31 @@ void publishDiagnosticsNotification describe "dynamic capabilities" $ do - it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do + let config = def{ignoreLogNotifications = False} + it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout config fullCaps "." $ do loggingNotification -- initialized log message createDoc ".register" "haskell" "" + setIgnoringRegistrationRequests False message SMethod_ClientRegisterCapability doc <- createDoc "Foo.watch" "haskell" "" msg <- message SMethod_WindowLogMessage liftIO $ msg ^. L.params . L.message `shouldBe` "got workspace/didChangeWatchedFiles" - [SomeRegistration (TRegistration _ regMethod regOpts)] <- getRegisteredCapabilities - liftIO $ do - case regMethod `mEqClient` SMethod_WorkspaceDidChangeWatchedFiles of - Just (Right HRefl) -> - regOpts - `shouldBe` ( Just $ - DidChangeWatchedFilesRegistrationOptions - [FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create)] - ) - _ -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" + -- Look for the registration, we might have one for didChangeConfiguration in there too + registeredCaps <- getRegisteredCapabilities + let + regOpts :: Maybe DidChangeWatchedFilesRegistrationOptions + regOpts = flip firstJust registeredCaps $ \(SomeRegistration (TRegistration _ regMethod regOpts)) -> + case regMethod of + SMethod_WorkspaceDidChangeWatchedFiles -> regOpts + _ -> Nothing + liftIO $ + regOpts + `shouldBe` ( Just $ + DidChangeWatchedFilesRegistrationOptions + [FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create)] + ) -- now unregister it by sending a specific createDoc createDoc ".unregister" "haskell" "" @@ -398,10 +402,11 @@ void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing void $ anyResponse - it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "" $ do + it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout config fullCaps "" $ do loggingNotification -- initialized log message curDir <- liftIO $ getCurrentDirectory + setIgnoringRegistrationRequests False createDoc ".register.abs" "haskell" "" message SMethod_ClientRegisterCapability