Skip to content

Commit 9a782b7

Browse files
pepeiborrapepeiborra
committed
Use file watches for all workspace files
1 parent 88548ac commit 9a782b7

File tree

5 files changed

+141
-97
lines changed

5 files changed

+141
-97
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: 95 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,20 @@ 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
6670
import Language.LSP.Server hiding
6771
(getVirtualFile)
6872
import qualified Language.LSP.Server as LSP
69-
import Language.LSP.Types (FileChangeType (FcChanged),
73+
import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
74+
FileChangeType (FcChanged),
7075
FileEvent (FileEvent),
76+
FileSystemWatcher (..),
77+
WatchKind (..),
78+
_watchers,
7179
toNormalizedFilePath,
7280
uriToFilePath)
81+
import qualified Language.LSP.Types as LSP
82+
import qualified Language.LSP.Types.Capabilities as LSP
7383
import Language.LSP.VFS
7484
import System.FilePath
7585

@@ -94,6 +104,15 @@ makeLSPVFSHandle lspEnv = VFSHandle
94104
, setVirtualFileContents = Nothing
95105
}
96106

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

98117
isFileOfInterestRule :: Rules ()
99118
isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
@@ -109,45 +128,44 @@ isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest
109128
summarize (IsFOI (Modified True)) = BS.singleton 3
110129

111130

112-
getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
113-
getModificationTimeRule vfs isWatched = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
114-
getModificationTimeImpl vfs isWatched missingFileDiags file
131+
getModificationTimeRule :: VFSHandle -> Rules ()
132+
getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
133+
getModificationTimeImpl vfs missingFileDiags file
115134

116135
getModificationTimeImpl :: VFSHandle
117-
-> (NormalizedFilePath -> Action Bool)
118136
-> Bool
119137
-> NormalizedFilePath
120138
-> Action
121139
(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
140+
getModificationTimeImpl vfs missingFileDiags file = do
141+
let file' = fromNormalizedFilePath file
142+
let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
143+
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
144+
case mbVirtual of
145+
Just (virtualFileVersion -> ver) -> do
146+
alwaysRerun
147+
pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
148+
Nothing -> do
149+
isWF <- use_ AddWatchedFile file
150+
if isWF
151+
then -- the file is watched so we can rely on FileWatched notifications,
152+
-- but also need a dependency on IsFileOfInterest to reinstall
153+
-- alwaysRerun when the file becomes VFS
154+
void (use_ IsFileOfInterest file)
155+
else if isInterface file
156+
then -- interface files are tracked specially using the closed world assumption
157+
pure ()
158+
else -- in all other cases we will need to freshly check the file system
159+
alwaysRerun
142160

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))
161+
liftIO $ fmap wrap (getModTime file')
162+
`catch` \(e :: IOException) -> do
163+
let err | isDoesNotExistError e = "File does not exist: " ++ file'
164+
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
165+
diag = ideErrorText file (T.pack err)
166+
if isDoesNotExistError e && not missingFileDiags
167+
then return (Nothing, ([], Nothing))
168+
else return (Nothing, ([diag], Nothing))
151169

152170
-- | Interface files cannot be watched, since they live outside the workspace.
153171
-- But interface files are private, in that only HLS writes them.
@@ -239,9 +257,10 @@ getFileContents f = do
239257
fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
240258
fileStoreRules vfs isWatched = do
241259
addIdeGlobal vfs
242-
getModificationTimeRule vfs isWatched
260+
getModificationTimeRule vfs
243261
getFileContentsRule vfs
244262
isFileOfInterestRule
263+
addWatchedFileRule isWatched
245264

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