lsp-test 0.15.0.1 → 0.18.0.0
raw patch · 20 files changed
Files
- ChangeLog.md +51/−1
- README.md +2/−2
- bench/SimpleBench.hs +42/−37
- example/Test.hs +9/−7
- func-test/FuncTest.hs +286/−84
- lsp-test.cabal +64/−52
- src/Language/LSP/Test.hs +565/−341
- src/Language/LSP/Test/Compat.hs +14/−17
- src/Language/LSP/Test/Decoding.hs +54/−49
- src/Language/LSP/Test/Exceptions.hs +47/−32
- src/Language/LSP/Test/Files.hs +66/−72
- src/Language/LSP/Test/Parsing.hs +106/−93
- src/Language/LSP/Test/Server.hs +2/−2
- src/Language/LSP/Test/Session.hs +104/−46
- test/DummyServer.hs +110/−69
- test/Test.hs +161/−119
- test/data/Format.hs +4/−3
- test/data/documentSymbolFail/example/Main.hs +76/−60
- test/data/renameFail/Desktop/simple.hs +9/−13
- test/data/renamePass/Desktop/simple.hs +9/−13
ChangeLog.md view
@@ -1,5 +1,55 @@ # 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.++## 0.16.0.0++- The client configuration is now _mandatory_ and is an `Object` rather than a `Value`.+- `lsp-test` now responds to `workspace/configuration` requests.+- `lsp-test` does _not_ send a `workspace/didChangeConfiguration` request on startup.+- New functions for modifying the client configuration and notifying the server.+- `ignoreLogNotifications` is now _on by default_. Experience shows the norm is to ignore these+ and it is simpler to turn this on only when they are required.+- `ignoreConfigurationRequests` option to ignore `workspace/configuration` requests, also on+ by default.+- New functions `setIgnoringLogNotifications` and `setIgnoringConfigurationRequests` to change+ whether such messages are ignored during a `Session` without having to change the `SessionConfig`.+ ## 0.15.0.1 * Adds helper functions to resolve code lens, code actions, and completion items.@@ -18,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,44 +1,48 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}+ module Main where -import Language.LSP.Server-import qualified Language.LSP.Test as Test-import Language.LSP.Protocol.Types-import Language.LSP.Protocol.Message-import Control.Monad.IO.Class+import Control.Concurrent import Control.Monad-import System.Process hiding (env)+import Control.Monad.IO.Class+import Data.IORef+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Server+import Language.LSP.Test qualified as Test import System.Environment+import System.Process hiding (env) import System.Time.Extra-import Control.Concurrent-import Data.IORef handlers :: Handlers (LspM ())-handlers = mconcat- [ requestHandler SMethod_TextDocumentHover $ \req responder -> do- let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req- Position _l _c' = pos- rsp = Hover ms (Just range)- ms = InL $ mkMarkdown "Hello world"- range = Range pos pos- responder (Right $ InL rsp)- , requestHandler SMethod_TextDocumentDefinition $ \req responder -> do- let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req- responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos)- ]+handlers =+ mconcat+ [ requestHandler SMethod_TextDocumentHover $ \req responder -> do+ let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req+ Position _l _c' = pos+ rsp = Hover ms (Just range)+ ms = InL $ mkMarkdown "Hello world"+ range = Range pos pos+ responder (Right $ InL rsp)+ , requestHandler SMethod_TextDocumentDefinition $ \req responder -> do+ let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req+ responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos)+ ] server :: ServerDefinition ()-server = ServerDefinition- { onConfigurationChange = const $ const $ Right ()- , defaultConfig = ()- , doInitialize = \env _req -> pure $ Right env- , staticHandlers = \_caps -> handlers- , interpretHandler = \env -> Iso (runLspT env) liftIO- , options = defaultOptions- }+server =+ 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+ } main :: IO () main = do@@ -52,18 +56,19 @@ 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 liftIO $ when (v `mod` 1000 == 0) $ putStrLn $ show v- TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentHover $- HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing- TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentDefinition $- DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing+ TResponseMessage{_result = Right (InL _)} <-+ Test.request SMethod_TextDocumentHover $+ HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing+ TResponseMessage{_result = Right (InL _)} <-+ Test.request SMethod_TextDocumentDefinition $+ DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing - liftIO $ modifyIORef' i (+1)+ liftIO $ modifyIORef' i (+ 1) pure () end <- liftIO start liftIO $ putStrLn $ "Completed " <> show n <> " rounds in " <> showDuration end-
example/Test.hs view
@@ -1,21 +1,23 @@ {-# LANGUAGE OverloadedStrings #-}+ import Control.Applicative.Combinators import Control.Monad.IO.Class-import Language.LSP.Test-import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message+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. skipManyTill loggingNotification (count 1 publishDiagnosticsNotification) -- Send requests and notifications and receive responses- rsp <- request SMethod_TextDocumentDocumentSymbol $- DocumentSymbolParams Nothing Nothing doc+ rsp <-+ request SMethod_TextDocumentDocumentSymbol $+ DocumentSymbolParams Nothing Nothing doc liftIO $ print rsp -- Or use one of the helper functions getDocumentSymbols doc >>= liftIO . print-
func-test/FuncTest.hs view
@@ -1,126 +1,328 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs, OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+ module Main where -import Language.LSP.Server-import qualified Language.LSP.Test as Test-import Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Protocol.Message -import Control.Monad.IO.Class-import System.IO+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.Process-import Control.Applicative.Combinators-import Control.Lens hiding (List, Iso) import Test.Hspec-import Data.Maybe import UnliftIO import UnliftIO.Concurrent-import Control.Exception-import System.Exit-import qualified Colog.Core as L -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" $+ 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- (hinRead, hinWrite) <- createPipe- (houtRead, houtWrite) <- createPipe- killVar <- newEmptyMVar - let definition = ServerDefinition- { onConfigurationChange = const $ const $ Right ()- , defaultConfig = ()- , doInitialize = \env _req -> pure $ Right env- , staticHandlers = \_caps -> handlers killVar- , interpretHandler = \env -> Iso (runLspT env) liftIO- , options = defaultOptions- }+ let definition =+ ServerDefinition+ { parseConfig = const $ const $ Right ()+ , onConfigChange = const $ pure ()+ , defaultConfig = ()+ , configSection = "demo"+ , doInitialize = \env _req -> pure $ Right env+ , staticHandlers = \_caps -> handlers killVar+ , interpretHandler = \env -> Iso (runLspT env) liftIO+ , options = defaultOptions+ } 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- - Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do+ notificationHandler SMethod_Initialized $ \noti -> void $+ forkIO $+ withProgress "Doing something" Nothing NotCancellable $ \updater -> liftIO $ do+ takeMVar killVar+ Control.Exception.throwIO AsyncCancelled++ 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 guard $ has (L.params . L.value . _workDoneProgressBegin) x- + -- Then kill the thread liftIO $ putMVar killVar ()- + -- 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 + 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" wf1 = WorkspaceFolder (filePathToUri "/foo/bar") "My workspace" wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace"- - definition = ServerDefinition- { onConfigurationChange = const $ const $ Right ()- , defaultConfig = ()- , doInitialize = \env _req -> pure $ Right env- , staticHandlers = \_caps -> handlers- , interpretHandler = \env -> Iso (runLspT env) liftIO- , options = defaultOptions- } + 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 = mconcat- [ notificationHandler SMethod_Initialized $ \noti -> do- wfs <- fromJust <$> getWorkspaceFolders- liftIO $ wfs `shouldContain` [wf0]- , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do- i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i))- wfs <- fromJust <$> getWorkspaceFolders- liftIO $ case i of- 0 -> do- wfs `shouldContain` [wf1]- wfs `shouldContain` [wf0]- 1 -> do- wfs `shouldNotContain` [wf1]- wfs `shouldContain` [wf0]- wfs `shouldContain` [wf2]- _ -> 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]- }- + handlers =+ mconcat+ [ notificationHandler SMethod_Initialized $ \noti -> do+ wfs <- fromJust <$> getWorkspaceFolders+ liftIO $ wfs `shouldContain` [wf0]+ , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do+ i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i))+ wfs <- fromJust <$> getWorkspaceFolders+ liftIO $ case i of+ 0 -> do+ wfs `shouldContain` [wf1]+ wfs `shouldContain` [wf0]+ 1 -> do+ wfs `shouldNotContain` [wf1]+ wfs `shouldContain` [wf0]+ wfs `shouldContain` [wf2]+ _ -> error "Shouldn't be here"+ ]++ 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+ 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.15.0.1+version: 0.18.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against@@ -22,18 +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-language: GHC2021 exposed-modules: Language.LSP.Test reexported-modules: lsp-types:Language.LSP.Protocol.Types@@ -42,36 +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- , lsp ^>=2.1- , lsp-types ^>=2.0- , 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 @@ -87,38 +94,42 @@ ghc-options: -W test-suite tests- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Test.hs- default-language: Haskell2010- 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.1+ , 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- 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@@ -127,28 +138,29 @@ , process , unliftio - test-suite example+ import: warnings type: exitcode-stdio-1.0 hs-source-dirs: example- default-language: Haskell2010+ 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- 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,15 +1,10 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} -{-|+{- | Module : Language.LSP.Test Description : A functional testing framework for LSP servers. Maintainer : luke_lau@icloud.com@@ -20,213 +15,296 @@ <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>. You should import "Language.LSP.Types" alongside this. -}-module Language.LSP.Test- (+module Language.LSP.Test ( -- * Sessions- Session- , runSession- , runSessionWithConfig- , runSessionWithConfigCustomProcess- , runSessionWithHandles- , runSessionWithHandles'+ Session,+ runSession,+ runSessionWithConfig,+ runSessionWithConfigCustomProcess,+ runSessionWithHandles,+ runSessionWithHandles',+ setIgnoringLogNotifications,+ setIgnoringConfigurationRequests,+ setIgnoringRegistrationRequests,+ -- ** Config- , SessionConfig(..)- , defaultConfig- , C.fullCaps+ SessionConfig (..),+ defaultConfig,+ C.fullLatestClientCaps,+ -- ** Exceptions- , module Language.LSP.Test.Exceptions- , withTimeout+ module Language.LSP.Test.Exceptions,+ withTimeout,+ -- * Sending- , request- , request_- , sendRequest- , sendNotification- , sendResponse+ request,+ request_,+ sendRequest,+ sendNotification,+ sendResponse,+ -- * Receiving- , module Language.LSP.Test.Parsing+ module Language.LSP.Test.Parsing,+ -- * Utilities+ -- | Quick helper functions for common tasks. -- ** Initialization- , initializeResponse+ initializeResponse,++ -- ** Config+ modifyConfig,+ setConfig,+ modifyConfigSection,+ setConfigSection,+ -- ** Documents- , createDoc- , openDoc- , closeDoc- , changeDoc- , documentContents- , getDocumentEdit- , getDocUri- , getVersionedDoc+ createDoc,+ openDoc,+ closeDoc,+ changeDoc,+ documentContents,+ getDocumentEdit,+ getDocUri,+ getVersionedDoc,+ -- ** Symbols- , getDocumentSymbols+ getDocumentSymbols,+ -- ** Diagnostics- , waitForDiagnostics- , waitForDiagnosticsSource- , noDiagnostics- , getCurrentDiagnostics- , getIncompleteProgressSessions+ waitForDiagnostics,+ waitForDiagnosticsSource,+ noDiagnostics,+ getCurrentDiagnostics,+ getIncompleteProgressSessions,+ -- ** Commands- , executeCommand+ executeCommand,+ -- ** Code Actions- , getCodeActions- , getAndResolveCodeActions- , getAllCodeActions- , executeCodeAction- , resolveCodeAction- , resolveAndExecuteCodeAction+ getCodeActions,+ getAndResolveCodeActions,+ getAllCodeActions,+ executeCodeAction,+ resolveCodeAction,+ resolveAndExecuteCodeAction,+ -- ** Completions- , getCompletions- , getAndResolveCompletions+ getCompletions,+ getAndResolveCompletions,+ resolveCompletion,+ -- ** References- , getReferences+ getReferences,+ -- ** Definitions- , getDeclarations- , getDefinitions- , getTypeDefinitions- , getImplementations+ getDeclarations,+ getDefinitions,+ getTypeDefinitions,+ getImplementations,+ -- ** Renaming- , rename+ rename,+ -- ** Hover- , getHover+ getHover,++ -- ** Signature Help+ getSignatureHelp,+ -- ** Highlights- , getHighlights+ getHighlights,+ -- ** Formatting- , formatDoc- , formatRange+ formatDoc,+ formatRange,+ -- ** Edits- , applyEdit+ applyEdit,+ -- ** Code lenses- , getCodeLenses- , getAndResolveCodeLenses- , resolveCodeLens+ getCodeLenses,+ getAndResolveCodeLenses,+ resolveCodeLens,++ -- ** Inlay Hints+ getInlayHints,+ getAndResolveInlayHints,+ resolveInlayHint,+ -- ** Call hierarchy- , prepareCallHierarchy- , incomingCalls- , outgoingCalls+ prepareCallHierarchy,+ incomingCalls,+ outgoingCalls,+ -- ** SemanticTokens- , getSemanticTokens+ getSemanticTokens,++ -- ** Workspace Symbols+ getWorkspaceSymbols,+ resolveWorkspaceSymbols,+ -- ** Capabilities- , getRegisteredCapabilities- ) where+ getRegisteredCapabilities,+) where import Control.Applicative.Combinators import Control.Concurrent+import Control.Exception+import Control.Lens hiding (Empty, List, (.=)) import Control.Monad import Control.Monad.IO.Class-import Control.Exception-import Control.Lens hiding ((.=), List, Empty)-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.IO as T+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 Language.LSP.Protocol.Types+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Traversable (for)+import Language.LSP.Protocol.Capabilities qualified as C+import Language.LSP.Protocol.Lens qualified as L import Language.LSP.Protocol.Message-import qualified Language.LSP.Protocol.Lens as L-import qualified Language.LSP.Protocol.Capabilities as C-import Language.LSP.VFS+import Language.LSP.Protocol.Types import Language.LSP.Test.Compat import Language.LSP.Test.Decoding import Language.LSP.Test.Exceptions import Language.LSP.Test.Parsing-import Language.LSP.Test.Session import Language.LSP.Test.Server-import System.Environment-import System.IO+import Language.LSP.Test.Session+import Language.LSP.VFS import System.Directory+import System.Environment import System.FilePath-import System.Process (ProcessHandle, CreateProcess)-import qualified System.FilePath.Glob as Glob-import Control.Monad.State (execState)-import Data.Traversable (for)+import System.FilePath.Glob qualified as Glob+import System.IO+import System.Process (CreateProcess, ProcessHandle) --- | Starts a new session.------ > runSession "hie" fullCaps "path/to/root/dir" $ do--- > doc <- openDoc "Desktop/simple.hs" "haskell"--- > diags <- waitForDiagnostics--- > let pos = Position 12 5--- > params = TextDocumentPositionParams doc--- > hover <- request STextdocumentHover params-runSession :: String -- ^ The command to run the server.- -> ClientCapabilities -- ^ The capabilities that the client should declare.- -> FilePath -- ^ The filepath to the root directory for the session.- -> Session a -- ^ The session to run.- -> IO a+{- | Starts a new session.++ > runSession "hie" fullLatestClientCaps "path/to/root/dir" $ do+ > doc <- openDoc "Desktop/simple.hs" "haskell"+ > diags <- waitForDiagnostics+ > let pos = Position 12 5+ > params = TextDocumentPositionParams doc+ > hover <- request STextdocumentHover params+-}+runSession ::+ -- | The command to run the server.+ String ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSession = runSessionWithConfig def -- | Starts a new session with a custom configuration.-runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.- -> String -- ^ The command to run the server.- -> ClientCapabilities -- ^ The capabilities that the client should declare.- -> FilePath -- ^ The filepath to the root directory for the session.- -> Session a -- ^ The session to run.- -> IO a+runSessionWithConfig ::+ -- | Configuration options for the session.+ SessionConfig ->+ -- | The command to run the server.+ String ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSessionWithConfig = runSessionWithConfigCustomProcess id -- | Starts a new session with a custom configuration and server 'CreateProcess'.-runSessionWithConfigCustomProcess :: (CreateProcess -> CreateProcess) -- ^ Tweak the 'CreateProcess' used to start the server.- -> SessionConfig -- ^ Configuration options for the session.- -> String -- ^ The command to run the server.- -> ClientCapabilities -- ^ The capabilities that the client should declare.- -> FilePath -- ^ The filepath to the root directory for the session.- -> Session a -- ^ The session to run.- -> IO a+runSessionWithConfigCustomProcess ::+ -- | Tweak the 'CreateProcess' used to start the server.+ (CreateProcess -> CreateProcess) ->+ -- | Configuration options for the session.+ SessionConfig ->+ -- | The command to run the server.+ String ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSessionWithConfigCustomProcess modifyCreateProcess config' serverExe caps rootDir session = do config <- envOverrideConfig config' withServer serverExe (logStdErr config) modifyCreateProcess $ \serverIn serverOut serverProc -> runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session --- | Starts a new session, using the specified handles to communicate with the--- server. You can use this to host the server within the same process.--- An example with lsp might look like:------ > (hinRead, hinWrite) <- createPipe--- > (houtRead, houtWrite) <- createPipe--- >--- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition--- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do--- > -- ...-runSessionWithHandles :: Handle -- ^ The input handle- -> Handle -- ^ The output handle- -> SessionConfig- -> ClientCapabilities -- ^ The capabilities that the client should declare.- -> FilePath -- ^ The filepath to the root directory for the session.- -> Session a -- ^ The session to run.- -> IO a-runSessionWithHandles = runSessionWithHandles' Nothing+{- | Starts a new session, using the specified handles to communicate with the+ server. You can use this to host the server within the same process.+ An example with lsp might look like: + > (hinRead, hinWrite) <- createPipe+ > (houtRead, houtWrite) <- createPipe+ >+ > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition+ > runSessionWithHandles hinWrite houtRead defaultConfig fullLatestClientCaps "." $ do+ > -- ...+-}+runSessionWithHandles ::+ -- | The input handle+ Handle ->+ -- | The output handle+ Handle ->+ SessionConfig ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a+runSessionWithHandles = runSessionWithHandles' Nothing -runSessionWithHandles' :: Maybe ProcessHandle- -> Handle -- ^ The input handle- -> Handle -- ^ The output handle- -> SessionConfig- -> ClientCapabilities -- ^ The capabilities that the client should declare.- -> FilePath -- ^ The filepath to the root directory for the session.- -> Session a -- ^ The session to run.- -> IO a+runSessionWithHandles' ::+ Maybe ProcessHandle ->+ -- | The input handle+ Handle ->+ -- | The output handle+ Handle ->+ SessionConfig ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir config <- envOverrideConfig config' - 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- (lspConfig config')- (Just TraceValues_Off)- (fmap InL $ initialWorkspaceFolders config)+ let initializeParams =+ InitializeParams+ { _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@@ -243,10 +321,6 @@ liftIO $ putMVar initRspVar initRspMsg sendNotification SMethod_Initialized InitializedParams - case lspConfig config of- Just cfg -> sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)- Nothing -> return ()- -- ... relay them back to the user Session so they can match on them! -- As long as they are allowed. forM_ inBetween checkLegalBetweenMessage@@ -255,12 +329,12 @@ -- Run the actual test session- where- -- | Asks the server to shutdown and exit politely+ where+ -- \| Asks the server to shutdown and exit politely exitServer :: Session () exitServer = request_ SMethod_Shutdown Nothing >> sendNotification SMethod_Exit Nothing - -- | Listens to the server output until the shutdown ACK,+ -- \| Listens to the server output until the shutdown ACK, -- makes sure it matches the record and signals any semaphores listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do@@ -272,9 +346,9 @@ case msg of (FromServerRsp SMethod_Shutdown _) -> return ()- _ -> listenServer serverOut context+ _ -> listenServer serverOut context - -- | Is this message allowed to be sent by the server between the intialize+ -- \| Is this message allowed to be sent by the server between the intialize -- request and response? -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize checkLegalBetweenMessage :: FromServerMessage -> Session ()@@ -289,46 +363,50 @@ envOverrideConfig cfg = do logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES" logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"- return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }- where checkEnv :: String -> IO (Maybe Bool)- checkEnv s = fmap convertVal <$> lookupEnv s- convertVal "0" = False- convertVal _ = True+ return $ cfg{logMessages = logMessages', logStdErr = logStdErr'}+ where+ checkEnv :: String -> IO (Maybe Bool)+ checkEnv s = fmap convertVal <$> lookupEnv s+ convertVal "0" = False+ convertVal _ = True -- | The current text contents of a document. 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--- and returns the new content+{- | Parses an ApplyEditRequest, checks that it is for the passed document+ and returns the new content+-} getDocumentEdit :: TextDocumentIdentifier -> Session T.Text getDocumentEdit doc = do req <- message SMethod_WorkspaceApplyEdit unless (checkDocumentChanges req || checkChanges req) $- liftIO $ throw (IncorrectApplyEditRequest (show req))+ liftIO $+ throw (IncorrectApplyEditRequest (show req)) documentContents doc- where- checkDocumentChanges req =- let changes = req ^. L.params . L.edit . L.documentChanges- maybeDocs = fmap (fmap documentChangeUri) changes- in case maybeDocs of- Just docs -> (doc ^. L.uri) `elem` docs- Nothing -> False- checkChanges req =- let mMap = req ^. L.params . L.edit . L.changes- in maybe False (Map.member (doc ^. L.uri)) mMap+ where+ checkDocumentChanges req =+ let changes = req ^. L.params . L.edit . L.documentChanges+ maybeDocs = fmap (fmap documentChangeUri) changes+ in case maybeDocs of+ Just docs -> (doc ^. L.uri) `elem` docs+ Nothing -> False+ checkChanges req =+ let mMap = req ^. L.params . L.edit . L.changes+ in maybe False (Map.member (doc ^. L.uri)) mMap --- | Sends a request to the server and waits for its response.--- Will skip any messages in between the request and the response--- @--- rsp <- request STextDocumentDocumentSymbol params--- @--- Note: will skip any messages in between the request and the response.+{- | Sends a request to the server and waits for its response.+ Will skip any messages in between the request and the response+ @+ rsp <- request STextDocumentDocumentSymbol params+ @+ Note: will skip any messages in between the request and the response.+-} request :: SClientMethod m -> MessageParams m -> Session (TResponseMessage m) request m = sendRequest m >=> skipManyTill anyMessage . responseForId m @@ -337,21 +415,25 @@ request_ p = void . request p -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.-sendRequest- :: SClientMethod m -- ^ The request method.- -> MessageParams m -- ^ The request parameters.- -> Session (LspId m) -- ^ The id of the request that was sent.+sendRequest ::+ -- | The request method.+ SClientMethod m ->+ -- | The request parameters.+ MessageParams m ->+ -- | The id of the request that was sent.+ Session (LspId m) sendRequest method params = do idn <- curReqId <$> get- modify $ \c -> c { curReqId = idn+1 }+ modify $ \c -> c{curReqId = idn + 1} let id = IdInt idn let mess = TRequestMessage "2.0" id method params -- Update the request map reqMap <- requestMap <$> ask- liftIO $ modifyMVar_ reqMap $- \r -> return $ fromJust $ updateRequestMap r id method+ liftIO $+ modifyMVar_ reqMap $+ \r -> return $ fromJust $ updateRequestMap r id method ~() <- case splitClientMethod method of IsClientReq -> sendMessage mess@@ -360,15 +442,18 @@ return id -- | Sends a notification to the server.-sendNotification :: SClientMethod (m :: Method ClientToServer Notification) -- ^ The notification method.- -> MessageParams m -- ^ The notification parameters.- -> Session ()+sendNotification ::+ -- | The notification method.+ SClientMethod (m :: Method ClientToServer Notification) ->+ -- | The notification parameters.+ MessageParams m ->+ Session () -- Open a virtual file if we send a did open text document notification sendNotification SMethod_TextDocumentDidOpen params = do let n = TNotificationMessage "2.0" SMethod_TextDocumentDidOpen params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ openVFS mempty n- modify (\s -> s { vfs = newVFS })+ modify (\s -> s{vfs = newVFS}) sendMessage n -- Close a virtual file if we send a close text document notification@@ -376,16 +461,14 @@ let n = TNotificationMessage "2.0" SMethod_TextDocumentDidClose params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ closeVFS mempty n- modify (\s -> s { vfs = newVFS })+ modify (\s -> s{vfs = newVFS}) sendMessage n- sendNotification SMethod_TextDocumentDidChange params = do let n = TNotificationMessage "2.0" SMethod_TextDocumentDidChange params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ changeFromClientVFS mempty n- modify (\s -> s { vfs = newVFS })+ modify (\s -> s{vfs = newVFS}) sendMessage n- sendNotification method params = case splitClientMethod method of IsClientNot -> sendMessage (TNotificationMessage "2.0" method params)@@ -395,25 +478,93 @@ sendResponse :: (ToJSON (MessageResult m), ToJSON (ErrorData m)) => TResponseMessage m -> Session () sendResponse = sendMessage --- | Returns the initialize response that was received from the server.--- The initialize requests and responses are not included the session,--- so if you need to test it use this.+{- | Returns the initialize response that was received from the server.+ The initialize requests and responses are not included the session,+ so if you need to test it use this.+-} initializeResponse :: Session (TResponseMessage Method_Initialize) initializeResponse = ask >>= (liftIO . readMVar) . initRsp --- | /Creates/ a new text document. This is different from 'openDoc'--- as it sends a workspace/didChangeWatchedFiles notification letting the server--- know that a file was created within the workspace, __provided that the server--- has registered for it__, and the file matches any patterns the server--- registered for.--- It /does not/ actually create a file on disk, but is useful for convincing--- the server that one does exist.------ @since 11.0.0.0-createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__.- -> T.Text -- ^ The text document's language identifier, e.g. @"haskell"@.- -> T.Text -- ^ The content of the text document to create.- -> Session TextDocumentIdentifier -- ^ The identifier of the document just created.+setIgnoringLogNotifications :: Bool -> Session ()+setIgnoringLogNotifications value = do+ modify (\ss -> ss{ignoringLogNotifications = value})++setIgnoringConfigurationRequests :: Bool -> Session ()+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.+-}+modifyConfig :: (Object -> Object) -> Session ()+modifyConfig f = do+ oldConfig <- curLspConfig <$> get+ let newConfig = f oldConfig+ modify (\ss -> ss{curLspConfig = 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+ config has changed.+-}+setConfig :: Object -> Session ()+setConfig newConfig = modifyConfig (const newConfig)++{- | Modify a client config section (if already present, otherwise does nothing).+ This will send a notification to the server that the config has changed.+-}+modifyConfigSection :: String -> (Value -> Value) -> Session ()+modifyConfigSection section f = modifyConfig (\o -> o & ix (fromString section) %~ f)++{- | Set a client config section. This will send a notification to the server that the+ config has changed.+-}+setConfigSection :: String -> Value -> Session ()+setConfigSection section settings = modifyConfig (\o -> o & at (fromString section) ?~ settings)++{- | /Creates/ a new text document. This is different from 'openDoc'+ as it sends a workspace/didChangeWatchedFiles notification letting the server+ know that a file was created within the workspace, __provided that the server+ has registered for it__, and the file matches any patterns the server+ registered for.+ It /does not/ actually create a file on disk, but is useful for convincing+ the server that one does exist.++ @since 11.0.0.0+-}+createDoc ::+ -- | The path to the document to open, __relative to the root directory__.+ FilePath ->+ -- | The text document's language identifier, e.g. @"haskell"@.+ LanguageKind ->+ -- | The content of the text document to create.+ T.Text ->+ -- | The identifier of the document just created.+ Session TextDocumentIdentifier createDoc file languageId contents = do dynCaps <- curDynCaps <$> get rootDir <- asks rootDir@@ -422,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@@ -431,36 +582,40 @@ watchHits _ = False fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs+ where -- If the pattern is absolute then match against the absolute fp- where relOrAbs- | isAbsolute pattern = absFile- | otherwise = file+ relOrAbs+ | isAbsolute pattern = absFile+ | otherwise = file regHits :: TRegistration Method_WorkspaceDidChangeWatchedFiles -> Bool regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. L.registerOptions . _Just . L.watchers) clientCapsSupports =- caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just- == Just True+ caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just+ == Just True shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs when shouldSend $- sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $- [ FileEvent (filePathToUri (rootDir </> file)) FileChangeType_Created ]+ sendNotification SMethod_WorkspaceDidChangeWatchedFiles $+ DidChangeWatchedFilesParams $+ [FileEvent (filePathToUri (rootDir </> file)) FileChangeType_Created] openDoc' file languageId contents --- | Opens a text document that /exists on disk/, and sends a--- textDocument/didOpen notification to the server.-openDoc :: FilePath -> T.Text -> Session TextDocumentIdentifier+{- | Opens a text document that /exists on disk/, and sends a+ textDocument/didOpen notification to the server.+-}+openDoc :: FilePath -> LanguageKind -> Session TextDocumentIdentifier openDoc file languageId = do context <- ask let fp = rootDir context </> file contents <- liftIO $ T.readFile fp openDoc' file languageId contents --- | 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+{- | 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 -> LanguageKind -> T.Text -> Session TextDocumentIdentifier openDoc' file languageId contents = do context <- ask let fp = rootDir context </> file@@ -496,8 +651,9 @@ let diags = diagsNot ^. L.params . L.diagnostics return diags --- | The same as 'waitForDiagnostics', but will only match a specific--- 'Language.LSP.Types._source'.+{- | The same as 'waitForDiagnostics', but will only match a specific+ 'Language.LSP.Types._source'.+-} waitForDiagnosticsSource :: String -> Session [Diagnostic] waitForDiagnosticsSource src = do diags <- waitForDiagnostics@@ -505,13 +661,14 @@ if null res then waitForDiagnosticsSource src else return res- where- matches :: Diagnostic -> Bool- matches d = d ^. L.source == Just (T.pack src)+ where+ matches :: Diagnostic -> Bool+ matches d = d ^. L.source == Just (T.pack src) --- | Expects a 'PublishDiagnosticsNotification' and throws an--- 'UnexpectedDiagnostics' exception if there are any diagnostics--- returned.+{- | Expects a 'PublishDiagnosticsNotification' and throws an+ 'UnexpectedDiagnostics' exception if there are any diagnostics+ returned.+-} noDiagnostics :: Session () noDiagnostics = do diagsNot <- message SMethod_TextDocumentPublishDiagnostics@@ -525,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]@@ -536,53 +693,54 @@ 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.+{- | Returns the code actions in the specified range, resolving any with+ a non empty _data_ field.+-} getAndResolveCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] getAndResolveCodeActions doc range = do items <- getCodeActions doc range- for items $ \case + for items $ \case l@(InL _) -> pure l- (InR r) | isJust (r ^. L.data_) -> InR <$> resolveCodeAction r+ (InR r) | isJust (r ^. L.data_) -> InR <$> resolveCodeAction r r@(InR _) -> pure r --- | Returns all the code actions in a document by--- querying the code actions at each of the current--- diagnostics' positions.+{- | Returns all the code actions in a document by+ querying the code actions at each of the current+ diagnostics' positions.+-} getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction] getAllCodeActions doc = do ctx <- getCodeActionContext doc foldM (go ctx) [] =<< getCurrentDiagnostics doc-- where- go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]- go ctx acc diag = do- TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx)+ where+ go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]+ go ctx acc diag = do+ 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)- Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs)- Right (InR _) -> pure acc+ case res of+ Left e -> throw (UnexpectedResponseError (fromJust rspLid) e)+ Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs)+ Right (InR _) -> pure acc getCodeActionContextInRange :: TextDocumentIdentifier -> Range -> Session CodeActionContext getCodeActionContextInRange doc caRange = do curDiags <- getCurrentDiagnostics doc- let diags = [ d | d@Diagnostic{_range=range} <- curDiags- , overlappingRange caRange range- ]+ let diags =+ [ d | d@Diagnostic{_range = range} <- curDiags, overlappingRange caRange range+ ] return $ CodeActionContext diags Nothing Nothing- where- overlappingRange :: Range -> Range -> Bool- overlappingRange (Range s e) range =- positionInRange s range+ where+ overlappingRange :: Range -> Range -> Bool+ overlappingRange (Range s e) range =+ positionInRange s range || positionInRange e range - positionInRange :: Position -> Range -> Bool- positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =- pl > sl && pl < el+ positionInRange :: Position -> Range -> Bool+ positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =+ pl > sl && pl < el || pl == sl && pl == el && po >= so && po <= eo || pl == sl && po >= so || pl == el && po <= eo@@ -592,10 +750,11 @@ curDiags <- getCurrentDiagnostics doc return $ CodeActionContext curDiags Nothing Nothing --- | Returns the current diagnostics that have been sent to the client.--- Note that this does not wait for more to come in.+{- | Returns the current diagnostics that have been sent to the client.+ 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)@@ -608,33 +767,35 @@ execParams = ExecuteCommandParams Nothing (cmd ^. L.command) args void $ sendRequest SMethod_WorkspaceExecuteCommand execParams --- | Executes a code action.--- Matching with the specification, if a code action--- contains both an edit and a command, the edit will--- be applied first.+{- | Executes a code action.+ Matching with the specification, if a code action+ contains both an edit and a command, the edit will+ be applied first.+-} executeCodeAction :: CodeAction -> Session () executeCodeAction action = do maybe (return ()) handleEdit $ action ^. L.edit maybe (return ()) executeCommand $ action ^. L.command-- where handleEdit :: WorkspaceEdit -> Session ()- handleEdit e =- -- Its ok to pass in dummy parameters here as they aren't used- let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)- in updateState (FromServerMess SMethod_WorkspaceApplyEdit req)+ where+ handleEdit :: WorkspaceEdit -> Session ()+ handleEdit e =+ -- Its ok to pass in dummy parameters here as they aren't used+ 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 --- executes it. Otherwise, just executes it.+{- | If a code action contains a _data_ field: resolves the code action, then+ executes it. Otherwise, just executes it.+-} resolveAndExecuteCodeAction :: CodeAction -> Session ()-resolveAndExecuteCodeAction ca@CodeAction{_data_=Just _} = do+resolveAndExecuteCodeAction ca@CodeAction{_data_ = Just _} = do caRsp <- resolveCodeAction ca executeCodeAction caRsp resolveAndExecuteCodeAction ca = executeCodeAction ca@@ -643,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))@@ -651,20 +812,20 @@ -- | Applys an edit to the document and returns the updated document version. applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier applyEdit doc edit = do- verDoc <- getVersionedDoc doc caps <- asks sessionCapabilities let supportsDocChanges = fromMaybe False $ caps ^? L.workspace . _Just . L.workspaceEdit . _Just . L.documentChanges . _Just - let wEdit = if supportsDocChanges- then- let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit]- in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing- else- let changes = Map.singleton (doc ^. L.uri) [edit]- in WorkspaceEdit (Just changes) Nothing Nothing+ let wEdit =+ if supportsDocChanges+ then+ let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit]+ in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing+ else+ let changes = Map.singleton (doc ^. L.uri) [edit]+ in WorkspaceEdit (Just changes) Nothing Nothing let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) updateState (FromServerMess SMethod_WorkspaceApplyEdit req)@@ -682,59 +843,77 @@ InR (InL c) -> return $ c ^. L.items InR (InR _) -> return [] --- | Returns the completions for the position in the document, resolving any with --- a non empty _data_ field.+{- | Returns the completions for the position in the document, resolving any with+ a non empty _data_ field.+-} getAndResolveCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getAndResolveCompletions doc pos = do 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 :: TextDocumentIdentifier -- ^ The document to lookup in.- -> Position -- ^ The position to lookup.- -> Bool -- ^ Whether to include declarations as references.- -> Session [Location] -- ^ The locations of the references.+getReferences ::+ -- | The document to lookup in.+ TextDocumentIdentifier ->+ -- | The position to lookup.+ Position ->+ -- | Whether to include declarations as references.+ Bool ->+ -- | The locations of the references.+ Session [Location] getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl params = ReferenceParams doc pos Nothing Nothing ctx- in absorbNull . getResponseResult <$> request SMethod_TextDocumentReferences params+ in absorbNull . getResponseResult <$> request SMethod_TextDocumentReferences params -- | Returns the declarations(s) for the term at the specified position.-getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in.- -> Position -- ^ The position the term is at.- -> Session (Declaration |? [DeclarationLink] |? Null)+getDeclarations ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ Session (Declaration |? [DeclarationLink] |? Null) getDeclarations doc pos = do rsp <- request SMethod_TextDocumentDeclaration (DeclarationParams doc pos Nothing Nothing) pure $ getResponseResult rsp -- | Returns the definition(s) for the term at the specified position.-getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.- -> Position -- ^ The position the term is at.- -> Session (Definition |? [DefinitionLink] |? Null)+getDefinitions ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ Session (Definition |? [DefinitionLink] |? Null) getDefinitions doc pos = do rsp <- request SMethod_TextDocumentDefinition (DefinitionParams doc pos Nothing Nothing) pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position.-getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.- -> Position -- ^ The position the term is at.- -> Session (Definition |? [DefinitionLink] |? Null)+getTypeDefinitions ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ Session (Definition |? [DefinitionLink] |? Null) getTypeDefinitions doc pos = do rsp <- request SMethod_TextDocumentTypeDefinition (TypeDefinitionParams doc pos Nothing Nothing) pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position.-getImplementations :: TextDocumentIdentifier -- ^ The document the term is in.- -> Position -- ^ The position the term is at.- -> Session (Definition |? [DefinitionLink] |? Null)+getImplementations ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ Session (Definition |? [DefinitionLink] |? Null) getImplementations doc pos = do rsp <- request SMethod_TextDocumentImplementation (ImplementationParams doc pos Nothing Nothing) pure $ getResponseResult rsp@@ -755,21 +934,28 @@ getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) getHover doc pos = let params = HoverParams doc pos Nothing- in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params+ 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 = let params = DocumentHighlightParams doc pos Nothing Nothing- in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params+ in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params --- | Checks the response for errors and throws an exception if needed.--- Returns the result if successful.-getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m+{- | Checks the response for errors and throws an exception if needed.+ Returns the result if successful.+-}+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 ()@@ -790,29 +976,52 @@ let wEdit = WorkspaceEdit (Just (Map.singleton (doc ^. L.uri) edits)) Nothing Nothing -- Send a dummy message to updateState so it can do bookkeeping req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)- in updateState (FromServerMess SMethod_WorkspaceApplyEdit req)+ in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do- rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId)- pure $ absorbNull $ getResponseResult rsp+ rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId)+ pure $ absorbNull $ getResponseResult rsp --- | Returns the code lenses for the specified document, resolving any with --- a non empty _data_ field.+{- | Returns the code lenses for the specified document, resolving any with+ a non empty _data_ field.+-} getAndResolveCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getAndResolveCodeLenses tId = do- codeLenses <- getCodeLenses tId- for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens+ 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@@ -824,25 +1033,40 @@ outgoingCalls = resolveRequestWithListResp SMethod_CallHierarchyOutgoingCalls -- | Send a request and receive a response with list.-resolveRequestWithListResp :: forall (m :: Method ClientToServer Request) a- . (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null))- => SMethod m- -> MessageParams m- -> Session [a]+resolveRequestWithListResp ::+ forall (m :: Method ClientToServer Request) a.+ (Show (ErrorData m), MessageResult m ~ ([a] |? Null)) =>+ SMethod m ->+ MessageParams m ->+ Session [a] resolveRequestWithListResp method params = do 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 --- | Returns a list of capabilities that the server has requested to /dynamically/--- register during the 'Session'.------ @since 0.11.0.0+{- | 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/+ register during the 'Session'.++ @since 0.11.0.0+-} getRegisteredCapabilities :: Session [SomeRegistration] getRegisteredCapabilities = Map.elems . curDynCaps <$> get
src/Language/LSP/Test/Compat.hs view
@@ -1,17 +1,16 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} -- For some reason ghc warns about not using -- Control.Monad.IO.Class but it's needed for -- MonadIO {-# OPTIONS_GHC -Wunused-imports #-}+ module Language.LSP.Test.Compat where -import Data.Row import Data.Maybe-import qualified Data.Text as T+import Language.LSP.Protocol.Types qualified as L import System.IO #if MIN_VERSION_process(1,6,3)@@ -44,7 +43,6 @@ import qualified System.Posix.Process #endif - getCurrentProcessID :: IO Int #ifdef mingw32_HOST_OS getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId@@ -54,7 +52,7 @@ getProcessID :: ProcessHandle -> IO Int getProcessID p = fromIntegral . fromJust <$> getProcessID' p- where+ where #if MIN_VERSION_process(1,6,3) getProcessID' = System.Process.getPid #else@@ -75,13 +73,12 @@ _ -> return Nothing #endif -cleanupProcess- :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()--withCreateProcess- :: CreateProcess- -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)- -> IO a+cleanupProcess ::+ (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()+withCreateProcess ::+ CreateProcess ->+ (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) ->+ IO a #if MIN_VERSION_process(1,6,4) @@ -105,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@@ -120,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,55 +1,58 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE OverloadedStrings #-}+ module Language.LSP.Test.Decoding where -import Prelude hiding ( id )-import Data.Aeson-import Data.Aeson.Types-import Data.Foldable-import Data.Functor.Product-import Data.Functor.Const-import Control.Exception-import Control.Lens-import qualified Data.ByteString.Lazy.Char8 as B-import Data.Maybe-import System.IO-import System.IO.Error-import Language.LSP.Protocol.Message-import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Test.Exceptions+import Control.Exception+import Control.Lens+import Data.Aeson+import Data.Aeson.Types+import Data.ByteString.Lazy.Char8 qualified as B+import Data.Foldable+import Data.Functor.Product+import Data.Maybe+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Test.Exceptions+import System.IO+import System.IO.Error+import Prelude hiding (id) import Data.IxMap import Data.Kind --- | Fetches the next message bytes based on--- the Content-Length header+{- | Fetches the next message bytes based on+ the Content-Length header+-} getNextMessage :: Handle -> IO B.ByteString getNextMessage h = do headers <- getHeaders h case read . init <$> lookup "Content-Length" headers of- Nothing -> throw NoContentLengthHeader+ Nothing -> throw NoContentLengthHeader Just size -> B.hGet h size addHeader :: B.ByteString -> B.ByteString-addHeader content = B.concat- [ "Content-Length: "- , B.pack $ show $ B.length content- , "\r\n"- , "\r\n"- , content- ]+addHeader content =+ B.concat+ [ "Content-Length: "+ , B.pack $ show $ B.length content+ , "\r\n"+ , "\r\n"+ , content+ ] getHeaders :: Handle -> IO [(String, String)] getHeaders h = do l <- catch (hGetLine h) eofHandler let (name, val) = span (/= ':') l if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h- where eofHandler e- | isEOFError e = throw UnexpectedServerTermination- | otherwise = throw e+ where+ eofHandler e+ | isEOFError e = throw UnexpectedServerTermination+ | otherwise = throw e -type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type )+type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type) newRequestMap :: RequestMap newRequestMap = emptyIxMap@@ -72,22 +75,24 @@ decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage) decodeFromServerMsg reqMap bytes = unP $ parse p obj- where obj = fromJust $ decode bytes :: Value- p = parseServerMessage $ \lid ->- let (mm, newMap) = pickFromIxMap lid reqMap- in case mm of- Nothing -> Nothing- 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- {-- WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"- WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"- CustomServerMethod _- | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes- | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes- | otherwise -> NotCustomServer $ fromJust $ decode bytes+ where+ obj = fromJust $ decode bytes :: Value+ p = parseServerMessage $ \lid ->+ let (mm, newMap) = pickFromIxMap lid reqMap+ in case mm of+ Nothing -> Nothing+ 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 - Error e -> error e- -}+{-+ WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"+ WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"+ CustomServerMethod _+ | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes+ | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes+ | otherwise -> NotCustomServer $ fromJust $ decode bytes++Error e -> error e+-}
src/Language/LSP/Test/Exceptions.hs view
@@ -1,59 +1,74 @@ module Language.LSP.Test.Exceptions where import Control.Exception-import Language.LSP.Protocol.Message import Data.Aeson import Data.Aeson.Encode.Pretty import Data.Algorithm.Diff import Data.Algorithm.DiffOutput+import Data.ByteString.Lazy.Char8 qualified as B import Data.List-import qualified Data.ByteString.Lazy.Char8 as B+import Language.LSP.Protocol.Message -- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session'-data SessionException = Timeout (Maybe FromServerMessage)- | NoContentLengthHeader- | UnexpectedMessage String FromServerMessage- | ReplayOutOfOrder FromServerMessage [FromServerMessage]- | UnexpectedDiagnostics- | IncorrectApplyEditRequest String- | UnexpectedResponseError SomeLspId ResponseError- | UnexpectedServerTermination- | IllegalInitSequenceMessage FromServerMessage- | MessageSendError Value IOError- deriving Eq+data SessionException+ = Timeout (Maybe FromServerMessage)+ | NoContentLengthHeader+ | UnexpectedMessage String FromServerMessage+ | ReplayOutOfOrder FromServerMessage [FromServerMessage]+ | UnexpectedDiagnostics+ | IncorrectApplyEditRequest String+ | forall m. Show (ErrorData m) => UnexpectedResponseError (LspId m) (TResponseError m)+ | UnexpectedServerTermination+ | IllegalInitSequenceMessage FromServerMessage+ | MessageSendError Value IOError instance Exception SessionException instance Show SessionException where show (Timeout lastMsg) =- "Timed out waiting to receive a message from the server." ++- case lastMsg of- Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg)- Nothing -> mempty+ "Timed out waiting to receive a message from the server."+ ++ case lastMsg of+ Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg)+ Nothing -> mempty show NoContentLengthHeader = "Couldn't read Content-Length header from the server." show (UnexpectedMessage expected lastMsg) =- "Received an unexpected message from the server:\n" ++- "Was parsing: " ++ expected ++ "\n" ++- "But the last message received was:\n" ++ B.unpack (encodePretty lastMsg)+ "Received an unexpected message from the server:\n"+ ++ "Was parsing: "+ ++ expected+ ++ "\n"+ ++ "But the last message received was:\n"+ ++ B.unpack (encodePretty lastMsg) show (ReplayOutOfOrder received expected) = let expected' = nub expected getJsonDiff = lines . B.unpack . encodePretty- showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" ++- ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp))- in "Replay is out of order:\n" ++- -- Print json so its a bit easier to update the session logs- "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" ++- "Raw from server:\n" ++ B.unpack (encode received) ++ "\n" ++- "Expected one of:\n" ++ unlines (map showExp expected')+ showExp exp =+ B.unpack (encodePretty exp)+ ++ "\nDiff:\n"+ ++ ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp))+ in "Replay is out of order:\n"+ +++ -- Print json so its a bit easier to update the session logs+ "Received from server:\n"+ ++ B.unpack (encodePretty received)+ ++ "\n"+ ++ "Raw from server:\n"+ ++ B.unpack (encode received)+ ++ "\n"+ ++ "Expected one of:\n"+ ++ unlines (map showExp expected') show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server."- show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n"- ++ msgStr- show (UnexpectedResponseError lid e) = "Received an expected error in a response for id " ++ show lid ++ ":\n"- ++ show e+ show (IncorrectApplyEditRequest msgStr) =+ "ApplyEditRequest didn't contain document, instead received:\n"+ ++ msgStr+ show (UnexpectedResponseError lid e) =+ "Received an expected error in a response for id "+ ++ show lid+ ++ ":\n"+ ++ show e show UnexpectedServerTermination = "Language server unexpectedly terminated" show (IllegalInitSequenceMessage msg) = "Received an illegal message between the initialize request and response:\n"- ++ B.unpack (encodePretty msg)+ ++ B.unpack (encodePretty msg) show (MessageSendError msg e) = "IO exception:\n" ++ show e ++ "\narose while trying to send message:\n" ++ B.unpack (encodePretty msg)
src/Language/LSP/Test/Files.hs view
@@ -1,25 +1,23 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}-module Language.LSP.Test.Files- ( swapFiles- , rootDir- )++module Language.LSP.Test.Files (+ swapFiles,+ rootDir,+) where -import Language.LSP.Protocol.Message-import Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Lens as L-import Control.Lens-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import Data.Maybe-import System.Directory-import System.FilePath+import Control.Lens+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Text qualified as T import Data.Time.Clock+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import System.Directory+import System.FilePath data Event = ClientEv UTCTime FromClientMessage@@ -33,17 +31,17 @@ let transform uri = let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) newFp = curBaseDir </> makeRelative capturedBaseDir fp- in filePathToUri newFp+ in filePathToUri newFp newMsgs = map (mapUris transform) msgs return newMsgs rootDir :: [Event] -> FilePath-rootDir (ClientEv _ (FromClientMess SMethod_Initialize req):_) =+rootDir (ClientEv _ (FromClientMess SMethod_Initialize req) : _) = fromMaybe (error "Couldn't find root dir") $ do rootUri <- case req ^. L.params . L.rootUri of- InL r -> Just r- InR _ -> error "Couldn't find root dir"+ InL r -> Just r+ InR _ -> error "Couldn't find root dir" uriToFilePath rootUri rootDir _ = error "Couldn't find initialize request in session" @@ -52,58 +50,54 @@ case event of ClientEv t msg -> ClientEv t (fromClientMsg msg) ServerEv t msg -> ServerEv t (fromServerMsg msg)-- where- --TODO: Handle all other URIs that might need swapped- fromClientMsg (FromClientMess m@SMethod_Initialize r) = FromClientMess m $ L.params .~ transformInit (r ^. L.params) $ r- fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen n) = FromClientMess m $ swapUri (L.params . L.textDocument) n- fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange n) = FromClientMess m $ swapUri (L.params . L.textDocument) n- fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n- fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n- fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose n) = FromClientMess m $ swapUri (L.params . L.textDocument) n- fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (L.params . L.textDocument) n- fromClientMsg (FromClientMess m@SMethod_TextDocumentRename n) = FromClientMess m $ swapUri (L.params . L.textDocument) n- fromClientMsg x = x-- fromServerMsg :: FromServerMessage -> FromServerMessage- fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ L.params . L.edit .~ swapWorkspaceEdit (r ^. L.params . L.edit) $ r- fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri L.params n- fromServerMsg (FromServerRsp m@SMethod_TextDocumentDocumentSymbol r) =- let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null- swapUri' (InR (InL dss)) = InR $ InL dss -- no file locations here- swapUri' (InR (InR n)) = InR $ InR n- swapUri' (InL si) = InL (swapUri L.location <$> si)- in FromServerRsp m $ r & L.result . _Right %~ swapUri'- fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & L.result . _Right . _L %~ swapWorkspaceEdit- fromServerMsg x = x+ where+ -- TODO: Handle all other URIs that might need swapped+ fromClientMsg (FromClientMess m@SMethod_Initialize r) = FromClientMess m $ L.params .~ transformInit (r ^. L.params) $ r+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentRename n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg x = x - swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit- swapWorkspaceEdit e =- let swapDocumentChangeUri :: DocumentChange -> DocumentChange- swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri L.textDocument textDocEdit- swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile- -- for RenameFile, we swap `newUri`- 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.documentChanges . _Just . traversed%~ swapDocumentChangeUri+ fromServerMsg :: FromServerMessage -> FromServerMessage+ fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ L.params . L.edit .~ swapWorkspaceEdit (r ^. L.params . L.edit) $ r+ fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri L.params n+ fromServerMsg (FromServerRsp m@SMethod_TextDocumentDocumentSymbol r) =+ let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null+ swapUri' (InR (InL dss)) = InR $ InL dss -- no file locations here+ swapUri' (InR (InR n)) = InR $ InR n+ swapUri' (InL si) = InL (swapUri L.location <$> si)+ in FromServerRsp m $ r & L.result . _Right %~ swapUri'+ fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & L.result . _Right . _L %~ swapWorkspaceEdit+ fromServerMsg x = x - 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+ swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit+ swapWorkspaceEdit e =+ let swapDocumentChangeUri :: DocumentChange -> DocumentChange+ swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri L.textDocument textDocEdit+ swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile+ -- for RenameFile, we swap `newUri`+ 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 %~ M.mapKeys f+ & L.documentChanges . _Just . traversed %~ swapDocumentChangeUri - 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 :: L.HasUri b Uri => Lens' a b -> a -> a+ swapUri lens = (lens . L.uri) %~ f - -- | Transforms rootUri/rootPath.- transformInit :: InitializeParams -> InitializeParams- transformInit x =- let modifyRootPath p =- let fp = T.unpack p- uri = filePathToUri fp- in case uriToFilePath (f uri) of- Just fp -> T.pack fp- Nothing -> p- in x & L.rootUri . _L %~ f- & L.rootPath . _Just . _L %~ modifyRootPath+ -- Transforms rootUri/rootPath.+ transformInit :: InitializeParams -> InitializeParams+ transformInit x =+ let modifyRootPath p =+ let fp = T.unpack p+ uri = filePathToUri fp+ in case uriToFilePath (f uri) of+ Just fp -> T.pack fp+ Nothing -> p+ in x+ & L.rootUri . _L %~ f+ & L.rootPath . _Just . _L %~ modifyRootPath
src/Language/LSP/Test/Parsing.hs view
@@ -1,95 +1,97 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} -module Language.LSP.Test.Parsing- ( -- $receiving- satisfy- , satisfyMaybe- , message- , response- , responseForId- , customRequest- , customNotification- , anyRequest- , anyResponse- , anyNotification- , anyMessage- , loggingNotification- , publishDiagnosticsNotification- ) where+module Language.LSP.Test.Parsing (+ -- $receiving+ satisfy,+ satisfyMaybe,+ message,+ response,+ responseForId,+ customRequest,+ customNotification,+ anyRequest,+ anyResponse,+ anyNotification,+ anyMessage,+ loggingNotification,+ configurationRequest,+ loggingOrConfiguration,+ publishDiagnosticsNotification,+) where import Control.Applicative import Control.Concurrent-import Control.Monad.IO.Class import Control.Monad+import Control.Monad.IO.Class import Data.Conduit.Parser hiding (named)-import qualified Data.Conduit.Parser (named)-import qualified Data.Text as T+import Data.Conduit.Parser qualified (named)+import Data.GADT.Compare+import Data.Text qualified as T import Data.Typeable+import GHC.TypeLits (KnownSymbol, symbolVal) import Language.LSP.Protocol.Message import Language.LSP.Test.Session-import GHC.TypeLits (KnownSymbol, symbolVal)-import Data.GADT.Compare --- $receiving--- To receive a message, specify the method of the message to expect:------ @--- msg1 <- message SWorkspaceApplyEdit--- msg2 <- message STextDocumentHover--- @------ 'Language.LSP.Test.Session' is actually just a parser--- that operates on messages under the hood. This means that you--- can create and combine parsers to match specific sequences of--- messages that you expect.------ For example, if you wanted to match either a definition or--- references request:------ > defOrImpl = message STextDocumentDefinition--- > <|> message STextDocumentReferences------ If you wanted to match any number of telemetry--- notifications immediately followed by a response:------ @--- logThenDiags =--- skipManyTill (message STelemetryEvent)--- anyResponse--- @+{- $receiving+ To receive a message, specify the method of the message to expect: --- | Consumes and returns the next message, if it satisfies the specified predicate.------ @since 0.5.2.0+ @+ msg1 <- message SWorkspaceApplyEdit+ msg2 <- message STextDocumentHover+ @++ 'Language.LSP.Test.Session' is actually just a parser+ that operates on messages under the hood. This means that you+ can create and combine parsers to match specific sequences of+ messages that you expect.++ For example, if you wanted to match either a definition or+ references request:++ > defOrImpl = message STextDocumentDefinition+ > <|> message STextDocumentReferences++ If you wanted to match any number of telemetry+ notifications immediately followed by a response:++ @+ logThenDiags =+ skipManyTill (message STelemetryEvent)+ anyResponse+ @+-}++{- | Consumes and returns the next message, if it satisfies the specified predicate.++ @since 0.5.2.0+-} satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) --- | Consumes and returns the result of the specified predicate if it returns `Just`.------ @since 0.6.1.0+{- | Consumes and returns the result of the specified predicate if it returns `Just`.++ @since 0.6.1.0+-} satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a satisfyMaybe pred = satisfyMaybeM (pure . pred) satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a-satisfyMaybeM pred = do - +satisfyMaybeM pred = do skipTimeout <- overridingTimeout <$> get timeoutId <- getCurTimeoutId mtid <- if skipTimeout- then pure Nothing- else Just <$> do- chan <- asks messageChan- timeout <- asks (messageTimeout . config)- liftIO $ forkIO $ do- threadDelay (timeout * 1000000)- writeChan chan (TimeoutMessage timeoutId)+ then pure Nothing+ else+ Just <$> do+ chan <- asks messageChan+ timeout <- asks (messageTimeout . config)+ liftIO $ forkIO $ do+ threadDelay (timeout * 1000000)+ writeChan chan (TimeoutMessage timeoutId) x <- Session await @@ -97,7 +99,7 @@ bumpTimeoutId timeoutId liftIO $ killThread tid - modify $ \s -> s { lastReceivedMessage = Just x }+ modify $ \s -> s{lastReceivedMessage = Just x} res <- pred x @@ -110,9 +112,9 @@ named :: T.Text -> Session a -> Session a named s (Session x) = Session (Data.Conduit.Parser.named s x) ---- | Matches a request or a notification coming from the server.--- Doesn't match Custom Messages+{- | Matches a request or a notification coming from the server.+ Doesn't match Custom Messages+-} message :: SServerMethod m -> Session (TMessage m) message (SMethod_CustomMethod _) = error "message can't be used with CustomMethod, use customRequest or customNotification instead" message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case@@ -126,28 +128,28 @@ customRequest :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Request)) customRequest p = let m = T.pack $ symbolVal p- in named m $ satisfyMaybe $ \case- FromServerMess m1 msg -> case splitServerMethod m1 of- IsServerEither -> case msg of- ReqMess _ -> case m1 `geq` SMethod_CustomMethod p of- Just Refl -> Just msg+ in named m $ satisfyMaybe $ \case+ FromServerMess m1 msg -> case splitServerMethod m1 of+ IsServerEither -> case msg of+ ReqMess _ -> case m1 `geq` SMethod_CustomMethod p of+ Just Refl -> Just msg+ _ -> Nothing+ _ -> Nothing _ -> Nothing _ -> Nothing- _ -> Nothing- _ -> Nothing customNotification :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Notification)) customNotification p = let m = T.pack $ symbolVal p- in named m $ satisfyMaybe $ \case- FromServerMess m1 msg -> case splitServerMethod m1 of- IsServerEither -> case msg of- NotMess _ -> case m1 `geq` SMethod_CustomMethod p of- Just Refl -> Just msg+ in named m $ satisfyMaybe $ \case+ FromServerMess m1 msg -> case splitServerMethod m1 of+ IsServerEither -> case msg of+ NotMess _ -> case m1 `geq` SMethod_CustomMethod p of+ Just Refl -> Just msg+ _ -> Nothing+ _ -> Nothing _ -> Nothing _ -> Nothing- _ -> Nothing- _ -> Nothing -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage@@ -200,15 +202,26 @@ -- | Matches if the message is a log message notification or a show message notification/request. loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip- where- shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True- shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True- shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True- shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True- shouldSkip _ = False+ where+ shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True+ shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True+ shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True+ shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True+ shouldSkip _ = False --- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'--- (textDocument/publishDiagnostics) notification.+-- | Matches if the message is a configuration request from the server.+configurationRequest :: Session FromServerMessage+configurationRequest = named "Configuration request" $ satisfy shouldSkip+ where+ shouldSkip (FromServerMess SMethod_WorkspaceConfiguration _) = True+ shouldSkip _ = False++loggingOrConfiguration :: Session FromServerMessage+loggingOrConfiguration = loggingNotification <|> configurationRequest++{- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'+ (textDocument/publishDiagnostics) notification.+-} publishDiagnosticsNotification :: Session (TMessage Method_TextDocumentPublishDiagnostics) publishDiagnosticsNotification = named "Publish diagnostics notification" $ satisfyMaybe $ \msg -> case msg of
src/Language/LSP/Test/Server.hs view
@@ -10,8 +10,8 @@ withServer serverExe logStdErr modifyCreateProcess f = do -- TODO Probably should just change runServer to accept -- separate command and arguments- let cmd:args = words serverExe- createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+ let cmd : args = words serverExe+ createProc = (proc cmd args){std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe} withCreateProcess (modifyCreateProcess createProc) $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do -- Need to continuously consume to stderr else it gets blocked -- Can't pass NoStream either to std_err
src/Language/LSP/Test/Session.hs view
@@ -1,14 +1,11 @@+{- ORMOLU_DISABLE -}+ {-# 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 DataKinds #-} module Language.LSP.Test.Session ( Session(..)@@ -41,10 +38,10 @@ import Control.Exception import Control.Lens hiding (List, Empty) import Control.Monad-import Control.Monad.Catch (MonadThrow)-import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Except #if __GLASGOW_HASKELL__ == 806 import Control.Monad.Fail #endif@@ -55,6 +52,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson hiding (Error, Null) import Data.Aeson.Encode.Pretty+import Data.Aeson.Lens () import Data.Conduit as Conduit import Data.Conduit.Parser as Parser import Data.Default@@ -83,7 +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. --@@ -112,12 +112,21 @@ -- ^ Trace the messages sent and received to stdout, defaults to False. -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@. , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.- , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.+ , lspConfig :: Object+ -- ^ The initial LSP config as JSON object, defaults to the empty object.+ -- This should include the config section for the server if it has one, i.e. if+ -- the server has a 'mylang' config section, then the config should be an object+ -- 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 'Language.LSP.Types.ShowMessageNotification' and- -- 'Language.LSP.Types.LogMessageNotification', defaults to False.- --- -- @since 0.9.0.0+ -- ^ 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.@@ -125,7 +134,7 @@ -- | The configuration used in 'Language.LSP.Test.runSession'. defaultConfig :: SessionConfig-defaultConfig = SessionConfig 60 False False True Nothing False Nothing+defaultConfig = SessionConfig 60 False False True mempty True True True Nothing instance Default SessionConfig where def = defaultConfig@@ -181,7 +190,11 @@ , curDynCaps :: !(Map.Map T.Text SomeRegistration) -- ^ The capabilities that the server has dynamically registered with us so -- far+ , curLspConfig :: Object , curProgressSessions :: !(Set.Set ProgressToken)+ , ignoringLogNotifications :: Bool+ , ignoringConfigurationRequests :: Bool+ , ignoringRegistrationRequests :: Bool } class Monad m => HasState s m where@@ -227,21 +240,15 @@ chanSource = do msg <- liftIO $ readChan (messageChan context)- unless (ignoreLogNotifications (config context) && isLogNotification msg) $- yield msg+ yield msg chanSource - isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowMessage _)) = True- isLogNotification (ServerMessage (FromServerMess SMethod_WindowLogMessage _)) = True- isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowDocument _)) = True- isLogNotification _ = False- watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () watchdog = Conduit.awaitForever $ \msg -> do 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.@@ -272,15 +279,34 @@ mainThreadId <- myThreadId - let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps- initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty- runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses+ 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@@ -293,27 +319,59 @@ 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- (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)+ (const $ runSessionMonad context initState session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () updateStateC = awaitForever $ \msg -> do+ state <- get @SessionState updateState msg- respond msg- yield msg- where- respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()- respond (FromServerMess SMethod_WindowWorkDoneProgressCreate req) =+ case msg of+ FromServerMess SMethod_WindowWorkDoneProgressCreate req -> sendMessage $ TResponseMessage "2.0" (Just $ req ^. L.id) (Right Null)- respond (FromServerMess SMethod_WorkspaceApplyEdit r) = do+ FromServerMess SMethod_WorkspaceApplyEdit r -> do sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right $ ApplyWorkspaceEditResult True Nothing Nothing)- respond _ = pure ()+ FromServerMess SMethod_WorkspaceConfiguration r -> do+ 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 ->+ case o ^. at (fromString $ T.unpack section) of+ Just config -> Right config+ Nothing -> Left section + 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+ 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)+ || (ignoringRegistrationRequests state && isRegistrationRequest msg)) $+ yield msg++ where++ isLogNotification (FromServerMess SMethod_WindowShowMessage _) = True+ isLogNotification (FromServerMess SMethod_WindowLogMessage _) = True+ isLogNotification (FromServerMess SMethod_WindowShowDocument _) = True+ isLogNotification _ = False++ 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@@ -357,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)@@ -388,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@@ -415,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@@ -429,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,25 +1,28 @@-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ module DummyServer where import Control.Monad import Control.Monad.Reader-import Data.Aeson hiding (defaultOptions, Null)-import qualified Data.Map.Strict as M+import Data.Aeson hiding (Null, defaultOptions)+import Data.Aeson qualified as J import Data.List (isSuffixOf)+import Data.Map.Strict qualified as M+import Data.Proxy import Data.String-import UnliftIO.Concurrent+import Data.Text qualified as T+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types import Language.LSP.Server-import System.IO-import UnliftIO import System.Directory import System.FilePath+import System.IO import System.Process-import Language.LSP.Protocol.Types-import Language.LSP.Protocol.Message-import Data.Proxy+import UnliftIO+import UnliftIO.Concurrent withDummyServer :: ((Handle, Handle) -> IO ()) -> IO () withDummyServer f = do@@ -27,14 +30,20 @@ (houtRead, houtWrite) <- createPipe handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar- let definition = ServerDefinition+ let+ definition =+ ServerDefinition { doInitialize = \env _req -> pure $ Right env- , defaultConfig = ()- , onConfigurationChange = const $ pure $ Right ()+ , defaultConfig = 1 :: Int+ , configSection = "dummy"+ , parseConfig = \_old new -> case fromJSON new of+ J.Success v -> Right v+ J.Error err -> Left $ T.pack err+ , onConfigChange = const $ pure () , staticHandlers = \_caps -> handlers , interpretHandler = \env -> Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO- , options = defaultOptions {optExecuteCommandCommands = Just ["doAnEdit"]}+ , options = defaultOptions{optExecuteCommandCommands = Just ["doAnEdit"]} } bracket@@ -42,41 +51,50 @@ killThread (const $ f (hinWrite, houtRead)) - data HandlerEnv = HandlerEnv { relRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) } -handlers :: Handlers (ReaderT HandlerEnv (LspM ()))+handlers :: Handlers (ReaderT HandlerEnv (LspM Int)) handlers = mconcat [ notificationHandler SMethod_Initialized $ \_noti -> sendNotification SMethod_WindowLogMessage $ LogMessageParams MessageType_Log "initialized"+ , requestHandler (SMethod_CustomMethod (Proxy @"getConfig")) $ \_req resp -> do+ config <- getConfig+ resp $ Right $ toJSON config , requestHandler SMethod_TextDocumentHover $ \_req responder -> responder $ 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 $ Right $- InR $ InL- [ DocumentSymbol- "foo"- Nothing- SymbolKind_Object- Nothing- Nothing- (mkRange 0 0 3 6)- (mkRange 0 0 3 6)- Nothing- ]- , notificationHandler SMethod_TextDocumentDidOpen $+ InR $+ InL+ [ DocumentSymbol+ "foo"+ Nothing+ SymbolKind_Object+ Nothing+ Nothing+ (mkRange 0 0 3 6)+ (mkRange 0 0 3 6)+ Nothing+ ]+ , notificationHandler SMethod_TextDocumentDidOpen $ \noti -> do let TNotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti TextDocumentItem uri _ _ _ = doc@@ -112,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"@@ -127,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"@@ -141,37 +159,35 @@ do Just token <- runInIO $ asks absRegToken >>= tryReadMVar runInIO $ unregisterCapability token-- -- this handler is used by the+ , -- this handler is used by the -- "text document VFS / sends back didChange notifications (documentChanges)" test- , notificationHandler SMethod_TextDocumentDidChange $ \noti -> do+ notificationHandler SMethod_TextDocumentDidChange $ \noti -> do let TNotificationMessage _ _ params = noti void $ sendNotification (SMethod_CustomMethod (Proxy @"custom/textDocument/didChange")) (toJSON params)-- , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do- case req of- TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do- let- Success docUri = fromJSON val- edit = [TextEdit (mkRange 0 0 0 5) "howdy"]- params =- ApplyWorkspaceEditParams (Just "Howdy edit") $- WorkspaceEdit (Just (M.singleton docUri edit)) Nothing Nothing- resp $ Right $ InR $ Null- void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))- TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just [val])) -> do- let- Success versionedDocUri = fromJSON val- edit = [InL (TextEdit (mkRange 0 0 0 5) "howdy")]- documentEdit = TextDocumentEdit versionedDocUri edit- params =- ApplyWorkspaceEditParams (Just "Howdy edit") $- WorkspaceEdit Nothing (Just [InL documentEdit]) Nothing- resp $ Right $ InR Null- void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))- TRequestMessage _ _ _ (ExecuteCommandParams _ name _) ->- error $ "unsupported command: " <> show name- , requestHandler SMethod_TextDocumentCodeAction $ \req resp -> do+ , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do+ case req of+ TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do+ let+ Success docUri = fromJSON val+ edit = [TextEdit (mkRange 0 0 0 5) "howdy"]+ params =+ ApplyWorkspaceEditParams (Just "Howdy edit") $+ WorkspaceEdit (Just (M.singleton docUri edit)) Nothing Nothing+ resp $ Right $ InR $ Null+ void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))+ TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just [val])) -> do+ let+ Success versionedDocUri = fromJSON val+ edit = [InL (TextEdit (mkRange 0 0 0 5) "howdy")]+ documentEdit = TextDocumentEdit versionedDocUri edit+ params =+ ApplyWorkspaceEditParams (Just "Howdy edit") $+ WorkspaceEdit Nothing (Just [InL documentEdit]) Nothing+ resp $ Right $ InR Null+ void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))+ TRequestMessage _ _ _ (ExecuteCommandParams _ name _) ->+ error $ "unsupported command: " <> show name+ , requestHandler SMethod_TextDocumentCodeAction $ \req resp -> do let TRequestMessage _ _ _ params = req CodeActionParams _ _ _ _ cactx = params CodeActionContext diags _ _ = cactx@@ -187,7 +203,7 @@ (Just (Command "" "deleteThis" Nothing)) Nothing resp $ Right $ InL $ InR <$> codeActions- , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do+ , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do let res = CompletionList True Nothing [item] item = CompletionItem@@ -211,7 +227,7 @@ Nothing Nothing resp $ Right $ InR $ InL res- , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do+ , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyPrepareParams _ pos _ = params Position x y = pos@@ -228,19 +244,44 @@ if x == 0 && y == 0 then resp $ Right $ InR Null else resp $ Right $ InL [item]- , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do+ , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyIncomingCallsParams _ _ item = params- resp $ Right $ InL- [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]]- , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do+ resp $+ Right $+ InL+ [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]]+ , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyOutgoingCallsParams _ _ item = params- resp $ Right $ InL- [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]]- , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do+ resp $+ Right $+ InL+ [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]]+ , 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,94 +1,91 @@-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} +import Control.Applicative.Combinators+import Control.Concurrent+import Control.Lens hiding (Iso, List)+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson+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 DummyServer-import Test.Hspec-import Data.Aeson-import Data.Default-import qualified Data.Map.Strict as M-import Data.Either-import Data.Maybe-import qualified Data.Text as T-import Data.Type.Equality-import Data.Proxy-import Control.Applicative.Combinators-import Control.Concurrent-import Control.Monad.IO.Class-import Control.Monad-import Control.Lens hiding (List, Iso)-import Language.LSP.Test-import Language.LSP.Protocol.Message-import Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Lens as L-import System.Directory-import System.FilePath-import System.Timeout-+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Test+import System.Directory+import System.FilePath+import System.Timeout+import Test.Hspec {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} - main = hspec $ around withDummyServer $ do describe "Session" $ do it "fails a test" $ \(hin, hout) ->- let session = runSessionWithHandles hin hout def fullCaps "." $ do- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- anyRequest- in session `shouldThrow` anySessionException- it "initializeResponse" $ \(hin, hout) -> 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 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- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- -- won't receive a request - will timeout- -- incoming logging requests shouldn't increase the- -- timeout- withTimeout 5 $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)- -- wait just a bit longer than 5 seconds so we have time- -- to open the document- in timeout 6000000 sesh `shouldThrow` anySessionException+ 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+ -- timeout+ withTimeout 5 $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+ in -- wait just a bit longer than 5 seconds so we have time+ -- to open the document+ timeout 6000000 sesh `shouldThrow` anySessionException it "doesn't time out" $ \(hin, hout) ->- let sesh = runSessionWithHandles hin hout def fullCaps "." $ do- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification- in void $ timeout 6000000 sesh+ 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 -- longer than the original timeout- liftIO $ threadDelay (5 * 10^6)+ liftIO $ threadDelay (5 * 10 ^ 6) -- shouldn't throw an exception getDocumentSymbols doc return () 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 getDocumentSymbols doc return True- in sesh `shouldReturn` True+ in sesh `shouldReturn` True 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@@ -97,20 +94,17 @@ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False- in sesh `shouldThrow` isTimeout-+ in sesh `shouldThrow` isTimeout describe "SessionException" $ do it "throw on time out" $ \(hin, hout) ->- let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do- skipMany loggingNotification- _ <- message SMethod_WorkspaceApplyEdit- return ()- in sesh `shouldThrow` anySessionException+ 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- loggingNotification+ runSessionWithHandles hin hout (def{messageTimeout = 5}) fullLatestClientCaps "." $ do liftIO $ threadDelay $ 6 * 1000000 _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" return ()@@ -119,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 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@@ -128,12 +122,35 @@ sendRequest SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification response SMethod_TextDocumentRename -- the wrong type- in runSessionWithHandles hin hout def fullCaps "." sesh- `shouldThrow` selector+ in runSessionWithHandles hin hout def fullLatestClientCaps "." sesh+ `shouldThrow` selector + describe "config" $ do+ it "updates config correctly" $ \(hin, hout) ->+ runSessionWithHandles hin hout (def{ignoreConfigurationRequests = False}) fullLatestClientCaps "." $ do+ configurationRequest -- initialized configuration request+ let requestConfig = do+ resp <- request (SMethod_CustomMethod (Proxy @"getConfig")) J.Null+ case resp ^? L.result . _Right of+ Just val -> case fromJSON @Int val of+ J.Success v -> pure v+ J.Error err -> fail err+ Nothing -> fail "no result"++ c <- requestConfig+ -- from the server definition+ liftIO $ c `shouldBe` 1+ setConfigSection "dummy" (toJSON @Int 2)+ -- ensure the configuration change has happened+ configurationRequest+ c <- requestConfig+ liftIO $ c `shouldBe` 2++ pure ()+ 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 @@ -144,13 +161,13 @@ editReq <- message SMethod_WorkspaceApplyEdit liftIO $ do- let Just [InL(TextDocumentEdit vdoc [InL edit_])] =+ let Just [InL (TextDocumentEdit vdoc [InL edit_])] = editReq ^. L.params . L.edit . L.documentChanges- vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion)+ vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion) edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy" change <- customNotification (Proxy @"custom/textDocument/didChange")- let NotMess (TNotificationMessage _ _ (c::Value)) = change+ let NotMess (TNotificationMessage _ _ (c :: Value)) = change Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc @@ -163,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)@@ -181,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)@@ -191,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))@@ -200,22 +217,20 @@ 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 liftIO $ do let [InR action] = actions action ^. L.title `shouldBe` "Delete this"- action ^. L.command . _Just . L.command `shouldBe` "deleteThis"+ 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" - skipMany loggingNotification-- Right (mainSymbol:_) <- getDocumentSymbols doc+ Right (mainSymbol : _) <- getDocumentSymbols doc liftIO $ do mainSymbol ^. L.name `shouldBe` "foo"@@ -223,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@@ -237,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)@@ -245,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@@ -257,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@@ -281,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))@@ -316,29 +337,29 @@ 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 documentContents doc >>= liftIO . print- in sesh `shouldThrow` anyException+ in sesh `shouldThrow` anyException describe "satisfy" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def 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 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 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@@ -348,29 +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 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" ""@@ -378,14 +406,13 @@ createDoc "Bar.watch" "haskell" "" void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing- count 0 $ loggingNotification void $ anyResponse - it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "" $ do- curDir <- liftIO $ getCurrentDirectory-+ 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 @@ -399,32 +426,47 @@ createDoc (curDir </> "Bar.watch") "haskell" "" void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing- count 0 $ loggingNotification void $ anyResponse describe "call hierarchy" $ do let workPos = Position 1 0 notWorkPos = Position 0 0 params pos = CallHierarchyPrepareParams (TextDocumentIdentifier (Uri "")) pos Nothing- item = CallHierarchyItem "foo" SymbolKind_Function Nothing Nothing (Uri "")- (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+ item =+ CallHierarchyItem+ "foo"+ SymbolKind_Function+ Nothing+ Nothing+ (Uri "")+ (Range (Position 1 2) (Position 3 4))+ (Range (Position 1 2) (Position 3 4))+ Nothing+ 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]+ 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)))
test/data/Format.hs view
@@ -1,4 +1,5 @@ module Format where-foo 3 = 2-foo x = x-bar _ = 2++foo 3 = 2+foo x = x+bar _ = 2
test/data/documentSymbolFail/example/Main.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+ module Main where -import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP-import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP-import qualified LSP.Client as Client-import Data.Proxy-import qualified Data.Text.IO as T import Control.Concurrent-import System.Process import Control.Lens-import System.IO-import System.Exit-import System.Environment-import System.Directory import Control.Monad+import Data.Proxy+import qualified Data.Text.IO as T+import qualified LSP.Client as Client+import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP+import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP+import System.Directory+import System.Environment+import System.Exit+import System.IO+import System.Process import qualified Compat @@ -39,43 +40,55 @@ pid <- Compat.getPID let caps = LSP.ClientCapabilities (Just workspaceCaps) (Just textDocumentCaps) Nothing- workspaceCaps = LSP.WorkspaceClientCapabilities- (Just False)- (Just (LSP.WorkspaceEditClientCapabilities (Just False)))- (Just (LSP.DidChangeConfigurationClientCapabilities (Just False)))- (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False)))- (Just (LSP.SymbolClientCapabilities (Just False)))- (Just (LSP.ExecuteClientCapabilities (Just False)))- textDocumentCaps = LSP.TextDocumentClientCapabilities- (Just (LSP.SynchronizationTextDocumentClientCapabilities- (Just False)- (Just False)- (Just False)- (Just False)))- (Just (LSP.CompletionClientCapabilities- (Just False)- (Just (LSP.CompletionItemClientCapabilities (Just False)))))- (Just (LSP.HoverClientCapabilities (Just False)))- (Just (LSP.SignatureHelpClientCapabilities (Just False)))- (Just (LSP.ReferencesClientCapabilities (Just False)))- (Just (LSP.DocumentHighlightClientCapabilities (Just False)))- (Just (LSP.DocumentSymbolClientCapabilities (Just False)))- (Just (LSP.FormattingClientCapabilities (Just False)))- (Just (LSP.RangeFormattingClientCapabilities (Just False)))- (Just (LSP.OnTypeFormattingClientCapabilities (Just False)))- (Just (LSP.DefinitionClientCapabilities (Just False)))- (Just (LSP.CodeActionClientCapabilities (Just False)))- (Just (LSP.CodeLensClientCapabilities (Just False)))- (Just (LSP.DocumentLinkClientCapabilities (Just False)))- (Just (LSP.RenameClientCapabilities (Just False)))- (Just (LSP.CallHierarchyClientCapabilities (Just False)))+ workspaceCaps =+ LSP.WorkspaceClientCapabilities+ (Just False)+ (Just (LSP.WorkspaceEditClientCapabilities (Just False)))+ (Just (LSP.DidChangeConfigurationClientCapabilities (Just False)))+ (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False)))+ (Just (LSP.SymbolClientCapabilities (Just False)))+ (Just (LSP.ExecuteClientCapabilities (Just False)))+ textDocumentCaps =+ LSP.TextDocumentClientCapabilities+ ( Just+ ( LSP.SynchronizationTextDocumentClientCapabilities+ (Just False)+ (Just False)+ (Just False)+ (Just False)+ )+ )+ ( Just+ ( LSP.CompletionClientCapabilities+ (Just False)+ (Just (LSP.CompletionItemClientCapabilities (Just False)))+ )+ )+ (Just (LSP.HoverClientCapabilities (Just False)))+ (Just (LSP.SignatureHelpClientCapabilities (Just False)))+ (Just (LSP.ReferencesClientCapabilities (Just False)))+ (Just (LSP.DocumentHighlightClientCapabilities (Just False)))+ (Just (LSP.DocumentSymbolClientCapabilities (Just False)))+ (Just (LSP.FormattingClientCapabilities (Just False)))+ (Just (LSP.RangeFormattingClientCapabilities (Just False)))+ (Just (LSP.OnTypeFormattingClientCapabilities (Just False)))+ (Just (LSP.DefinitionClientCapabilities (Just False)))+ (Just (LSP.CodeActionClientCapabilities (Just False)))+ (Just (LSP.CodeLensClientCapabilities (Just False)))+ (Just (LSP.DocumentLinkClientCapabilities (Just False)))+ (Just (LSP.RenameClientCapabilities (Just False)))+ (Just (LSP.CallHierarchyClientCapabilities (Just False))) initializeParams :: LSP.InitializeParams initializeParams = LSP.InitializeParams (Just pid) Nothing Nothing Nothing caps Nothing -- (Just inp, Just out, _, _) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"])- {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe}+ (Just inp, Just out, _, _) <-+ createProcess+ (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"])+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ } client <- Client.start (Client.Config inp out testNotificationMessageHandler testRequestMessageHandler) @@ -93,7 +106,8 @@ client (Proxy :: Proxy LSP.DefinitionRequest) LSP.TextDocumentDefinition- (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36)) >>= \case+ (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36))+ >>= \case Just (Right pos) -> print pos _ -> putStrLn "Server couldn't give us defnition position" @@ -108,21 +122,23 @@ Client.stop client testRequestMessageHandler :: Client.RequestMessageHandler-testRequestMessageHandler = Client.RequestMessageHandler- (\m -> emptyResponse m <$ print m)- (\m -> emptyResponse m <$ print m)- (\m -> emptyResponse m <$ print m)- (\m -> emptyResponse m <$ print m)- where- toRspId (LSP.IdInt i) = LSP.IdRspInt i- toRspId (LSP.IdString t) = LSP.IdRspString t+testRequestMessageHandler =+ Client.RequestMessageHandler+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ where+ toRspId (LSP.IdInt i) = LSP.IdRspInt i+ toRspId (LSP.IdString t) = LSP.IdRspString t - emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a- emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing+ emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a+ emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing testNotificationMessageHandler :: Client.NotificationMessageHandler-testNotificationMessageHandler = Client.NotificationMessageHandler- (T.putStrLn . view (LSP.params . LSP.message))- (T.putStrLn . view (LSP.params . LSP.message))- (print . view LSP.params)- (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message))+testNotificationMessageHandler =+ Client.NotificationMessageHandler+ (T.putStrLn . view (LSP.params . LSP.message))+ (T.putStrLn . view (LSP.params . LSP.message))+ (print . view LSP.params)+ (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message))
test/data/renameFail/Desktop/simple.hs view
@@ -8,11 +8,12 @@ type Item = String type Items = [Item] -data Command = Quit- | DisplayItems- | AddItem String- | RemoveItem Int- | Help+data Command+ = Quit+ | DisplayItems+ | AddItem String+ | RemoveItem Int+ | Help type Error = String @@ -35,8 +36,9 @@ removeItem i items | i < 0 || i >= length items = Left "Out of range" | otherwise = Right result- where (front, back) = splitAt (i + 1) items- result = init front ++ back+ where+ (front, back) = splitAt (i + 1) items+ result = init front ++ back interactWithUser :: Items -> IO () interactWithUser items = do@@ -45,12 +47,10 @@ Right DisplayItems -> do putStrLn $ displayItems items interactWithUser items- Right (AddItem item) -> do let newItems = addItem item items putStrLn "Added" interactWithUser newItems- Right (RemoveItem i) -> case removeItem i items of Right newItems -> do@@ -59,10 +59,7 @@ Left err -> do putStrLn err interactWithUser items-- Right Quit -> return ()- Right Help -> do putStrLn "Commands:" putStrLn "help"@@ -70,7 +67,6 @@ putStrLn "add" putStrLn "quit" interactWithUser items- Left err -> do putStrLn $ "Error: " ++ err interactWithUser items
test/data/renamePass/Desktop/simple.hs view
@@ -8,11 +8,12 @@ type Item = String type Items = [Item] -data Command = Quit- | DisplayItems- | AddItem String- | RemoveItem Int- | Help+data Command+ = Quit+ | DisplayItems+ | AddItem String+ | RemoveItem Int+ | Help type Error = String @@ -35,8 +36,9 @@ removeItem i items | i < 0 || i >= length items = Left "Out of range" | otherwise = Right result- where (front, back) = splitAt (i + 1) items- result = init front ++ back+ where+ (front, back) = splitAt (i + 1) items+ result = init front ++ back interactWithUser :: Items -> IO () interactWithUser items = do@@ -45,12 +47,10 @@ Right DisplayItems -> do putStrLn $ displayItems items interactWithUser items- Right (AddItem item) -> do let newItems = addItem item items putStrLn "Added" interactWithUser newItems- Right (RemoveItem i) -> case removeItem i items of Right newItems -> do@@ -59,10 +59,7 @@ Left err -> do putStrLn err interactWithUser items-- Right Quit -> return ()- Right Help -> do putStrLn "Commands:" putStrLn "help"@@ -70,7 +67,6 @@ putStrLn "add" putStrLn "quit" interactWithUser items- Left err -> do putStrLn $ "Error: " ++ err interactWithUser items