lsp-test 0.16.0.1 → 0.17.0.0
raw patch · 10 files changed
+355/−144 lines, 10 filesdep ~Diffdep ~aesondep ~aeson-prettyPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Diff, aeson, aeson-pretty, ansi-terminal, async, base, bytestring, co-log-core, conduit, containers, data-default, directory, exceptions, extra, filepath, lens, lens-aeson, lsp, mtl, parser-combinators, process, row-types, some, text, time, transformers
API changes (from Hackage documentation)
+ Language.LSP.Test: [ignoreRegistrationRequests] :: SessionConfig -> Bool
+ Language.LSP.Test: setIgnoringRegistrationRequests :: Bool -> Session ()
- Language.LSP.Test: SessionConfig :: Int -> Bool -> Bool -> Bool -> Object -> Bool -> Bool -> Maybe [WorkspaceFolder] -> SessionConfig
+ Language.LSP.Test: SessionConfig :: Int -> Bool -> Bool -> Bool -> Object -> Bool -> Bool -> Bool -> Maybe [WorkspaceFolder] -> SessionConfig
Files
- ChangeLog.md +9/−0
- func-test/FuncTest.hs +199/−31
- lsp-test.cabal +55/−57
- src/Language/LSP/Test.hs +32/−16
- src/Language/LSP/Test/Compat.hs +0/−1
- src/Language/LSP/Test/Files.hs +0/−3
- src/Language/LSP/Test/Parsing.hs +0/−3
- src/Language/LSP/Test/Session.hs +38/−15
- test/DummyServer.hs +2/−3
- test/Test.hs +20/−15
ChangeLog.md view
@@ -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.
func-test/FuncTest.hs view
@@ -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
lsp-test.cabal view
@@ -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-
src/Language/LSP/Test.hs view
@@ -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
src/Language/LSP/Test/Compat.hs view
@@ -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
src/Language/LSP/Test/Files.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-} module Language.LSP.Test.Files ( swapFiles,
src/Language/LSP/Test/Parsing.hs view
@@ -1,9 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-} module Language.LSP.Test.Parsing (
src/Language/LSP/Test/Session.hs view
@@ -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
test/DummyServer.hs view
@@ -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"
test/Test.hs view
@@ -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