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
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" $
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
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
-- 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"
-- 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
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
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'
projects / lsp-test.git / blobdiff