diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/SimpleBench.hs b/bench/SimpleBench.hs --- a/bench/SimpleBench.hs +++ b/bench/SimpleBench.hs @@ -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 - diff --git a/example/Test.hs b/example/Test.hs --- a/example/Test.hs +++ b/example/Test.hs @@ -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 - diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -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 diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test -version: 0.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 - diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- a/src/Language/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -1,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 @@ . 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 diff --git a/src/Language/LSP/Test/Compat.hs b/src/Language/LSP/Test/Compat.hs --- a/src/Language/LSP/Test/Compat.hs +++ b/src/Language/LSP/Test/Compat.hs @@ -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} diff --git a/src/Language/LSP/Test/Decoding.hs b/src/Language/LSP/Test/Decoding.hs --- a/src/Language/LSP/Test/Decoding.hs +++ b/src/Language/LSP/Test/Decoding.hs @@ -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 +-} diff --git a/src/Language/LSP/Test/Exceptions.hs b/src/Language/LSP/Test/Exceptions.hs --- a/src/Language/LSP/Test/Exceptions.hs +++ b/src/Language/LSP/Test/Exceptions.hs @@ -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) diff --git a/src/Language/LSP/Test/Files.hs b/src/Language/LSP/Test/Files.hs --- a/src/Language/LSP/Test/Files.hs +++ b/src/Language/LSP/Test/Files.hs @@ -1,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 diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -1,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 diff --git a/src/Language/LSP/Test/Server.hs b/src/Language/LSP/Test/Server.hs --- a/src/Language/LSP/Test/Server.hs +++ b/src/Language/LSP/Test/Server.hs @@ -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 diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- a/src/Language/LSP/Test/Session.hs +++ b/src/Language/LSP/Test/Session.hs @@ -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)) diff --git a/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -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 ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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))) diff --git a/test/data/Format.hs b/test/data/Format.hs --- a/test/data/Format.hs +++ b/test/data/Format.hs @@ -1,4 +1,5 @@ module Format where -foo 3 = 2 -foo x = x -bar _ = 2 + +foo 3 = 2 +foo x = x +bar _ = 2 diff --git a/test/data/documentSymbolFail/example/Main.hs b/test/data/documentSymbolFail/example/Main.hs --- a/test/data/documentSymbolFail/example/Main.hs +++ b/test/data/documentSymbolFail/example/Main.hs @@ -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)) diff --git a/test/data/renameFail/Desktop/simple.hs b/test/data/renameFail/Desktop/simple.hs --- a/test/data/renameFail/Desktop/simple.hs +++ b/test/data/renameFail/Desktop/simple.hs @@ -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 diff --git a/test/data/renamePass/Desktop/simple.hs b/test/data/renamePass/Desktop/simple.hs --- a/test/data/renamePass/Desktop/simple.hs +++ b/test/data/renamePass/Desktop/simple.hs @@ -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