X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=test%2FTest.hs;h=845f6e46aecdc732c5a465b51c42faead0907486;hb=e2ae28cd825653b0cb8b982d113497e9ac795059;hp=3fd14e4c5dc9cbad53ff157cbffd0e8da8aecfae;hpb=287998584f8dc2ec1c1995733ca38d38d8d9f031;p=opengl.git diff --git a/test/Test.hs b/test/Test.hs index 3fd14e4..845f6e4 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,38 +1,242 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + import Test.Hspec -import System.IO -import System.Directory -import Control.Lens -import Language.Haskell.LSP.Test.Recorded --- import Language.Haskell.LSP.Test.Parsing --- import Language.Haskell.LSP.Test.Files -import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP +import Data.Aeson +import Data.Default +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.Types.Capabilities +import Language.Haskell.LSP.Types hiding (message, capabilities) +import System.Timeout main = hspec $ do - describe "Replay" $ do + describe "Session" $ do + 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 + openDoc "Desktop/simple.hs" "haskell" + skipMany loggingNotification + anyRequest + in session `shouldThrow` anyException + it "initializeResponse" $ runSession "hie --lsp" "test/data/renamePass" $ do + rsp <- initializeResponse + liftIO $ rsp ^. result `shouldNotBe` Nothing + + it "runSessionWithConfig" $ + 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` (== Timeout) + + + describe "SessionException" $ do + it "throw on time out" $ + let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do + skipMany loggingNotification + _ <- message :: Session ApplyWorkspaceEditRequest + return () + in sesh `shouldThrow` anySessionException + + 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 () + + describe "UnexpectedMessageException" $ do + it "throws when there's an unexpected message" $ + let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True + selector _ = False + in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector + it "provides the correct types that were expected and received" $ + let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True + selector _ = False + sesh = do + doc <- openDoc "Desktop/simple.hs" "haskell" + sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc) + skipMany anyNotification + message :: Session RenameResponse -- the wrong type + in runSession "hie --lsp" "test/data/renamePass" sesh + `shouldThrow` selector + + describe "replaySession" $ do it "passes a test" $ - replay "test/recordings/renamePass/client.log" - "test/recordings/renamePass/server.log" - "test/recordings/renamePass" - `shouldReturn` True + replaySession "hie --lsp" "test/data/renamePass" it "fails a test" $ - replay "test/recordings/documentSymbolFail/client.log" - "test/recordings/documentSymbolFail/server.log" - "test/recordings/documentSymbolFail" - `shouldReturn` False - - -- describe "file swapping" $ do - -- it "gets the base directory" $ do - -- h <- openFile "test/recordings/renamePass/client.log" ReadMode - -- msgs <- getAllMessages h - -- rootDir msgs `shouldBe` "/Users/luke/Desktop" - - -- it "gets builds a mapping of files" $ do - -- h <- openFile "test/recordings/renamePass/client.log" ReadMode - -- msgs <- getAllMessages h - -- let root = rootDir msgs - -- swapped <- swapFiles root "test/recordings/renamePass/" msgs - -- let (Just n) = decode (swapped !! 3) :: Maybe LSP.DidOpenNotification - - -- cd <- getCurrentDirectory - - -- n .^ params . uri `shouldBe` LSP.uriFromFilePath (cd "test/recordings/renamePass/") + let selector (ReplayOutOfOrder _ _) = True + selector _ = False + in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector + + describe "manual javascript session" $ + it "passes a test" $ + runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do + doc <- openDoc "test.js" "javascript" + + noDiagnostics + + (fooSymbol:_) <- getDocumentSymbols doc + + liftIO $ do + fooSymbol ^. name `shouldBe` "foo" + fooSymbol ^. kind `shouldBe` SkFunction + + describe "text document VFS" $ + it "sends back didChange notifications" $ + runSession "hie --lsp" "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + + let args = toJSON $ AOP (doc ^. uri) + (Position 1 14) + "Redundant bracket" + reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) + sendRequest_ WorkspaceExecuteCommand reqParams + + editReq <- message :: Session ApplyWorkspaceEditRequest + liftIO $ do + let (Just cs) = editReq ^. params . edit . changes + [(u, List es)] = HM.toList cs + u `shouldBe` doc ^. uri + es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"] + + noDiagnostics + + contents <- documentContents doc + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" + + describe "getDocumentEdit" $ + it "automatically consumes applyedit requests" $ + runSession "hie --lsp" "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + + let args = toJSON $ AOP (doc ^. uri) + (Position 1 14) + "Redundant bracket" + reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) + sendRequest_ WorkspaceExecuteCommand reqParams + contents <- getDocumentEdit doc + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" + noDiagnostics + + 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 doc edit + 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 doc edit + contents <- documentContents doc + liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" + + describe "getCompletions" $ + it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + [item] <- getCompletions doc (Position 5 5) + liftIO $ do + item ^. label `shouldBe` "interactWithUser" + item ^. kind `shouldBe` Just CiFunction + item ^. detail `shouldBe` Just "Items -> IO ()\nMain" + + +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)