Skip to content

Commit 1b245ca

Browse files
pepeiborrapepeiborra
authored
Drive GetModificationTime using watched file events (#1487)
* Extend file watch suscriptions to monitor changes * file watch notifications for GetModificationTime * enable shake profiling in tests via SHAKE_PROFILING env var * log FileChanged events * rename and avoid resetting FOIs * Make IsFileOfInterest dependency explicit
1 parent 19207ef commit 1b245ca

File tree

6 files changed

+92
-51
lines changed

6 files changed

+92
-51
lines changed

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

Lines changed: 32 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -88,17 +88,27 @@ getFileExistsMapUntracked = do
8888
liftIO $ readVar v
8989

9090
-- | Modify the global store of file exists.
91-
modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
91+
modifyFileExists :: IdeState -> [FileEvent] -> IO ()
9292
modifyFileExists state changes = do
9393
FileExistsMapVar var <- getIdeGlobalState state
94-
changesMap <- evaluate $ HashMap.fromList changes
94+
changesMap <- evaluate $ HashMap.fromList $
95+
[ (toNormalizedFilePath' f, newState)
96+
| FileEvent uri change <- changes
97+
, Just f <- [uriToFilePath uri]
98+
, Just newState <- [fromChange change]
99+
]
95100
-- Masked to ensure that the previous values are flushed together with the map update
96101
mask $ \_ -> do
97102
-- update the map
98103
modifyVar_ var $ evaluate . HashMap.union changesMap
99104
-- See Note [Invalidating file existence results]
100105
-- flush previous values
101-
mapM_ (deleteValue state GetFileExists . fst) changes
106+
mapM_ (deleteValue state GetFileExists) (HashMap.keys changesMap)
107+
108+
fromChange :: FileChangeType -> Maybe Bool
109+
fromChange FcCreated = Just True
110+
fromChange FcDeleted = Just True
111+
fromChange FcChanged = Nothing
102112

103113
-------------------------------------------------------------------------------------
104114

@@ -145,7 +155,10 @@ This is fine so long as we're watching the files we check most often, i.e. sourc
145155

146156
-- | The list of file globs that we ask the client to watch.
147157
watchedGlobs :: IdeOptions -> [String]
148-
watchedGlobs opts = [ "**/*." ++ extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]]
158+
watchedGlobs opts = [ "**/*." ++ ext | ext <- allExtensions opts]
159+
160+
allExtensions :: IdeOptions -> [String]
161+
allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]]
149162

150163
-- | Installs the 'getFileExists' rules.
151164
-- Provides a fast implementation if client supports dynamic watched files.
@@ -170,19 +183,26 @@ fileExistsRules lspEnv vfs = do
170183
extras <- getShakeExtrasRules
171184
opts <- liftIO $ getIdeOptionsIO extras
172185
let globs = watchedGlobs opts
186+
patterns = fmap Glob.compile globs
187+
fpMatches fp = any (`Glob.match`fp) patterns
188+
isWatched = if supportsWatchedFiles
189+
then \f -> do
190+
isWF <- isWorkspaceFile f
191+
return $ isWF && fpMatches (fromNormalizedFilePath f)
192+
else const $ pure False
173193

174194
if supportsWatchedFiles
175-
then fileExistsRulesFast globs vfs
195+
then fileExistsRulesFast isWatched vfs
176196
else fileExistsRulesSlow vfs
177197

198+
fileStoreRules vfs isWatched
199+
178200
-- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked.
179-
fileExistsRulesFast :: [String] -> VFSHandle -> Rules ()
180-
fileExistsRulesFast globs vfs =
181-
let patterns = fmap Glob.compile globs
182-
fpMatches fp = any (\p -> Glob.match p fp) patterns
183-
in defineEarlyCutoff $ \GetFileExists file -> do
184-
isWf <- isWorkspaceFile file
185-
if isWf && fpMatches (fromNormalizedFilePath file)
201+
fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules ()
202+
fileExistsRulesFast isWatched vfs =
203+
defineEarlyCutoff $ \GetFileExists file -> do
204+
isWF <- isWatched file
205+
if isWF
186206
then fileExistsFast vfs file
187207
else fileExistsSlow vfs file
188208

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

Lines changed: 43 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ module Development.IDE.Core.FileStore(
1515
makeVFSHandle,
1616
makeLSPVFSHandle,
1717
isFileOfInterestRule
18-
) where
18+
,resetFileStore) where
1919

2020
import Control.Concurrent.Extra
2121
import Control.Concurrent.STM (atomically)
@@ -31,7 +31,7 @@ import Data.Maybe
3131
import qualified Data.Rope.UTF16 as Rope
3232
import qualified Data.Text as T
3333
import Data.Time
34-
import Development.IDE.Core.OfInterest (getFilesOfInterest)
34+
import Development.IDE.Core.OfInterest (getFilesOfInterest, OfInterestVar(..))
3535
import Development.IDE.Core.RuleTypes
3636
import Development.IDE.Core.Shake
3737
import Development.IDE.GHC.Orphans ()
@@ -63,6 +63,9 @@ import qualified Development.IDE.Types.Logger as L
6363
import Language.LSP.Server hiding
6464
(getVirtualFile)
6565
import qualified Language.LSP.Server as LSP
66+
import Language.LSP.Types (FileChangeType (FcChanged),
67+
FileEvent (FileEvent),
68+
uriToFilePath, toNormalizedFilePath)
6669
import Language.LSP.VFS
6770

6871
makeVFSHandle :: IO VFSHandle
@@ -93,24 +96,47 @@ isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
9396
let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest
9497
return (Just $ BS.pack $ show $ hash res, ([], Just res))
9598

96-
getModificationTimeRule :: VFSHandle -> Rules ()
97-
getModificationTimeRule vfs =
99+
getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
100+
getModificationTimeRule vfs isWatched =
98101
defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do
99102
let file' = fromNormalizedFilePath file
100103
let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
101-
alwaysRerun
102104
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
105+
-- we use 'getVirtualFile' to discriminate FOIs so make that
106+
-- dependency explicit by using the IsFileOfInterest rule
107+
_ <- use_ IsFileOfInterest file
103108
case mbVirtual of
104-
Just (virtualFileVersion -> ver) ->
109+
Just (virtualFileVersion -> ver) -> do
110+
alwaysRerun
105111
pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
106-
Nothing -> liftIO $ fmap wrap (getModTime file')
107-
`catch` \(e :: IOException) -> do
108-
let err | isDoesNotExistError e = "File does not exist: " ++ file'
109-
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
110-
diag = ideErrorText file (T.pack err)
111-
if isDoesNotExistError e && not missingFileDiags
112-
then return (Nothing, ([], Nothing))
113-
else return (Nothing, ([diag], Nothing))
112+
Nothing -> do
113+
isWF <- isWatched file
114+
unless isWF alwaysRerun
115+
liftIO $ fmap wrap (getModTime file')
116+
`catch` \(e :: IOException) -> do
117+
let err | isDoesNotExistError e = "File does not exist: " ++ file'
118+
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
119+
diag = ideErrorText file (T.pack err)
120+
if isDoesNotExistError e && not missingFileDiags
121+
then return (Nothing, ([], Nothing))
122+
else return (Nothing, ([diag], Nothing))
123+
124+
-- | Reset the GetModificationTime state of watched files
125+
resetFileStore :: IdeState -> [FileEvent] -> IO ()
126+
resetFileStore ideState changes = mask $ \_ ->
127+
forM_ changes $ \(FileEvent uri c) ->
128+
case c of
129+
FcChanged
130+
| Just f <- uriToFilePath uri
131+
-> do
132+
-- we record FOIs document versions in all the stored values
133+
-- so NEVER reset FOIs to avoid losing their versions
134+
OfInterestVar foisVar <- getIdeGlobalExtras (shakeExtras ideState)
135+
fois <- readVar foisVar
136+
unless (HM.member (toNormalizedFilePath f) fois) $ do
137+
deleteValue ideState (GetModificationTime_ True) (toNormalizedFilePath' f)
138+
deleteValue ideState (GetModificationTime_ False) (toNormalizedFilePath' f)
139+
_ -> pure ()
114140

115141
-- Dir.getModificationTime is surprisingly slow since it performs
116142
-- a ton of conversions. Since we do not actually care about
@@ -188,10 +214,10 @@ getFileContents f = do
188214
pure $ internalTimeToUTCTime large small
189215
return (modTime, txt)
190216

191-
fileStoreRules :: VFSHandle -> Rules ()
192-
fileStoreRules vfs = do
217+
fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
218+
fileStoreRules vfs isWatched = do
193219
addIdeGlobal vfs
194-
getModificationTimeRule vfs
220+
getModificationTimeRule vfs isWatched
195221
getFileContentsRule vfs
196222
isFileOfInterestRule
197223

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,8 @@
99
module Development.IDE.Core.OfInterest(
1010
ofInterestRules,
1111
getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
12-
kick, FileOfInterestStatus(..)
12+
kick, FileOfInterestStatus(..),
13+
OfInterestVar(..)
1314
) where
1415

1516
import Control.Concurrent.Extra

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

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,6 @@ module Development.IDE.Core.Service(
2020

2121
import Development.IDE.Core.Debouncer
2222
import Development.IDE.Core.FileExists (fileExistsRules)
23-
import Development.IDE.Core.FileStore (fileStoreRules)
2423
import Development.IDE.Core.OfInterest
2524
import Development.IDE.Types.Logger as Logger
2625
import Development.IDE.Types.Options (IdeOptions (..))
@@ -62,7 +61,6 @@ initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hied
6261
(optShakeOptions options)
6362
$ do
6463
addIdeGlobal $ GlobalIdeOptions options
65-
fileStoreRules vfs
6664
ofInterestRules
6765
fileExistsRules lspEnv vfs
6866
mainRule

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

Lines changed: 8 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -24,16 +24,15 @@ import Development.IDE.Types.Logger
2424
import Development.IDE.Types.Options
2525

2626
import Control.Monad.Extra
27-
import Data.Foldable as F
2827
import qualified Data.HashMap.Strict as M
2928
import qualified Data.HashSet as S
30-
import Data.Maybe
3129
import qualified Data.Text as Text
3230

3331
import Control.Monad.IO.Class
3432
import Development.IDE.Core.FileExists (modifyFileExists,
3533
watchedGlobs)
36-
import Development.IDE.Core.FileStore (setFileModified,
34+
import Development.IDE.Core.FileStore (resetFileStore,
35+
setFileModified,
3736
setSomethingModified,
3837
typecheckParents)
3938
import Development.IDE.Core.OfInterest
@@ -80,19 +79,13 @@ setHandlersNotifications = mconcat
8079
logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri
8180

8281
, notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $
83-
\ide (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do
82+
\ide (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do
8483
-- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and
8584
-- what we do with them
86-
let events =
87-
mapMaybe
88-
(\(FileEvent uri ev) ->
89-
(, ev /= FcDeleted) . toNormalizedFilePath'
90-
<$> LSP.uriToFilePath uri
91-
)
92-
( F.toList fileEvents )
93-
let msg = Text.pack $ show events
94-
logDebug (ideLogger ide) $ "Files created or deleted: " <> msg
95-
modifyFileExists ide events
85+
let msg = Text.pack $ show fileEvents
86+
logDebug (ideLogger ide) $ "Watched file events: " <> msg
87+
modifyFileExists ide fileEvents
88+
resetFileStore ide fileEvents
9689
setSomethingModified ide
9790

9891
, notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $
@@ -133,7 +126,7 @@ setHandlersNotifications = mconcat
133126
regOptions =
134127
DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
135128
-- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
136-
watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}
129+
watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}
137130
-- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
138131
-- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
139132
-- followed by a file with an extension 'hs'.

‎ghcide/test/exe/Main.hs

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1559,14 +1559,14 @@ suggestImportTests = testGroup "suggest import actions"
15591559
, test True [] "f = (&) [] id" [] "import Data.Function ((&))"
15601560
, test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))"
15611561
, test True [] "f = (.|.)" [] "import Data.Bits ((.|.))"
1562-
, test True
1562+
, test True
15631563
["qualified Data.Text as T"
15641564
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
1565-
, test True
1565+
, test True
15661566
[ "qualified Data.Text as T"
15671567
, "qualified Data.Function as T"
15681568
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
1569-
, test True
1569+
, test True
15701570
[ "qualified Data.Text as T"
15711571
, "qualified Data.Function as T"
15721572
, "qualified Data.Functor as T"
@@ -5149,8 +5149,11 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do
51495149
-- since the package import test creates "Data/List.hs", which otherwise has no physical home
51505150
createDirectoryIfMissing True $ projDir ++ "/Data"
51515151

5152+
shakeProfiling <- getEnv "SHAKE_PROFILING"
51525153
let cmd = unwords $
5153-
[ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir] ++ extraOptions
5154+
[ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir
5155+
] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]
5156+
] ++ extraOptions
51545157
-- HIE calls getXgdDirectory which assumes that HOME is set.
51555158
-- Only sets HOME if it wasn't already set.
51565159
setEnv "HOME" "/homeless-shelter" False

0 commit comments

Comments
 (0)