X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=test%2FTest.hs;h=60d3a38d0c9ab9016dfa2ba90359020bffc78383;hb=cf9e06e2eb79b113ff861866690f14166d1fa4e7;hp=4cffda347f150c4de7a9ba6e9797dfa4c1fa196f;hpb=ddc2cdb9d0563dcf30102c8ef41dc6932717a872;p=lsp-test.git diff --git a/test/Test.hs b/test/Test.hs index 4cffda3..60d3a38 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} @@ -15,17 +17,16 @@ 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 -import Language.Haskell.LSP.Types.Lens as LSP hiding +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (capabilities, message, rename, applyEdit) -import Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.Types.Capabilities as LSP import System.Directory import System.FilePath import System.Timeout +import Data.Type.Equality {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} @@ -52,7 +53,7 @@ main = findServer >>= \serverExe -> hspec $ do -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the -- timeout - withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit) :: Session ApplyWorkspaceEditRequest -- wait just a bit longer than 5 seconds so we have time -- to open the document in timeout 6000000 sesh `shouldThrow` anySessionException @@ -91,7 +92,7 @@ main = findServer >>= \serverExe -> hspec $ do withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc -- should now timeout - skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + skipManyTill anyMessage (message SWorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False in sesh `shouldThrow` isTimeout @@ -101,7 +102,7 @@ main = findServer >>= \serverExe -> hspec $ do it "throw on time out" $ let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do skipMany loggingNotification - _ <- message :: Session ApplyWorkspaceEditRequest + _ <- message SWorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException @@ -113,52 +114,30 @@ main = findServer >>= \serverExe -> hspec $ do describe "UnexpectedMessageException" $ do it "throws when there's an unexpected message" $ - let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True + let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True selector _ = False in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ - let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True + let selector (UnexpectedMessage "STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification - message :: Session RenameResponse -- the wrong type + response STextDocumentRename -- the wrong type in runSession serverExe fullCaps "test/data/renamePass" sesh `shouldThrow` selector - describe "replaySession" $ - -- This is too fickle at the moment - -- it "passes a test" $ - -- replaySession serverExe "test/data/renamePass" - it "fails a test" $ - let selector (ReplayOutOfOrder _ _) = True - selector _ = False - in replaySession serverExe "test/data/renameFail" `shouldThrow` selector - - -- describe "manual javascript session" $ - -- it "passes a test" $ - -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do - -- doc <- openDoc "test.js" "javascript" - - -- noDiagnostics - - -- Right (fooSymbol:_) <- getDocumentSymbols doc - - -- liftIO $ do - -- fooSymbol ^. name `shouldBe` "foo" - -- fooSymbol ^. kind `shouldBe` SkFunction - describe "text document VFS" $ it "sends back didChange notifications" $ runSession serverExe def "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing - request_ WorkspaceExecuteCommand reqParams + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) + request_ SWorkspaceExecuteCommand reqParams - editReq <- message :: Session ApplyWorkspaceEditRequest + editReq <- message SWorkspaceApplyEdit liftIO $ do let (Just cs) = editReq ^. params . edit . changes [(u, List es)] = HM.toList cs @@ -173,17 +152,17 @@ main = findServer >>= \serverExe -> hspec $ do doc <- openDoc "Main.hs" "haskell" let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing - request_ WorkspaceExecuteCommand reqParams + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) + request_ SWorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" - -- describe "getCodeActions" $ - -- it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do - -- doc <- openDoc "Main.hs" "haskell" - -- waitForDiagnostics - -- [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) - -- liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket" + describe "getCodeActions" $ + it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + waitForDiagnostics + [InR action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) + liftIO $ action ^. title `shouldBe` "Delete this" describe "getAllCodeActions" $ it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do @@ -191,24 +170,22 @@ main = findServer >>= \serverExe -> hspec $ do _ <- waitForDiagnostics actions <- getAllCodeActions doc liftIO $ do - let [CACodeAction action] = actions + let [InR action] = actions action ^. title `shouldBe` "Delete this" action ^. command . _Just . command `shouldBe` "deleteThis" - -- describe "getDocumentSymbols" $ - -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" - - -- skipMany loggingNotification + describe "getDocumentSymbols" $ + it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" - -- noDiagnostics + skipMany loggingNotification - -- Left (mainSymbol:_) <- getDocumentSymbols doc + Left (mainSymbol:_) <- getDocumentSymbols doc - -- liftIO $ do - -- mainSymbol ^. name `shouldBe` "main" - -- mainSymbol ^. kind `shouldBe` SkFunction - -- mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30) + liftIO $ do + mainSymbol ^. name `shouldBe` "foo" + mainSymbol ^. kind `shouldBe` SkObject + mainSymbol ^. range `shouldBe` mkRange 0 0 3 6 describe "applyEdit" $ do it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do @@ -224,21 +201,13 @@ main = findServer >>= \serverExe -> hspec $ do contents <- documentContents doc liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" - -- describe "getCompletions" $ - -- it "works" $ runSession serverExe def "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" - - -- -- wait for module to be loaded - -- skipMany loggingNotification - -- noDiagnostics - -- noDiagnostics + describe "getCompletions" $ + it "works" $ runSession serverExe def "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" - -- comps <- getCompletions doc (Position 5 5) - -- let item = head (filter (\x -> x ^. label == "interactWithUser") comps) - -- liftIO $ do - -- item ^. label `shouldBe` "interactWithUser" - -- item ^. kind `shouldBe` Just CiFunction - -- item ^. detail `shouldBe` Just "Items -> IO ()\nMain" + comps <- getCompletions doc (Position 5 5) + let item = head comps + liftIO $ item ^. label `shouldBe` "foo" -- describe "getReferences" $ -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do @@ -266,13 +235,13 @@ main = findServer >>= \serverExe -> hspec $ do -- defs <- getTypeDefinitions doc pos -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition - -- describe "waitForDiagnosticsSource" $ - -- it "works" $ runSession serverExe fullCaps "test/data" $ do - -- openDoc "Error.hs" "haskell" - -- [diag] <- waitForDiagnosticsSource "bios" - -- liftIO $ do - -- diag ^. severity `shouldBe` Just DsError - -- diag ^. source `shouldBe` Just "bios" + describe "waitForDiagnosticsSource" $ + it "works" $ runSession serverExe fullCaps "test/data" $ do + openDoc "Error.hs" "haskell" + [diag] <- waitForDiagnosticsSource "dummy-server" + liftIO $ do + diag ^. severity `shouldBe` Just DsWarning + diag ^. source `shouldBe` Just "dummy-server" -- describe "rename" $ do -- it "works" $ pendingWith "HaRe not in hie-bios yet" @@ -282,11 +251,11 @@ main = findServer >>= \serverExe -> hspec $ do -- rename doc (Position 2 11) "bar" -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack - -- describe "getHover" $ - -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" - -- hover <- getHover doc (Position 45 9) - -- liftIO $ hover `shouldSatisfy` isJust + describe "getHover" $ + it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + hover <- getHover doc (Position 45 9) + liftIO $ hover `shouldSatisfy` isJust -- describe "getHighlights" $ -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do @@ -322,7 +291,7 @@ main = findServer >>= \serverExe -> hspec $ do describe "satisfy" $ it "works" $ runSession serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" - let pred (NotLogMessage _) = True + let pred (FromServerMess SWindowLogMessage _) = True pred _ = False void $ satisfy pred @@ -332,7 +301,56 @@ main = findServer >>= \serverExe -> hspec $ do openDoc "Format.hs" "haskell" void publishDiagnosticsNotification -mkRange sl sc el ec = Range (Position sl sc) (Position el ec) + describe "dynamic capabilities" $ do + + it "keeps track" $ runSession serverExe fullCaps "test/data" $ do + loggingNotification -- initialized log message + + createDoc ".register" "haskell" "" + message SClientRegisterCapability + + doc <- createDoc "Foo.watch" "haskell" "" + msg <- message SWindowLogMessage + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities + liftIO $ do + case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of + Just HRefl -> + regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]) + Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" + + -- now unregister it by sending a specific createDoc + createDoc ".unregister" "haskell" "" + message SClientUnregisterCapability + + createDoc "Bar.watch" "haskell" "" + void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + + it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do + curDir <- liftIO $ getCurrentDirectory + + loggingNotification -- initialized log message + + createDoc ".register.abs" "haskell" "" + message SClientRegisterCapability + + doc <- createDoc (curDir "Foo.watch") "haskell" "" + msg <- message SWindowLogMessage + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + -- now unregister it by sending a specific createDoc + createDoc ".unregister.abs" "haskell" "" + message SClientUnregisterCapability + + createDoc (curDir "Bar.watch") "haskell" "" + void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + didChangeCaps :: ClientCapabilities didChangeCaps = def { _workspace = Just workspaceCaps } @@ -344,7 +362,7 @@ docChangesCaps :: ClientCapabilities docChangesCaps = def { _workspace = Just workspaceCaps } where workspaceCaps = def { _workspaceEdit = Just editCaps } - editCaps = WorkspaceEditClientCapabilities (Just True) + editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)