X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=test%2FTest.hs;h=344bbd587c2390b460e9212b715203fccfb2dd21;hb=cc180dcaf2f72684a42b73d1cb76c31037c8c81a;hp=36594aa5df2968e50e826634471fd70a18cdb83a;hpb=75db44e4ff6541608adca5e6f15523575c98e558;p=lsp-test.git diff --git a/test/Test.hs b/test/Test.hs index 36594aa..344bbd5 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} @@ -15,16 +17,16 @@ import Control.Concurrent import Control.Monad.IO.Class import Control.Monad import Control.Lens hiding (List) -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) #-} @@ -51,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) -- wait just a bit longer than 5 seconds so we have time -- to open the document in timeout 6000000 sesh `shouldThrow` anySessionException @@ -90,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 @@ -100,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 @@ -112,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 "Response for: 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 - -- This is too fickle at the moment - -- describe "replaySession" $ - -- 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 @@ -172,8 +152,8 @@ 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" @@ -181,8 +161,10 @@ main = findServer >>= \serverExe -> hspec $ do 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)) + [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2)) + actions <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) liftIO $ action ^. title `shouldBe` "Delete this" + liftIO $ actions `shouldSatisfy` null describe "getAllCodeActions" $ it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do @@ -190,7 +172,7 @@ 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" @@ -221,21 +203,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 @@ -319,7 +293,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 @@ -329,7 +303,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 } @@ -341,7 +364,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)