X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=test%2FTest.hs;h=b5abae51f5fab1ad553ab31aa3a0dc96cdf84644;hb=06aef4efc7a5d9fd43b938cd45c7aa6a38bf2b77;hp=b3a54ed9cd0d7f890ad4abbc968d6e993587a037;hpb=d8e460543b7cbc32550bed20d20ef4b13d6705a5;p=lsp-test.git diff --git a/test/Test.hs b/test/Test.hs index b3a54ed..b5abae5 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -10,14 +10,15 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Control.Concurrent import Control.Monad.IO.Class +import Control.Monad import Control.Lens hiding (List) import GHC.Generics import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Replay import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.Types hiding (capabilities) -import ParsingTests +import Language.Haskell.LSP.Types hiding (message, capabilities) +import System.Timeout main = hspec $ do describe "manual session" $ do @@ -32,40 +33,85 @@ main = hspec $ do rsp <- initializeResponse liftIO $ rsp ^. result `shouldNotBe` Nothing - it "can register specific capabilities" $ do - let caps = def { _workspace = Just workspaceCaps } - workspaceCaps = def { _didChangeConfiguration = Just configCaps } - configCaps = DidChangeConfigurationClientCapabilities (Just True) - conf = def { capabilities = caps } - runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return () + it "can register specific capabilities" $ + runSessionWithConfig (def { capabilities = didChangeCaps }) + "hie --lsp" "test/data/renamePass" $ return () + + describe "withTimeout" $ do + it "times out" $ + let sesh = runSession "hie --lsp" "test/data/renamePass" $ do + openDoc "Desktop/simple.hs" "haskell" + -- won't receive a request - will timeout + -- incoming logging requests shouldn't increase the + -- timeout + withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + -- wait just a bit longer than 5 seconds so we have time + -- to open the document + in timeout 6000000 sesh `shouldThrow` anySessionException + + it "doesn't time out" $ + let sesh = runSession "hie --lsp" "test/data/renamePass" $ do + openDoc "Desktop/simple.hs" "haskell" + withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification + in void $ timeout 6000000 sesh + + it "further timeout messages are ignored" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + withTimeout 3 $ getDocumentSymbols doc + liftIO $ threadDelay 5000000 + -- shouldn't throw an exception + getDocumentSymbols doc + return () + + it "overrides global message timeout" $ + let sesh = + runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "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 + + it "unoverrides global message timeout" $ + let sesh = + runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + -- shouldn't time out in here since we are overriding it + withTimeout 10 $ liftIO $ threadDelay 7000000 + getDocumentSymbols doc + -- should now timeout + skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + in sesh `shouldThrow` (== TimeoutException) + describe "exceptions" $ do it "throw on time out" $ - let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do + let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do skipMany loggingNotification - _ <- request :: Session ApplyWorkspaceEditRequest + _ <- message :: Session ApplyWorkspaceEditRequest return () in sesh `shouldThrow` anySessionException - it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 5}) "hie --lsp" "test/data/renamePass" $ do + it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do loggingNotification liftIO $ threadDelay 10 _ <- openDoc "Desktop/simple.hs" "haskell" return () - it "throw when there's an unexpected message" $ + describe "UnexpectedMessageException" $ do + it "throws when there's an unexpected message" $ let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True selector _ = False in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector - - it "throw when there's an unexpected message 2" $ - let selector (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True + it "provides the correct types that were expected and received" $ + let selector (UnexpectedMessageException "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc) skipMany anyNotification - response :: Session RenameResponse -- the wrong type + message :: Session RenameResponse -- the wrong type in runSession "hie --lsp" "test/data/renamePass" sesh `shouldThrow` selector @@ -101,7 +147,7 @@ main = hspec $ do reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) sendRequest_ WorkspaceExecuteCommand reqParams - editReq <- request :: Session ApplyWorkspaceEditRequest + editReq <- message :: Session ApplyWorkspaceEditRequest liftIO $ do let (Just cs) = editReq ^. params . edit . changes [(u, List es)] = HM.toList cs @@ -153,11 +199,35 @@ main = hspec $ do mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) mainSymbol ^. containerName `shouldBe` Nothing - parsingSpec + describe "applyEdit" $ do + it "increments the version" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc + let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" + VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit edit doc + liftIO $ newVersion `shouldBe` oldVersion + 1 + it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" + applyEdit edit doc + contents <- documentContents doc + liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" + + +didChangeCaps :: ClientCapabilities +didChangeCaps = def { _workspace = Just workspaceCaps } + where + workspaceCaps = def { _didChangeConfiguration = Just configCaps } + configCaps = DidChangeConfigurationClientCapabilities (Just True) + +docChangesCaps :: ClientCapabilities +docChangesCaps = def { _workspace = Just workspaceCaps } + where + workspaceCaps = def { _workspaceEdit = Just editCaps } + editCaps = WorkspaceEditClientCapabilities (Just True) data ApplyOneParams = AOP { file :: Uri , start_pos :: Position , hintTitle :: String } deriving (Generic, ToJSON) -