X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=test%2FTest.hs;h=3ff5ea4895cc65cf34a3b10a2814d5a128f96ca3;hb=9b771257fb775abdcca8e6b71e2d3d0ec4309670;hp=c6ef7e29e90ca44e6ad592e379aa7f3ef64579f7;hpb=22df37c703e39fa5ebeb130be5785b3a9713c520;p=lsp-test.git diff --git a/test/Test.hs b/test/Test.hs index c6ef7e2..3ff5ea4 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -7,38 +7,21 @@ import Test.Hspec import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HM -import Data.Maybe +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.Capabilities +import Language.Haskell.LSP.Types hiding (message, capabilities) +import System.Timeout main = hspec $ do describe "manual session" $ do - it "passes a test" $ - runSession "hie --lsp" "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - - skipMany loggingNotification - - noDiagnostics - - rspSymbols <- documentSymbols doc - - liftIO $ do - let (List symbols) = fromJust (rspSymbols ^. result) - mainSymbol = head symbols - mainSymbol ^. name `shouldBe` "main" - mainSymbol ^. kind `shouldBe` SkFunction - mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) - mainSymbol ^. containerName `shouldBe` Nothing - it "fails a test" $ -- TODO: Catch the exception in haskell-lsp-test and provide nicer output let session = runSession "hie --lsp" "test/data/renamePass" $ do @@ -50,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) + 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 @@ -102,10 +130,8 @@ main = hspec $ do noDiagnostics - rspSymbols <- documentSymbols doc + (fooSymbol:_) <- getDocumentSymbols doc - let (List symbols) = fromJust (rspSymbols ^. result) - fooSymbol = head symbols liftIO $ do fooSymbol ^. name `shouldBe` "foo" fooSymbol ^. kind `shouldBe` SkFunction @@ -119,11 +145,9 @@ main = hspec $ do (Position 1 14) "Redundant bracket" reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) - sendRequest WorkspaceExecuteCommand reqParams - skipMany anyNotification - _ <- response :: Session ExecuteCommandResponse + 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 @@ -144,19 +168,66 @@ main = hspec $ do (Position 1 14) "Redundant bracket" reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) - sendRequest WorkspaceExecuteCommand reqParams - skipMany anyNotification - _ <- response :: Session ExecuteCommandResponse - - contents <- documentEdit doc + sendRequest_ WorkspaceExecuteCommand reqParams + contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" noDiagnostics - parsingSpec + describe "getAllCodeActions" $ + it "works" $ runSession "hie --lsp" "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + _ <- waitForDiagnostics + actions <- getAllCodeActions doc + liftIO $ do + let [CommandOrCodeActionCommand action] = actions + action ^. title `shouldBe` "Apply hint:Redundant bracket" + action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne" + + describe "getDocumentSymbols" $ + it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + + skipMany loggingNotification + + noDiagnostics + + (mainSymbol:_) <- getDocumentSymbols doc + + liftIO $ do + mainSymbol ^. name `shouldBe` "main" + mainSymbol ^. kind `shouldBe` SkFunction + mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) + mainSymbol ^. containerName `shouldBe` Nothing + + 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) -