X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=test%2FTest.hs;h=90350135eabe7d53c331e370112baf96f5ba5643;hb=e5da0e9511c679626dbe40a99e8c0de0c968dddf;hp=4cffda347f150c4de7a9ba6e9797dfa4c1fa196f;hpb=ddc2cdb9d0563dcf30102c8ef41dc6932717a872;p=lsp-test.git diff --git a/test/Test.hs b/test/Test.hs index 4cffda3..9035013 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -8,20 +8,21 @@ import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HM import Data.Either +import Data.List (sortOn) import Data.Maybe import qualified Data.Text as T import Control.Applicative.Combinators import Control.Concurrent +import Control.Exception (finally) 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.Haskell.LSP.Types.Lens hiding (capabilities, message, rename, applyEdit) +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Types.Capabilities as LSP import System.Directory import System.FilePath @@ -127,14 +128,14 @@ main = findServer >>= \serverExe -> hspec $ do in runSession serverExe fullCaps "test/data/renamePass" sesh `shouldThrow` selector - describe "replaySession" $ -- 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 + -- 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" $ @@ -178,12 +179,12 @@ main = findServer >>= \serverExe -> hspec $ do 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 + [CACodeAction 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 @@ -195,20 +196,18 @@ main = findServer >>= \serverExe -> hspec $ do 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 @@ -266,13 +265,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 +281,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 @@ -332,6 +331,90 @@ main = findServer >>= \serverExe -> hspec $ do openDoc "Format.hs" "haskell" void publishDiagnosticsNotification + describe "dynamic capabilities" $ do + it "keeps track" $ runSession serverExe fullCaps "test/data" $ do + loggingNotification -- initialized log message + + createDoc ".register" "haskell" "" + message :: Session RegisterCapabilityRequest + + doc <- createDoc "Foo.watch" "haskell" "" + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + caps <- getRegisteredCapabilities + liftIO $ caps `shouldBe` + [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] + ] + + -- now unregister it by sending a specific createDoc + createDoc ".unregister" "haskell" "" + message :: Session UnregisterCapabilityRequest + + createDoc "Bar.watch" "haskell" "" + void $ sendRequest TextDocumentHover $ TextDocumentPositionParams 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 :: Session RegisterCapabilityRequest + + doc <- createDoc (curDir "Foo.watch") "haskell" "" + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + -- now unregister it by sending a specific createDoc + createDoc ".unregister.abs" "haskell" "" + message :: Session UnregisterCapabilityRequest + + createDoc (curDir "Bar.watch") "haskell" "" + void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + + describe "file watching" $ + it "works" $ do + tmp <- liftIO getTemporaryDirectory + let testFile = tmp "lsp-test.watch" + testFile' = tmp "lsp-test.nowatch" + finally (runSession serverExe fullCaps "" $ do + loggingNotification -- initialized log message + + createDoc ".register.tmp" "haskell" "" + message :: Session RegisterCapabilityRequest + + liftIO $ writeFile testFile "Hello" -- >> hFlush h + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + -- this shouldn't trigger a watch files thingy + liftIO $ writeFile testFile' "Hello" + doc <- createDoc "blah" "haskell" "" + + let testNoLog = do + void $ sendRequest TextDocumentHover $ + TextDocumentPositionParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + testNoLog + + -- unwatch .watch in tmp + createDoc ".unregister.tmp" "haskell" "" + message :: Session UnregisterCapabilityRequest + + -- modifying shouldn't return anything + liftIO $ writeFile testFile "Hello" + testNoLog) (mapM_ removeFile [testFile, testFile']) + + +mkRange :: Int -> Int -> Int -> Int -> Range mkRange sl sc el ec = Range (Position sl sc) (Position el ec) didChangeCaps :: ClientCapabilities @@ -347,23 +430,24 @@ docChangesCaps = def { _workspace = Just workspaceCaps } editCaps = WorkspaceEditClientCapabilities (Just True) -findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath) +findExeRecursive :: FilePath -> FilePath -> IO [FilePath] findExeRecursive exe dir = do - me <- listToMaybe <$> findExecutablesInDirectories [dir] exe - case me of - Just e -> return (Just e) - Nothing -> do + exes <- findExecutablesInDirectories [dir] exe subdirs <- (fmap (dir )) <$> listDirectory dir >>= filterM doesDirectoryExist - foldM (\acc subdir -> case acc of - Just y -> pure $ Just y - Nothing -> findExeRecursive exe subdir) - Nothing - subdirs + exes' <- concat <$> mapM (findExeRecursive exe) subdirs + return $ exes ++ exes' + +newestExe :: [FilePath] -> IO (Maybe FilePath) +newestExe exes = do + pairs <- zip exes <$> mapM getModificationTime exes + case sortOn snd pairs of + (e,_):_ -> return $ Just e + _ -> return Nothing -- | So we can find the dummy-server with cabal run -- since it doesnt put build tools on the path (only cabal test) findServer = do let serverName = "dummy-server" e <- findExecutable serverName - e' <- findExeRecursive serverName "dist-newstyle" + e' <- findExeRecursive serverName "dist-newstyle" >>= newestExe pure $ fromJust $ e <|> e'