Watch files to send didChangeWatchedFiles notifications

[lsp-test.git] / test / Test.hs

diff --git a/test/Test.hs b/test/Test.hs
index 36594aa5df2968e50e826634471fd70a18cdb83a..90350135eabe7d53c331e370112baf96f5ba5643 100644 (file)
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -8,19 +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           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
@@ -329,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
@@ -344,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'