import Language.Haskell.LSP.Test.Exceptions
import System.Console.ANSI
import System.Directory
+import System.FSNotify (watchTree, eventPath, withManager, WatchManager)
+import qualified System.FSNotify as FS
import System.IO
import System.Process (ProcessHandle())
import System.Timeout
+import System.FilePath.Glob (match, commonDirectory, compile)
-- | A session representing one instance of launching and connecting to a server.
--
, initRsp :: MVar InitializeResponse
, config :: SessionConfig
, sessionCapabilities :: ClientCapabilities
+ , watchManager :: WatchManager
}
class Monad m => HasReader r m where
instance HasReader SessionContext Session where
ask = Session (lift $ lift Reader.ask)
-instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
+instance Monad m => HasReader r (ConduitT a b (StateT s (ReaderT r m))) where
ask = lift $ lift Reader.ask
getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int
, curDynCaps :: Map.Map T.Text Registration
-- ^ The capabilities that the server has dynamically registered with us so
-- far
+ , unwatchers :: Map.Map T.Text [IO ()]
}
class Monad m => HasState s m where
get = State.get
put = State.put
-instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m)
+instance (Monad m, (HasState s m)) => HasState s (ConduitT a b m)
where
get = lift get
put = lift . put
isLogNotification (ServerMessage (NotLogMessage _)) = True
isLogNotification _ = False
- watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
+ watchdog :: ConduitT SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
watchdog = Conduit.awaitForever $ \msg -> do
curId <- getCurTimeoutId
case msg of
mainThreadId <- myThreadId
- let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
- initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty
+ withManager $ \watchManager -> do
+ let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps watchManager
+ initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty mempty
+ -- Interesting note: turning on TypeFamilies causes type inference to
+ -- infer the type runSession' :: Session () -> IO ((), SessionState)
+ -- instead of runSession' :: Session a -> IO (a , SessionState)
runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
errorHandler = throwTo mainThreadId :: SessionException -> IO ()
(const $ runSession' session)
return result
-updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
+updateStateC :: ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
updateStateC = awaitForever $ \msg -> do
updateState msg
yield msg
modify $ \s ->
s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }
+ -- Process the new registrations
+ forM_ newRegs $ \(regId, reg) -> do
+ when (reg ^. method == WorkspaceDidChangeWatchedFiles) $ do
+ processFileWatchRegistration regId reg
+
updateState (ReqUnregisterCapability req) = do
let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations
modify $ \s ->
let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs
in s { curDynCaps = newCurDynCaps }
+ -- Process the unregistrations
+ processFileWatchUnregistrations unRegs
+
updateState (NotPublishDiagnostics n) = do
let List diags = n ^. params . diagnostics
doc = n ^. params . uri
contents <- liftIO $ T.readFile fp
let item = TextDocumentItem (filePathToUri fp) "" 0 contents
msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
+ -- TODO: use 'sendMessage'?
liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
modifyM $ \s -> do
modify $ \s -> s { overridingTimeout = False }
return res
+-- TODO: add a shouldTimeout helper. need to add exceptions within Session
data LogMsgType = LogServer | LogClient
deriving Eq
| otherwise = Cyan
showPretty = B.unpack . encodePretty
+
+-- File watching
+
+processFileWatchRegistration :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
+ => T.Text -> Registration -> m ()
+processFileWatchRegistration regId reg = do
+ mgr <- asks watchManager
+ let mOpts = do
+ regOpts <- reg ^. registerOptions
+ case fromJSON regOpts of
+ Error _ -> Nothing
+ Success x -> Just x
+ case mOpts of
+ Nothing -> pure ()
+ Just (DidChangeWatchedFilesRegistrationOptions (List ws)) ->
+ forM_ ws $ \(FileSystemWatcher pat' watchKind) -> do
+ pat <- liftIO $ canonicalizePath pat'
+ let glob = compile pat
+ -- the root-most dir before any globbing stuff happens
+ dir = fst $ commonDirectory glob
+ pred = match glob . eventPath
+ -- If no watchKind specified, spec defaults to all true
+ WatchKind wkC wkM wkD = fromMaybe (WatchKind True True True) watchKind
+ handle <- asks serverIn
+ unwatch <- liftIO $ watchTree mgr dir pred $ \event -> do
+ let fe = FileEvent (filePathToUri (eventPath event)) typ
+ typ = case event of
+ FS.Added _ _ _ -> FcCreated
+ FS.Modified _ _ _ -> FcChanged
+ FS.Removed _ _ _ -> FcDeleted
+ -- This is a bit of a guess
+ FS.Unknown _ _ _ -> FcChanged
+ matches = case typ of
+ FcCreated -> wkC
+ FcChanged -> wkM
+ FcDeleted -> wkD
+ params = DidChangeWatchedFilesParams (List [fe])
+ msg = fmClientDidChangeWatchedFilesNotification params
+ liftIO $ when matches $ B.hPut handle (addHeader $ encode msg)
+ modify $ \s ->
+ s { unwatchers = Map.insertWith (++) regId [unwatch] (unwatchers s) }
+
+processFileWatchUnregistrations :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
+ => [T.Text] -> m ()
+processFileWatchUnregistrations regIds =
+ forM_ regIds $ \regId -> modifyM $ \s -> do
+ let fs = fromMaybe [] (Map.lookup regId (unwatchers s))
+ liftIO $ sequence fs
+ return $ s { unwatchers = Map.delete regId (unwatchers s) }
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)
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)
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'
DidChangeWatchedFilesRegistrationOptions $ List
[ FileSystemWatcher (curDir </> "*.watch") (Just (WatchKind True True True)) ]
]
+ when (".register.tmp" `isSuffixOf` fp) $ do
+ tmpDir <- getTemporaryDirectory
+ reqId <- readMVar lfvar >>= getNextReqId
+ send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
+ RegistrationParams $ List $
+ [ Registration "2" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
+ DidChangeWatchedFilesRegistrationOptions $ List
+ [ FileSystemWatcher (tmpDir </> "*.watch") (Just (WatchKind True True True)) ]
+ ]
-- also act as an unregisterer for workspace/didChangeWatchedFiles
when (".unregister" `isSuffixOf` fp) $ do
reqId <- readMVar lfvar >>= getNextReqId
send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ]
+ when (".unregister.tmp" `isSuffixOf` fp) $ do
+ reqId <- readMVar lfvar >>= getNextReqId
+ send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
+ UnregistrationParams $ List [ Unregistration "2" "workspace/didChangeWatchedFiles" ]
, executeCommandHandler = pure $ \req -> do
send $ RspExecuteCommand $ makeResponseMessage req Null
reqId <- readMVar lfvar >>= getNextReqId
projects / lsp-test.git / commitdiff