lsp-test 0.16.0.1 → 0.18.0.0
raw patch · 15 files changed
Files
- ChangeLog.md +34/−1
- README.md +2/−2
- bench/SimpleBench.hs +1/−2
- example/Test.hs +2/−1
- func-test/FuncTest.hs +224/−32
- lsp-test.cabal +64/−58
- src/Language/LSP/Test.hs +120/−49
- src/Language/LSP/Test/Compat.hs +5/−7
- src/Language/LSP/Test/Decoding.hs +2/−3
- src/Language/LSP/Test/Exceptions.hs +1/−2
- src/Language/LSP/Test/Files.hs +4/−12
- src/Language/LSP/Test/Parsing.hs +1/−4
- src/Language/LSP/Test/Session.hs +55/−31
- test/DummyServer.hs +32/−5
- test/Test.hs +78/−57
ChangeLog.md view
@@ -1,5 +1,38 @@ # Revision history for lsp-test +## 0.18.0.0 -- 2026-02-14++- Add a context parameter for getSignatureHelp+- Add signature help request+- Add workspace symbol request+- Relax dependency version bounds+- Expose resolveCompletion helper++## 0.17.1.1 -- 2024-12-31++- Relax dependency version bounds++## 0.17.1.0 -- 2024-06-06++- Add helpers for testing inlay hints.++## 0.17.0.2++- Support for newer versions of dependencies.++## 0.17.0.1++- Support for newer versions of dependencies.++## 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.@@ -35,7 +68,7 @@ * Compatibility with new `lsp-types` major version. -## 0.14.0.2 +## 0.14.0.2 * Compatibility with new `lsp-types` major version.
README.md view
@@ -8,7 +8,7 @@ ```haskell import Language.LSP.Test-main = runSession "hie" fullCaps "proj/dir" $ do+main = runSession "hie" fullLatestClientCaps "proj/dir" $ do doc <- openDoc "Foo.hs" "haskell" skipMany anyNotification symbols <- getDocumentSymbols doc@@ -19,7 +19,7 @@ ### Unit tests with HSpec ```haskell describe "diagnostics" $- it "report errors" $ runSession "hie" fullCaps "test/data" $ do+ it "report errors" $ runSession "hie" fullLatestClientCaps "test/data" $ do openDoc "Error.hs" "haskell" [diag] <- waitForDiagnosticsSource "ghcmod" liftIO $ do
bench/SimpleBench.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} module Main where @@ -57,7 +56,7 @@ i <- newIORef (0 :: Integer) - Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do+ Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullLatestClientCaps "." $ do start <- liftIO offsetTime replicateM_ n $ do v <- liftIO $ readIORef i
example/Test.hs view
@@ -6,7 +6,8 @@ import Language.LSP.Protocol.Types import Language.LSP.Test -main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do+main :: IO ()+main = runSession "lsp-demo-reactor-server" fullLatestClientCaps "test/data/" $ do doc <- openDoc "Rename.hs" "haskell" -- Use your favourite favourite combinators.
func-test/FuncTest.hs view
@@ -1,36 +1,175 @@+{-# 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.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier) 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 Language.LSP.Protocol.Lens qualified as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.Test qualified as Test import System.Exit-import System.IO import System.Process import Test.Hspec 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 $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite defn++ res <- Test.runSessionWithHandles hinWrite houtRead testConfig caps root session++ timeout 3000000 $ do+ return_code <- wait server+ case return_code of+ 0 -> pure ()+ _ -> error $ "Server exited with non-zero code: " ++ show return_code++ 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 <- newBarrier+ b1 <- newBarrier+ b2 <- newBarrier+ b3 <- newBarrier + 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+ liftIO $ waitBarrier startBarrier+ updater $ ProgressAmount (Just 25) (Just "step1")+ liftIO $ waitBarrier b1+ updater $ ProgressAmount (Just 50) (Just "step2")+ liftIO $ waitBarrier b2+ updater $ ProgressAmount (Just 75) (Just "step3")+ liftIO $ waitBarrier b3++ runSessionWithServer logger definition Test.defaultConfig Test.fullLatestClientCaps "." $ 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+ liftIO $ signalBarrier 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)+ liftIO $ signalBarrier b1 ()++ 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)+ liftIO $ signalBarrier b2 ()++ 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)+ liftIO $ signalBarrier b3 ()++ -- 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 (5 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True))++ runSessionWithServer logger definition Test.defaultConfig Test.fullLatestClientCaps "." $ 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 +186,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.fullLatestClientCaps "." $ do -- First make sure that we get a $/progress begin notification skipManyTill Test.anyMessage $ do x <- Test.message SMethod_Progress@@ -73,11 +206,75 @@ x <- Test.message SMethod_Progress guard $ has (L.params . L.value . _workDoneProgressEnd) x + describe "client-initiated progress reporting" $ do+ it "sends updates" $ do+ startBarrier <- newBarrier+ b1 <- newBarrier+ b2 <- newBarrier+ b3 <- newBarrier++ 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+ liftIO $ waitBarrier startBarrier+ updater $ ProgressAmount (Just 25) (Just "step1")+ liftIO $ waitBarrier b1+ updater $ ProgressAmount (Just 50) (Just "step2")+ liftIO $ waitBarrier b2+ updater $ ProgressAmount (Just 75) (Just "step3")+ liftIO $ waitBarrier b3++ runSessionWithServer logger definition Test.defaultConfig Test.fullLatestClientCaps "." $ 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++ liftIO $ signalBarrier 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)+ liftIO $ signalBarrier b1 ()++ 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)+ liftIO $ signalBarrier b2 ()++ 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)+ liftIO $ signalBarrier b3 ()++ -- 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 +313,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.fullLatestClientCaps "." $ 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.18.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against@@ -22,19 +22,23 @@ copyright: 2021 Luke Lau category: Testing build-type: Simple-extra-source-files:+extra-doc-files: ChangeLog.md README.md+extra-source-files: test/data/**/*.hs source-repository head type: git location: https://github.com/haskell/lsp +common warnings+ ghc-options: -Wunused-packages+ library+ import: warnings 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 +47,38 @@ , 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.2+ , 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 && < 0.9+ , data-default >=0.7 && < 0.9+ , Diff >=0.4 && <1.1+ , directory ^>=1.3+ , exceptions ^>=0.10+ , extra >=1.7 && < 1.9+ , filepath >=1.4 && < 1.6+ , Glob >=0.9 && <0.11+ , lens >=5.1 && <5.4+ , lens-aeson ^>=1.2+ , lsp ^>=2.8+ , lsp-types ^>=2.4+ , mtl >=2.2 && <2.4+ , parser-combinators ^>=1.3+ , process ^>=1.6+ , some ^>=1.0+ , text >=1 && <2.2+ , time >=1.10 && <1.16+ , transformers >=0.5 && <0.7 if os(windows) build-depends: Win32+ else build-depends: unix @@ -89,40 +94,42 @@ 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+ import: warnings+ 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+ import: warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: func-test+ default-language: GHC2021+ main-is: FuncTest.hs build-depends: , base+ , aeson , co-log-core+ , extra , hspec , lens , lsp@@ -131,30 +138,29 @@ , process , unliftio - test-suite example+ import: warnings 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+ import: warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ default-language: GHC2021+ main-is: SimpleBench.hs+ ghc-options: -Wall -O2 -rtsopts build-depends: , base , extra , lsp , lsp-test , process-
src/Language/LSP/Test.hs view
@@ -1,13 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# 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,11 +25,12 @@ runSessionWithHandles', setIgnoringLogNotifications, setIgnoringConfigurationRequests,+ setIgnoringRegistrationRequests, -- ** Config SessionConfig (..), defaultConfig,- C.fullCaps,+ C.fullLatestClientCaps, -- ** Exceptions module Language.LSP.Test.Exceptions,@@ -97,6 +93,7 @@ -- ** Completions getCompletions, getAndResolveCompletions,+ resolveCompletion, -- ** References getReferences,@@ -113,6 +110,9 @@ -- ** Hover getHover, + -- ** Signature Help+ getSignatureHelp,+ -- ** Highlights getHighlights, @@ -128,6 +128,11 @@ getAndResolveCodeLenses, resolveCodeLens, + -- ** Inlay Hints+ getInlayHints,+ getAndResolveInlayHints,+ resolveInlayHint,+ -- ** Call hierarchy prepareCallHierarchy, incomingCalls,@@ -136,6 +141,10 @@ -- ** SemanticTokens getSemanticTokens, + -- ** Workspace Symbols+ getWorkspaceSymbols,+ resolveWorkspaceSymbols,+ -- ** Capabilities getRegisteredCapabilities, ) where@@ -149,8 +158,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@@ -178,7 +189,7 @@ {- | Starts a new session. - > runSession "hie" fullCaps "path/to/root/dir" $ do+ > runSession "hie" fullLatestClientCaps "path/to/root/dir" $ do > doc <- openDoc "Desktop/simple.hs" "haskell" > diags <- waitForDiagnostics > let pos = Position 12 5@@ -240,7 +251,7 @@ > (houtRead, houtWrite) <- createPipe > > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do+ > runSessionWithHandles hinWrite houtRead defaultConfig fullLatestClientCaps "." $ do > -- ... -} runSessionWithHandles ::@@ -280,19 +291,20 @@ let initializeParams = InitializeParams- Nothing- -- Narrowing to Int32 here, but it's unlikely that a PID will- -- be outside the range- (InL $ fromIntegral pid)- (Just lspTestClientInfo)- (Just $ T.pack absRootDir)- Nothing- (InL $ filePathToUri absRootDir)- caps- -- TODO: make this configurable?- (Just $ Object $ lspConfig config')- (Just TraceValues_Off)- (fmap InL $ initialWorkspaceFolders config)+ { _workDoneToken = Nothing+ , -- Narrowing to Int32 here, but it's unlikely that a PID will+ -- be outside the range+ _processId = InL $ fromIntegral pid+ , _clientInfo = Just lspTestClientInfo+ , _locale = Nothing+ , _rootPath = Just (InL $ T.pack absRootDir)+ , _rootUri = InL $ filePathToUri absRootDir+ , _capabilities = caps+ , -- TODO: make this configurable?+ _initializationOptions = Just $ Object $ lspConfig config'+ , _trace = Just TraceValue_Off+ , _workspaceFolders = InL <$> initialWorkspaceFolders config+ } runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls initReqId <- sendRequest SMethod_Initialize initializeParams@@ -362,7 +374,7 @@ documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get- let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. L.uri))+ let Just file = vfs ^? vfsMap . ix (toNormalizedUri (doc ^. L.uri)) . _Open return (virtualFileText file) {- | Parses an ApplyEditRequest, checks that it is for the passed document@@ -481,6 +493,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 +506,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@@ -530,7 +560,7 @@ -- | The path to the document to open, __relative to the root directory__. FilePath -> -- | The text document's language identifier, e.g. @"haskell"@.- T.Text ->+ LanguageKind -> -- | The content of the text document to create. T.Text -> -- | The identifier of the document just created.@@ -543,7 +573,7 @@ let pred :: SomeRegistration -> [TRegistration Method_WorkspaceDidChangeWatchedFiles] pred (SomeRegistration r@(TRegistration _ SMethod_WorkspaceDidChangeWatchedFiles _)) = [r] pred _ = mempty- regs = concatMap pred $ Map.elems dynCaps+ regs = concatMap pred dynCaps watchHits :: FileSystemWatcher -> Bool watchHits (FileSystemWatcher (GlobPattern (InL (Pattern pattern))) kind) = -- If WatchKind is excluded, defaults to all true as per spec@@ -575,7 +605,7 @@ {- | Opens a text document that /exists on disk/, and sends a textDocument/didOpen notification to the server. -}-openDoc :: FilePath -> T.Text -> Session TextDocumentIdentifier+openDoc :: FilePath -> LanguageKind -> Session TextDocumentIdentifier openDoc file languageId = do context <- ask let fp = rootDir context </> file@@ -585,7 +615,7 @@ {- | This is a variant of `openDoc` that takes the file content as an argument. Use this is the file exists /outside/ of the current workspace. -}-openDoc' :: FilePath -> T.Text -> T.Text -> Session TextDocumentIdentifier+openDoc' :: FilePath -> LanguageKind -> T.Text -> Session TextDocumentIdentifier openDoc' file languageId contents = do context <- ask let fp = rootDir context </> file@@ -652,7 +682,7 @@ Right (InL xs) -> return (Left xs) Right (InR (InL xs)) -> return (Right xs) Right (InR (InR _)) -> return (Right [])- Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)+ Left err -> throw (UnexpectedResponseError (fromJust rspLid) err) -- | Returns the code actions in the specified range. getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]@@ -663,7 +693,7 @@ case rsp ^. L.result of Right (InL xs) -> return xs Right (InR _) -> return []- Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error)+ Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error) {- | Returns the code actions in the specified range, resolving any with a non empty _data_ field.@@ -691,7 +721,7 @@ TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx) case res of- Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)+ Left e -> throw (UnexpectedResponseError (fromJust rspLid) e) Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs) Right (InR _) -> pure acc @@ -724,7 +754,7 @@ Note that this does not wait for more to come in. -} getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]-getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get+getCurrentDiagnostics doc = Map.findWithDefault [] (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get -- | Returns the tokens of all progress sessions that have started but not yet ended. getIncompleteProgressSessions :: Session (Set.Set ProgressToken)@@ -753,15 +783,15 @@ 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 case rsp ^. L.result of Right ca -> return ca- Left er -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) er)+ Left er -> throw (UnexpectedResponseError (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 ()@@ -774,7 +804,7 @@ getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do vfs <- vfs <$> get- let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion+ let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . _Open . to virtualFileVersion -- TODO: is this correct? Could return an OptionalVersionedTextDocumentIdentifier, -- but that complicated callers... return (VersionedTextDocumentIdentifier uri (fromMaybe 0 ver))@@ -821,13 +851,13 @@ 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 case rsp ^. L.result of Right ci -> return ci- Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error)+ Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error) -- | Returns the references for the position in the document. getReferences ::@@ -906,6 +936,12 @@ let params = HoverParams doc pos Nothing in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params +-- | Returns the signature help at the specified position.+getSignatureHelp :: TextDocumentIdentifier -> Position -> Maybe SignatureHelpContext -> Session (Maybe SignatureHelp)+getSignatureHelp doc pos mCtx =+ let params = SignatureHelpParams doc pos Nothing mCtx+ in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentSignatureHelp params+ -- | Returns the highlighted occurrences of the term at the specified position getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] getHighlights doc pos =@@ -915,11 +951,11 @@ {- | Checks the response for errors and throws an exception if needed. Returns the result if successful. -}-getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m+getResponseResult :: (Show (ErrorData m)) => TResponseMessage m -> MessageResult m getResponseResult rsp = case rsp ^. L.result of Right x -> x- Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err+ Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()@@ -956,14 +992,36 @@ 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 case rsp ^. L.result of Right cl -> return cl- Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error)+ Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error) +-- | Returns the inlay hints in the specified range.+getInlayHints :: TextDocumentIdentifier -> Range -> Session [InlayHint]+getInlayHints tId range = do+ rsp <- request SMethod_TextDocumentInlayHint (InlayHintParams Nothing tId range)+ pure $ absorbNull $ getResponseResult rsp++{- | Returns the inlay hints in the specified range, resolving any with+ a non empty _data_ field.+-}+getAndResolveInlayHints :: TextDocumentIdentifier -> Range -> Session [InlayHint]+getAndResolveInlayHints tId range = do+ inlayHints <- getInlayHints tId range+ for inlayHints $ \inlayHint -> if isJust (inlayHint ^. L.data_) then resolveInlayHint inlayHint else pure inlayHint++-- | Resolves the provided inlay hint.+resolveInlayHint :: InlayHint -> Session InlayHint+resolveInlayHint ih = do+ rsp <- request SMethod_InlayHintResolve ih+ case rsp ^. L.result of+ Right ih -> return ih+ Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error)+ -- | Pass a param and return the response from `prepareCallHierarchy` prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem] prepareCallHierarchy = resolveRequestWithListResp SMethod_TextDocumentPrepareCallHierarchy@@ -977,7 +1035,7 @@ -- | Send a request and receive a response with list. resolveRequestWithListResp :: forall (m :: Method ClientToServer Request) a.- (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null)) =>+ (Show (ErrorData m), MessageResult m ~ ([a] |? Null)) => SMethod m -> MessageParams m -> Session [a]@@ -985,11 +1043,24 @@ 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 rsp <- request SMethod_TextDocumentSemanticTokensFull params+ pure $ getResponseResult rsp++{- | Query the workspace and filter by the given 'T.Text'.+If empty, this queries the entire workspace.+-}+getWorkspaceSymbols :: T.Text -> Session ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))+getWorkspaceSymbols query = do+ rsp <- request SMethod_WorkspaceSymbol (WorkspaceSymbolParams Nothing Nothing query)+ pure $ getResponseResult rsp++resolveWorkspaceSymbols :: WorkspaceSymbol -> Session WorkspaceSymbol+resolveWorkspaceSymbols item = do+ rsp <- request SMethod_WorkspaceSymbolResolve item pure $ getResponseResult rsp {- | Returns a list of capabilities that the server has requested to /dynamically/
src/Language/LSP/Test/Compat.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-} -- For some reason ghc warns about not using -- Control.Monad.IO.Class but it's needed for -- MonadIO@@ -11,8 +10,7 @@ module Language.LSP.Test.Compat where import Data.Maybe-import Data.Row-import Data.Text qualified as T+import Language.LSP.Protocol.Types qualified as L import System.IO #if MIN_VERSION_process(1,6,3)@@ -104,7 +102,7 @@ return () where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE ignorePermDenied = ignoreIOError PermissionDenied eACCES- + ignoreIOError :: IOErrorType -> Errno -> IO () -> IO () ignoreIOError ioErrorType errno = C.handle $ \e -> case e of@@ -119,5 +117,5 @@ #endif -lspTestClientInfo :: Rec ("name" .== T.Text .+ "version" .== Maybe T.Text)-lspTestClientInfo = #name .== "lsp-test" .+ #version .== (Just CURRENT_PACKAGE_VERSION)+lspTestClientInfo :: L.ClientInfo+lspTestClientInfo = L.ClientInfo{L._name = "lsp-test", L._version = Just CURRENT_PACKAGE_VERSION}
src/Language/LSP/Test/Decoding.hs view
@@ -1,6 +1,6 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeInType #-} module Language.LSP.Test.Decoding where @@ -10,7 +10,6 @@ import Data.Aeson.Types import Data.ByteString.Lazy.Char8 qualified as B import Data.Foldable-import Data.Functor.Const import Data.Functor.Product import Data.Maybe import Language.LSP.Protocol.Lens qualified as L@@ -82,7 +81,7 @@ let (mm, newMap) = pickFromIxMap lid reqMap in case mm of Nothing -> Nothing- Just m -> Just $ (m, Pair m (Const newMap))+ Just m -> Just (m, Pair m (Const newMap)) unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg) unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg) unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e
src/Language/LSP/Test/Exceptions.hs view
@@ -17,11 +17,10 @@ | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics | IncorrectApplyEditRequest String- | UnexpectedResponseError SomeLspId ResponseError+ | forall m. Show (ErrorData m) => UnexpectedResponseError (LspId m) (TResponseError m) | UnexpectedServerTermination | IllegalInitSequenceMessage FromServerMessage | MessageSendError Value IOError- deriving (Eq) instance Exception SessionException
src/Language/LSP/Test/Files.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-} module Language.LSP.Test.Files ( swapFiles,@@ -86,18 +83,13 @@ swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile in e- & L.changes . _Just %~ swapKeys f+ & L.changes . _Just %~ M.mapKeys f & L.documentChanges . _Just . traversed %~ swapDocumentChangeUri - swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b- swapKeys f = M.foldlWithKey' (\acc k v -> M.insert (f k) v acc) M.empty- swapUri :: L.HasUri b Uri => Lens' a b -> a -> a- swapUri lens x =- let newUri = f (x ^. lens . L.uri)- in (lens . L.uri) .~ newUri $ x+ swapUri lens = (lens . L.uri) %~ f - -- \| Transforms rootUri/rootPath.+ -- Transforms rootUri/rootPath. transformInit :: InitializeParams -> InitializeParams transformInit x = let modifyRootPath p =
src/Language/LSP/Test/Parsing.hs view
@@ -1,10 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeInType #-} module Language.LSP.Test.Parsing ( -- $receiving
src/Language/LSP/Test/Session.hs view
@@ -2,16 +2,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-} module Language.LSP.Test.Session ( Session(..)@@ -87,9 +81,9 @@ import System.Timeout ( timeout ) import Data.IORef import Colog.Core (LogAction (..), WithSeverity (..), Severity (..))-import Data.Row import Data.String (fromString) import Data.Either (partitionEithers)+import Control.Concurrent.Async (async, cancel) -- | A session representing one instance of launching and connecting to a server. --@@ -125,11 +119,14 @@ -- with a 'mylang' key whose value is the actual config for the server. You -- can also include other config sections if your server may request those. , ignoreLogNotifications :: Bool- -- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications + -- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications -- from the server, defaults to True. , 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 +134,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 +194,7 @@ , curProgressSessions :: !(Set.Set ProgressToken) , ignoringLogNotifications :: Bool , ignoringConfigurationRequests :: Bool+ , ignoringRegistrationRequests :: Bool } class Monad m => HasState s m where@@ -250,7 +248,7 @@ curId <- getCurTimeoutId case msg of ServerMessage sMsg -> yield sMsg- TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout+ TimeoutMessage tId -> when (curId == tId) $ get >>= throw . Timeout . lastReceivedMessage -- | An internal version of 'runSession' that allows for a custom handler to listen to the server. -- It also does not automatically send initialize and exit messages.@@ -281,15 +279,34 @@ 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 () serverListenerLauncher =- forkIO $ catch (serverHandler serverOut context) errorHandler+ async $ catch (serverHandler serverOut context) errorHandler msgTimeoutMs = messageTimeout config * 10^6- serverAndListenerFinalizer tid = do+ serverAndListenerFinalizer async = do let cleanup | Just sp <- mServerProc = do -- Give the server some time to exit cleanly@@ -302,7 +319,7 @@ finally (timeout msgTimeoutMs (runSession' exitServer)) -- Make sure to kill the listener first, before closing -- handles etc via cleanupProcess- (killThread tid >> cleanup)+ (cancel async >> cleanup) (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer@@ -322,7 +339,7 @@ let requestedSections = mapMaybe (\i -> i ^? L.section . _Just) $ r ^. L.params . L.items let o = curLspConfig state -- check for each requested section whether we have it- let configsOrErrs = (flip fmap) requestedSections $ \section ->+ let configsOrErrs = flip fmap requestedSections $ \section -> case o ^. at (fromString $ T.unpack section) of Just config -> Right config Nothing -> Left section@@ -330,12 +347,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 $ TResponseError (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@@ -348,6 +368,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 documentChangeUri :: DocumentChange -> Uri@@ -391,7 +415,7 @@ -- First, prefer the versioned documentChanges field allChangeParams <- case r ^. L.params . L.edit . L.documentChanges of- Just (cs) -> do+ Just cs -> do mapM_ (checkIfNeedsOpened . documentChangeUri) cs -- replace the user provided version numbers with the VFS ones + 1 -- (technically we should check that the user versions match the VFS ones)@@ -422,8 +446,8 @@ forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> modify $ \s -> let oldVFS = vfs s- update (VirtualFile _ file_ver t) = VirtualFile v (file_ver +1) t- newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) %~ update+ update (VirtualFile _ file_ver t _kind) = VirtualFile v (file_ver +1) t _kind+ newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) . _Open %~ update in s { vfs = newVFS } where@@ -449,8 +473,8 @@ -- TODO: move somewhere reusable editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent- editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. L.range) .+ #rangeLength .== Nothing .+ #text .== (e ^. L.newText)- editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. L.range) .+ #rangeLength .== Nothing .+ #text .== (e ^. L.newText)+ editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ TextDocumentContentChangePartial { _range = e ^. L.range , _rangeLength = Nothing , _text = e ^. L.newText }+ editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ TextDocumentContentChangePartial { _range = e ^. L.range , _rangeLength = Nothing , _text = e ^. L.newText } getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams getParamsFromDocumentChange (InL textDocumentEdit) = getParamsFromTextDocumentEdit textDocumentEdit@@ -463,16 +487,16 @@ -- where n is the current version textDocumentVersions uri = do vfs <- vfs <$> get- let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version+ let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . _Open . lsp_version pure $ map (VersionedTextDocumentIdentifier uri) [curVer + 1..] textDocumentEdits uri edits = do vers <- textDocumentVersions uri- pure $ map (\(v, e) -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) $ zip vers edits+ pure $ zipWith (\v e -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) vers edits getChangeParams uri edits = do edits <- textDocumentEdits uri (reverse edits)- pure $ catMaybes $ map getParamsFromTextDocumentEdit edits+ pure $ mapMaybe getParamsFromTextDocumentEdit edits mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = let events = concat (toList (map (toList . (^. L.contentChanges)) params))
test/DummyServer.hs view
@@ -1,7 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE RecordWildCards #-} module DummyServer where @@ -72,6 +72,12 @@ Right $ InL $ Hover (InL (MarkupContent MarkupKind_PlainText "hello")) Nothing+ , requestHandler SMethod_TextDocumentSignatureHelp $+ \_req responder ->+ responder $+ Right $+ InL $+ SignatureHelp [] Nothing Nothing , requestHandler SMethod_TextDocumentDocumentSymbol $ \_req responder -> responder $@@ -124,7 +130,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 +145,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"@@ -255,6 +261,27 @@ , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do let tokens = makeSemanticTokens defaultSemanticTokensLegend [SemanticTokenAbsolute 0 1 2 SemanticTokenTypes_Type []] case tokens of- Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing+ Left t -> resp $ Left $ TResponseError (InR ErrorCodes_InternalError) t Nothing Right tokens -> resp $ Right $ InL tokens+ , requestHandler SMethod_TextDocumentInlayHint $ \req resp -> do+ let TRequestMessage _ _ _ params = req+ InlayHintParams _ _ (Range start end) = params+ ih =+ InlayHint+ end+ (InL ":: Text")+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ (Just $ toJSON start)+ resp $ Right $ InL [ih]+ , requestHandler SMethod_InlayHintResolve $ \req resp -> do+ let TRequestMessage _ _ _ params = req+ (InlayHint{_data_ = Just data_, ..}) = params+ start :: Position+ Success start = fromJSON data_+ ih = InlayHint{_data_ = Nothing, _tooltip = Just $ InL $ "start at " <> T.pack (show start), ..}+ resp $ Right ih ]
test/Test.hs view
@@ -1,9 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeInType #-} import Control.Applicative.Combinators import Control.Concurrent@@ -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@@ -35,20 +33,20 @@ main = hspec $ around withDummyServer $ do describe "Session" $ do it "fails a test" $ \(hin, hout) ->- let session = runSessionWithHandles hin hout def fullCaps "." $ do+ let session = runSessionWithHandles hin hout def fullLatestClientCaps "." $ do openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" anyRequest in session `shouldThrow` anySessionException- it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do rsp <- initializeResponse liftIO $ rsp ^. L.result `shouldSatisfy` isRight it "runSessionWithConfig" $ \(hin, hout) ->- runSessionWithHandles hin hout def fullCaps "." $ return ()+ runSessionWithHandles hin hout def fullLatestClientCaps "." $ return () describe "withTimeout" $ do it "times out" $ \(hin, hout) ->- let sesh = runSessionWithHandles hin hout def fullCaps "." $ do+ let sesh = runSessionWithHandles hin hout def fullLatestClientCaps "." $ do openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the@@ -59,13 +57,13 @@ timeout 6000000 sesh `shouldThrow` anySessionException it "doesn't time out" $ \(hin, hout) ->- let sesh = runSessionWithHandles hin hout def fullCaps "." $ do+ let sesh = runSessionWithHandles hin hout def fullLatestClientCaps "." $ do openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification in void $ timeout 6000000 sesh it "further timeout messages are ignored" $ \(hin, hout) ->- runSessionWithHandles hin hout def fullCaps "." $ do+ runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't timeout withTimeout 3 $ getDocumentSymbols doc@@ -77,7 +75,7 @@ it "overrides global message timeout" $ \(hin, hout) -> let sesh =- runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do+ runSessionWithHandles hin hout (def{messageTimeout = 5}) fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000@@ -87,7 +85,7 @@ it "unoverrides global message timeout" $ \(hin, hout) -> let sesh =- runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do+ runSessionWithHandles hin hout (def{messageTimeout = 5}) fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000@@ -100,13 +98,13 @@ describe "SessionException" $ do it "throw on time out" $ \(hin, hout) ->- let sesh = runSessionWithHandles hin hout (def{messageTimeout = 10}) fullCaps "." $ do+ let sesh = runSessionWithHandles hin hout (def{messageTimeout = 10}) fullLatestClientCaps "." $ do _ <- message SMethod_WorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException it "don't throw when no time out" $ \(hin, hout) ->- runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do+ runSessionWithHandles hin hout (def{messageTimeout = 5}) fullLatestClientCaps "." $ do liftIO $ threadDelay $ 6 * 1000000 _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" return ()@@ -115,7 +113,7 @@ it "throws when there's an unexpected message" $ \(hin, hout) -> let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SMethod_WindowLogMessage _)) = True selector _ = False- in runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." publishDiagnosticsNotification `shouldThrow` selector+ in runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullLatestClientCaps "." publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ \(hin, hout) -> let selector (UnexpectedMessage "Response for: SMethod_TextDocumentRename" (FromServerRsp SMethod_TextDocumentDocumentSymbol _)) = True selector _ = False@@ -124,12 +122,12 @@ sendRequest SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification response SMethod_TextDocumentRename -- the wrong type- in runSessionWithHandles hin hout def fullCaps "." sesh+ in runSessionWithHandles hin hout def fullLatestClientCaps "." sesh `shouldThrow` selector describe "config" $ do it "updates config correctly" $ \(hin, hout) ->- runSessionWithHandles hin hout (def{ignoreConfigurationRequests = False}) fullCaps "." $ do+ runSessionWithHandles hin hout (def{ignoreConfigurationRequests = False}) fullLatestClientCaps "." $ do configurationRequest -- initialized configuration request let requestConfig = do resp <- request (SMethod_CustomMethod (Proxy @"getConfig")) J.Null@@ -152,7 +150,7 @@ describe "text document VFS" $ do it "sends back didChange notifications (documentChanges)" $ \(hin, hout) ->- runSessionWithHandles hin hout def fullCaps "." $ do+ runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" VersionedTextDocumentIdentifier _ beforeVersion <- getVersionedDoc doc @@ -182,7 +180,7 @@ liftIO $ reportedVersion `shouldNotBe` beforeVersion it "sends back didChange notifications" $ \(hin, hout) ->- runSessionWithHandles hin hout def fullCaps "." $ do+ runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" let args = toJSON (doc ^. L.uri)@@ -200,7 +198,7 @@ describe "getDocumentEdit" $ it "automatically consumes applyedit requests" $ \(hin, hout) ->- runSessionWithHandles hin hout def fullCaps "." $ do+ runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" let args = toJSON (doc ^. L.uri)@@ -210,7 +208,7 @@ liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" describe "getCodeActions" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" waitForDiagnostics [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2))@@ -219,7 +217,7 @@ liftIO $ actions `shouldSatisfy` null describe "getAllCodeActions" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" _ <- waitForDiagnostics actions <- getAllCodeActions doc@@ -229,7 +227,7 @@ action ^. L.command . _Just . L.command `shouldBe` "deleteThis" describe "getDocumentSymbols" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" Right (mainSymbol : _) <- getDocumentSymbols doc@@ -240,13 +238,13 @@ mainSymbol ^. L.range `shouldBe` mkRange 0 0 3 6 describe "applyEdit" $ do- it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" VersionedTextDocumentIdentifier _ oldVersion <- getVersionedDoc doc let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" VersionedTextDocumentIdentifier _ newVersion <- applyEdit doc edit liftIO $ newVersion `shouldBe` oldVersion + 1- it "changes the document contents" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "changes the document contents" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" applyEdit doc edit@@ -254,7 +252,7 @@ liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" describe "getCompletions" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" comps <- getCompletions doc (Position 5 5)@@ -262,7 +260,7 @@ liftIO $ item ^. L.label `shouldBe` "foo" -- describe "getReferences" $- -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do -- doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- let pos = Position 40 3 -- interactWithUser -- uri = doc ^. LSP.uri@@ -274,21 +272,21 @@ -- ] -- describe "getDefinitions" $- -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do -- doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- let pos = Position 49 25 -- addItem -- defs <- getDefinitions doc pos -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)] -- describe "getTypeDefinitions" $- -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do -- doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- let pos = Position 20 23 -- Quit value -- defs <- getTypeDefinitions doc pos -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition describe "waitForDiagnosticsSource" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do openDoc "test/data/Error.hs" "haskell" [diag] <- waitForDiagnosticsSource "dummy-server" liftIO $ do@@ -298,33 +296,39 @@ -- describe "rename" $ do -- it "works" $ \(hin, hout) -> pendingWith "HaRe not in hie-bios yet" -- it "works on javascript" $- -- runSessionWithHandles hin hout "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do+ -- runSessionWithHandles hin hout "javascript-typescript-stdio" fullLatestClientCaps "test/data/javascriptPass" $ do -- doc <- openDoc "test.js" "javascript" -- rename doc (Position 2 11) "bar" -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack describe "getHover" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" hover <- getHover doc (Position 45 9) liftIO $ hover `shouldSatisfy` isJust + describe "getSignatureHelp" $+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do+ doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"+ signatureHelp <- getSignatureHelp doc (Position 22 32) Nothing+ liftIO $ signatureHelp `shouldSatisfy` isJust+ -- describe "getHighlights" $- -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do -- doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- skipManyTill loggingNotification $ count 2 noDiagnostics -- highlights <- getHighlights doc (Position 27 4) -- addItem -- liftIO $ length highlights `shouldBe` 4 -- describe "formatDoc" $- -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do -- doc <- openDoc "test/data/Format.hs" "haskell" -- oldContents <- documentContents doc -- formatDoc doc (FormattingOptions 4 True) -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents) -- describe "formatRange" $- -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do -- doc <- openDoc "test/data/Format.hs" "haskell" -- oldContents <- documentContents doc -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))@@ -333,7 +337,7 @@ describe "closeDoc" $ it "works" $ \(hin, hout) -> let sesh =- runSessionWithHandles hin hout def fullCaps "." $ do+ runSessionWithHandles hin hout def fullLatestClientCaps "." $ do doc <- openDoc "test/data/Format.hs" "haskell" closeDoc doc -- need to evaluate to throw@@ -341,21 +345,21 @@ in sesh `shouldThrow` anyException describe "satisfy" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullLatestClientCaps "." $ do openDoc "test/data/Format.hs" "haskell" let pred (FromServerMess SMethod_WindowLogMessage _) = True pred _ = False void $ satisfy pred describe "satisfyMaybe" $ do- it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do+ it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullLatestClientCaps "." $ do -- Wait for window/logMessage "initialized" from the server. let pred (FromServerMess SMethod_WindowLogMessage _) = Just "match" :: Maybe String pred _ = Nothing :: Maybe String result <- satisfyMaybe pred liftIO $ result `shouldBe` "match" - it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do+ it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullLatestClientCaps "." $ do let pred (FromServerMess SMethod_TextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String pred _ = Nothing :: Maybe String -- We expect a window/logMessage from the server, but@@ -365,30 +369,36 @@ describe "ignoreLogNotifications" $ it "works" $ \(hin, hout) ->- runSessionWithHandles hin hout (def{ignoreLogNotifications = True}) fullCaps "." $ do+ runSessionWithHandles hin hout (def{ignoreLogNotifications = True}) fullLatestClientCaps "." $ do openDoc "test/data/Format.hs" "haskell" 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 fullLatestClientCaps "." $ 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 +408,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 fullLatestClientCaps "" $ do loggingNotification -- initialized log message curDir <- liftIO $ getCurrentDirectory + setIgnoringRegistrationRequests False createDoc ".register.abs" "haskell" "" message SMethod_ClientRegisterCapability @@ -431,21 +442,31 @@ (Range (Position 1 2) (Position 3 4)) (Range (Position 1 2) (Position 3 4)) Nothing- it "prepare works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "prepare works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do rsp <- prepareCallHierarchy (params workPos) liftIO $ head rsp ^. L.range `shouldBe` Range (Position 2 3) (Position 4 5)- it "prepare not works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "prepare not works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do rsp <- prepareCallHierarchy (params notWorkPos) liftIO $ rsp `shouldBe` []- it "incoming calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "incoming calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do [CallHierarchyIncomingCall _ fromRanges] <- incomingCalls (CallHierarchyIncomingCallsParams Nothing Nothing item) liftIO $ head fromRanges `shouldBe` Range (Position 2 3) (Position 4 5)- it "outgoing calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "outgoing calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do [CallHierarchyOutgoingCall _ fromRanges] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item) liftIO $ head fromRanges `shouldBe` Range (Position 4 5) (Position 2 3) describe "semantic tokens" $ do- it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do let doc = TextDocumentIdentifier (Uri "") InL toks <- getSemanticTokens doc liftIO $ toks ^. L.data_ `shouldBe` [0, 1, 2, 1, 0]++ describe "inlay hints" $ do+ it "get works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do+ doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"+ inlayHints <- getInlayHints doc (Range (Position 1 2) (Position 3 4))+ liftIO $ head inlayHints ^. L.label `shouldBe` InL ":: Text"+ it "resolve tooltip works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullLatestClientCaps "." $ do+ doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"+ inlayHints <- getAndResolveInlayHints doc (Range (Position 1 2) (Position 3 4))+ liftIO $ head inlayHints ^. L.tooltip `shouldBe` Just (InL $ "start at " <> T.pack (show (Position 1 2)))