Skip to content

Commit cee889e

Browse files
pepeiborrapepeiborra
authored
Use file watches for all workspace files (#1880)
* Use file watches for all workspace files * Fix non LSP driver * handling of non workspace files * fix yaml escaping in Windows test
1 parent 88548ac commit cee889e

File tree

5 files changed

+146
-98
lines changed

5 files changed

+146
-98
lines changed

‎ghcide/src/Development/IDE/Core/FileExists.hs‎

Lines changed: 11 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import Control.Monad.IO.Class
1717
import qualified Data.ByteString as BS
1818
import Data.HashMap.Strict (HashMap)
1919
import qualified Data.HashMap.Strict as HashMap
20+
import Data.List (partition)
2021
import Data.Maybe
2122
import Development.IDE.Core.FileStore
2223
import Development.IDE.Core.IdeConfiguration
@@ -25,9 +26,9 @@ import Development.IDE.Core.Shake
2526
import Development.IDE.Graph
2627
import Development.IDE.Types.Location
2728
import Development.IDE.Types.Options
29+
import Ide.Plugin.Config (Config)
2830
import Language.LSP.Server hiding (getVirtualFile)
2931
import Language.LSP.Types
30-
import Language.LSP.Types.Capabilities
3132
import qualified System.Directory as Dir
3233
import qualified System.FilePath.Glob as Glob
3334

@@ -91,22 +92,23 @@ modifyFileExists :: IdeState -> [FileEvent] -> IO ()
9192
modifyFileExists state changes = do
9293
FileExistsMapVar var <- getIdeGlobalState state
9394
changesMap <- evaluate $ HashMap.fromList $
94-
[ (toNormalizedFilePath' f, newState)
95+
[ (toNormalizedFilePath' f, change)
9596
| FileEvent uri change <- changes
9697
, Just f <- [uriToFilePath uri]
97-
, Just newState <- [fromChange change]
9898
]
9999
-- Masked to ensure that the previous values are flushed together with the map update
100100
mask $ \_ -> do
101101
-- update the map
102-
void $ modifyVar' var $ HashMap.union changesMap
102+
void $ modifyVar' var $ HashMap.union (HashMap.mapMaybe fromChange changesMap)
103103
-- See Note [Invalidating file existence results]
104104
-- flush previous values
105-
mapM_ (deleteValue (shakeExtras state) GetFileExists) (HashMap.keys changesMap)
105+
let (_fileModifChanges, fileExistChanges) =
106+
partition ((== FcChanged) . snd) (HashMap.toList changesMap)
107+
mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
106108

107109
fromChange :: FileChangeType -> Maybe Bool
108110
fromChange FcCreated = Just True
109-
fromChange FcDeleted = Just True
111+
fromChange FcDeleted = Just False
110112
fromChange FcChanged = Nothing
111113

112114
-------------------------------------------------------------------------------------
@@ -153,18 +155,11 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext
153155
-- | Installs the 'getFileExists' rules.
154156
-- Provides a fast implementation if client supports dynamic watched files.
155157
-- Creates a global state as a side effect in that case.
156-
fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules ()
158+
fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules ()
157159
fileExistsRules lspEnv vfs = do
158160
supportsWatchedFiles <- case lspEnv of
159-
Just lspEnv' -> liftIO $ runLspT lspEnv' $ do
160-
ClientCapabilities {_workspace} <- getClientCapabilities
161-
case () of
162-
_ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
163-
, Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
164-
, Just True <- _dynamicRegistration
165-
-> pure True
166-
_ -> pure False
167-
Nothing -> pure False
161+
Nothing -> pure False
162+
Just lspEnv' -> liftIO $ runLspT lspEnv' isWatchSupported
168163
-- Create the global always, although it should only be used if we have fast rules.
169164
-- But there's a chance someone will send unexpected notifications anyway,
170165
-- e.g. https://github.com/haskell/ghcide/issues/599

‎ghcide/src/Development/IDE/Core/FileStore.hs‎

Lines changed: 98 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,9 @@ module Development.IDE.Core.FileStore(
2020
getModificationTimeImpl,
2121
addIdeGlobal,
2222
getFileContentsImpl,
23-
getModTime
23+
getModTime,
24+
isWatchSupported,
25+
registerFileWatches
2426
) where
2527

2628
import Control.Concurrent.STM (atomically)
@@ -49,7 +51,8 @@ import Development.IDE.Types.Diagnostics
4951
import Development.IDE.Types.Location
5052
import Development.IDE.Types.Options
5153
import HieDb.Create (deleteMissingRealFiles)
52-
import Ide.Plugin.Config (CheckParents (..))
54+
import Ide.Plugin.Config (CheckParents (..),
55+
Config)
5356
import System.IO.Error
5457

5558
#ifdef mingw32_HOST_OS
@@ -63,13 +66,21 @@ import qualified Development.IDE.Types.Logger as L
6366

6467
import qualified Data.Binary as B
6568
import qualified Data.ByteString.Lazy as LBS
69+
import qualified Data.Text as Text
70+
import Development.IDE.Core.IdeConfiguration (isWorkspaceFile)
6671
import Language.LSP.Server hiding
6772
(getVirtualFile)
6873
import qualified Language.LSP.Server as LSP
69-
import Language.LSP.Types (FileChangeType (FcChanged),
74+
import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
75+
FileChangeType (FcChanged),
7076
FileEvent (FileEvent),
77+
FileSystemWatcher (..),
78+
WatchKind (..),
79+
_watchers,
7180
toNormalizedFilePath,
7281
uriToFilePath)
82+
import qualified Language.LSP.Types as LSP
83+
import qualified Language.LSP.Types.Capabilities as LSP
7384
import Language.LSP.VFS
7485
import System.FilePath
7586

@@ -94,6 +105,17 @@ makeLSPVFSHandle lspEnv = VFSHandle
94105
, setVirtualFileContents = Nothing
95106
}
96107

108+
addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()
109+
addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do
110+
isAlreadyWatched <- isWatched f
111+
isWp <- isWorkspaceFile f
112+
if isAlreadyWatched then pure (Just True) else
113+
if not isWp then pure (Just False) else do
114+
ShakeExtras{lspEnv} <- getShakeExtras
115+
case lspEnv of
116+
Just env -> fmap Just $ liftIO $ LSP.runLspT env $
117+
registerFileWatches [fromNormalizedFilePath f]
118+
Nothing -> pure $ Just False
97119

98120
isFileOfInterestRule :: Rules ()
99121
isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
@@ -109,45 +131,44 @@ isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest
109131
summarize (IsFOI (Modified True)) = BS.singleton 3
110132

111133

112-
getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
113-
getModificationTimeRule vfs isWatched = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
114-
getModificationTimeImpl vfs isWatched missingFileDiags file
134+
getModificationTimeRule :: VFSHandle -> Rules ()
135+
getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
136+
getModificationTimeImpl vfs missingFileDiags file
115137

116138
getModificationTimeImpl :: VFSHandle
117-
-> (NormalizedFilePath -> Action Bool)
118139
-> Bool
119140
-> NormalizedFilePath
120141
-> Action
121142
(Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
122-
getModificationTimeImpl vfs isWatched missingFileDiags file = do
123-
let file' = fromNormalizedFilePath file
124-
let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
125-
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
126-
case mbVirtual of
127-
Just (virtualFileVersion -> ver) -> do
128-
alwaysRerun
129-
pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
130-
Nothing -> do
131-
isWF <- isWatched file
132-
if isWF
133-
then -- the file is watched so we can rely on FileWatched notifications,
134-
-- but also need a dependency on IsFileOfInterest to reinstall
135-
-- alwaysRerun when the file becomes VFS
136-
void (use_ IsFileOfInterest file)
137-
else if isInterface file
138-
then -- interface files are tracked specially using the closed world assumption
139-
pure ()
140-
else -- in all other cases we will need to freshly check the file system
141-
alwaysRerun
143+
getModificationTimeImpl vfs missingFileDiags file = do
144+
let file' = fromNormalizedFilePath file
145+
let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
146+
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
147+
case mbVirtual of
148+
Just (virtualFileVersion -> ver) -> do
149+
alwaysRerun
150+
pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
151+
Nothing -> do
152+
isWF <- use_ AddWatchedFile file
153+
if isWF
154+
then -- the file is watched so we can rely on FileWatched notifications,
155+
-- but also need a dependency on IsFileOfInterest to reinstall
156+
-- alwaysRerun when the file becomes VFS
157+
void (use_ IsFileOfInterest file)
158+
else if isInterface file
159+
then -- interface files are tracked specially using the closed world assumption
160+
pure ()
161+
else -- in all other cases we will need to freshly check the file system
162+
alwaysRerun
142163

143-
liftIO $ fmap wrap (getModTime file')
144-
`catch` \(e :: IOException) -> do
145-
let err | isDoesNotExistError e = "File does not exist: " ++ file'
146-
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
147-
diag = ideErrorText file (T.pack err)
148-
if isDoesNotExistError e && not missingFileDiags
149-
then return (Nothing, ([], Nothing))
150-
else return (Nothing, ([diag], Nothing))
164+
liftIO $ fmap wrap (getModTime file')
165+
`catch` \(e :: IOException) -> do
166+
let err | isDoesNotExistError e = "File does not exist: " ++ file'
167+
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
168+
diag = ideErrorText file (T.pack err)
169+
if isDoesNotExistError e && not missingFileDiags
170+
then return (Nothing, ([], Nothing))
171+
else return (Nothing, ([diag], Nothing))
151172

152173
-- | Interface files cannot be watched, since they live outside the workspace.
153174
-- But interface files are private, in that only HLS writes them.
@@ -239,9 +260,10 @@ getFileContents f = do
239260
fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
240261
fileStoreRules vfs isWatched = do
241262
addIdeGlobal vfs
242-
getModificationTimeRule vfs isWatched
263+
getModificationTimeRule vfs
243264
getFileContentsRule vfs
244265
isFileOfInterestRule
266+
addWatchedFileRule isWatched
245267

246268
-- | Note that some buffer for a specific file has been modified but not
247269
-- with what changes.
@@ -290,3 +312,43 @@ setSomethingModified state = do
290312
-- Update database to remove any files that might have been renamed/deleted
291313
atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles
292314
void $ shakeRestart state []
315+
316+
registerFileWatches :: [String] -> LSP.LspT Config IO Bool
317+
registerFileWatches globs = do
318+
watchSupported <- isWatchSupported
319+
if watchSupported
320+
then do
321+
let
322+
regParams = LSP.RegistrationParams (List [LSP.SomeRegistration registration])
323+
-- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
324+
-- We could also use something like a random UUID, as some other servers do, but this works for
325+
-- our purposes.
326+
registration = LSP.Registration "globalFileWatches"
327+
LSP.SWorkspaceDidChangeWatchedFiles
328+
regOptions
329+
regOptions =
330+
DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
331+
-- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
332+
watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}
333+
-- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
334+
-- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
335+
-- followed by a file with an extension 'hs'.
336+
watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
337+
-- We use multiple watchers instead of one using '{}' because lsp-test doesn't
338+
-- support that: https://github.com/bubba/lsp-test/issues/77
339+
watchers = [ watcher (Text.pack glob) | glob <- globs ]
340+
341+
void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ())
342+
return True
343+
else return False
344+
345+
isWatchSupported :: LSP.LspT Config IO Bool
346+
isWatchSupported = do
347+
clientCapabilities <- LSP.getClientCapabilities
348+
pure $ case () of
349+
_ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
350+
, Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
351+
, Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
352+
, Just True <- _dynamicRegistration
353+
-> True
354+
| otherwise -> False

‎ghcide/src/Development/IDE/Core/RuleTypes.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -267,6 +267,8 @@ type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
267267

268268
type instance RuleResult GetFileExists = Bool
269269

270+
type instance RuleResult AddWatchedFile = Bool
271+
270272

271273
-- The Shake key type for getModificationTime queries
272274
newtype GetModificationTime = GetModificationTime_
@@ -493,6 +495,12 @@ instance Binary GetClientSettings
493495

494496
type instance RuleResult GetClientSettings = Hashed (Maybe Value)
495497

498+
data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)
499+
instance Hashable AddWatchedFile
500+
instance NFData AddWatchedFile
501+
instance Binary AddWatchedFile
502+
503+
496504
-- A local rule type to get caching. We want to use newCache, but it has
497505
-- thread killed exception issues, so we lift it to a full rule.
498506
-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547

‎ghcide/src/Development/IDE/LSP/Notifications.hs‎

Lines changed: 12 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -11,10 +11,8 @@ module Development.IDE.LSP.Notifications
1111
, descriptor
1212
) where
1313

14-
import qualified Language.LSP.Server as LSP
1514
import Language.LSP.Types
1615
import qualified Language.LSP.Types as LSP
17-
import qualified Language.LSP.Types.Capabilities as LSP
1816

1917
import Development.IDE.Core.IdeConfiguration
2018
import Development.IDE.Core.Service
@@ -31,7 +29,8 @@ import qualified Data.Text as Text
3129
import Control.Monad.IO.Class
3230
import Development.IDE.Core.FileExists (modifyFileExists,
3331
watchedGlobs)
34-
import Development.IDE.Core.FileStore (resetFileStore,
32+
import Development.IDE.Core.FileStore (registerFileWatches,
33+
resetFileStore,
3534
setFileModified,
3635
setSomethingModified,
3736
typecheckParents)
@@ -108,38 +107,15 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
108107
liftIO $ shakeSessionInit ide
109108

110109
--------- Set up file watchers ------------------------------------------------------------------------
111-
clientCapabilities <- LSP.getClientCapabilities
112-
let watchSupported = case () of
113-
_ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
114-
, Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
115-
, Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
116-
, Just True <- _dynamicRegistration
117-
-> True
118-
| otherwise -> False
119-
if watchSupported
120-
then do
121-
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
122-
let
123-
regParams = RegistrationParams (List [SomeRegistration registration])
124-
-- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
125-
-- We could also use something like a random UUID, as some other servers do, but this works for
126-
-- our purposes.
127-
registration = Registration "globalFileWatches"
128-
SWorkspaceDidChangeWatchedFiles
129-
regOptions
130-
regOptions =
131-
DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
132-
-- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
133-
watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}
134-
-- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
135-
-- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
136-
-- followed by a file with an extension 'hs'.
137-
watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
138-
-- We use multiple watchers instead of one using '{}' because lsp-test doesn't
139-
-- support that: https://github.com/bubba/lsp-test/issues/77
140-
watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ]
141-
142-
void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response
143-
else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
110+
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
111+
-- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
112+
-- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
113+
-- followed by a file with an extension 'hs'.
114+
-- We use multiple watchers instead of one using '{}' because lsp-test doesn't
115+
-- support that: https://github.com/bubba/lsp-test/issues/77
116+
let globs = watchedGlobs opts
117+
success <- registerFileWatches globs
118+
unless success $
119+
liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
144120
]
145121
}

0 commit comments

Comments
 (0)