diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 5e4a98a77e..19ebf74904 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -88,17 +88,27 @@ getFileExistsMapUntracked = do liftIO $ readVar v -- | Modify the global store of file exists. -modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO () +modifyFileExists :: IdeState -> [FileEvent] -> IO () modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state - changesMap <- evaluate $ HashMap.fromList changes + changesMap <- evaluate $ HashMap.fromList $ + [ (toNormalizedFilePath' f, newState) + | FileEvent uri change <- changes + , Just f <- [uriToFilePath uri] + , Just newState <- [fromChange change] + ] -- Masked to ensure that the previous values are flushed together with the map update mask $ \_ -> do -- update the map modifyVar_ var $ evaluate . HashMap.union changesMap -- See Note [Invalidating file existence results] -- flush previous values - mapM_ (deleteValue state GetFileExists . fst) changes + mapM_ (deleteValue state GetFileExists) (HashMap.keys changesMap) + +fromChange :: FileChangeType -> Maybe Bool +fromChange FcCreated = Just True +fromChange FcDeleted = Just True +fromChange FcChanged = Nothing ------------------------------------------------------------------------------------- @@ -145,7 +155,10 @@ This is fine so long as we're watching the files we check most often, i.e. sourc -- | The list of file globs that we ask the client to watch. watchedGlobs :: IdeOptions -> [String] -watchedGlobs opts = [ "**/*." ++ extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]] +watchedGlobs opts = [ "**/*." ++ ext | ext <- allExtensions opts] + +allExtensions :: IdeOptions -> [String] +allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]] -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. @@ -170,19 +183,26 @@ fileExistsRules lspEnv vfs = do extras <- getShakeExtrasRules opts <- liftIO $ getIdeOptionsIO extras let globs = watchedGlobs opts + patterns = fmap Glob.compile globs + fpMatches fp = any (`Glob.match`fp) patterns + isWatched = if supportsWatchedFiles + then \f -> do + isWF <- isWorkspaceFile f + return $ isWF && fpMatches (fromNormalizedFilePath f) + else const $ pure False if supportsWatchedFiles - then fileExistsRulesFast globs vfs + then fileExistsRulesFast isWatched vfs else fileExistsRulesSlow vfs + fileStoreRules vfs isWatched + -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. -fileExistsRulesFast :: [String] -> VFSHandle -> Rules () -fileExistsRulesFast globs vfs = - let patterns = fmap Glob.compile globs - fpMatches fp = any (\p -> Glob.match p fp) patterns - in defineEarlyCutoff $ \GetFileExists file -> do - isWf <- isWorkspaceFile file - if isWf && fpMatches (fromNormalizedFilePath file) +fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () +fileExistsRulesFast isWatched vfs = + defineEarlyCutoff $ \GetFileExists file -> do + isWF <- isWatched file + if isWF then fileExistsFast vfs file else fileExistsSlow vfs file diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index d605a761fa..a05210bdf2 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -15,7 +15,7 @@ module Development.IDE.Core.FileStore( makeVFSHandle, makeLSPVFSHandle, isFileOfInterestRule - ) where + ,resetFileStore) where import Control.Concurrent.Extra import Control.Concurrent.STM (atomically) @@ -31,7 +31,7 @@ import Data.Maybe import qualified Data.Rope.UTF16 as Rope import qualified Data.Text as T import Data.Time -import Development.IDE.Core.OfInterest (getFilesOfInterest) +import Development.IDE.Core.OfInterest (getFilesOfInterest, OfInterestVar(..)) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.GHC.Orphans () @@ -63,6 +63,9 @@ import qualified Development.IDE.Types.Logger as L import Language.LSP.Server hiding (getVirtualFile) import qualified Language.LSP.Server as LSP +import Language.LSP.Types (FileChangeType (FcChanged), + FileEvent (FileEvent), + uriToFilePath, toNormalizedFilePath) import Language.LSP.VFS makeVFSHandle :: IO VFSHandle @@ -93,24 +96,47 @@ isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest return (Just $ BS.pack $ show $ hash res, ([], Just res)) -getModificationTimeRule :: VFSHandle -> Rules () -getModificationTimeRule vfs = +getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () +getModificationTimeRule vfs isWatched = defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do let file' = fromNormalizedFilePath file let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s)) - alwaysRerun mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file + -- we use 'getVirtualFile' to discriminate FOIs so make that + -- dependency explicit by using the IsFileOfInterest rule + _ <- use_ IsFileOfInterest file case mbVirtual of - Just (virtualFileVersion -> ver) -> + Just (virtualFileVersion -> ver) -> do + alwaysRerun pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver)) - Nothing -> liftIO $ fmap wrap (getModTime file') - `catch` \(e :: IOException) -> do - let err | isDoesNotExistError e = "File does not exist: " ++ file' - | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e - diag = ideErrorText file (T.pack err) - if isDoesNotExistError e && not missingFileDiags - then return (Nothing, ([], Nothing)) - else return (Nothing, ([diag], Nothing)) + Nothing -> do + isWF <- isWatched file + unless isWF alwaysRerun + liftIO $ fmap wrap (getModTime file') + `catch` \(e :: IOException) -> do + let err | isDoesNotExistError e = "File does not exist: " ++ file' + | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e + diag = ideErrorText file (T.pack err) + if isDoesNotExistError e && not missingFileDiags + then return (Nothing, ([], Nothing)) + else return (Nothing, ([diag], Nothing)) + +-- | Reset the GetModificationTime state of watched files +resetFileStore :: IdeState -> [FileEvent] -> IO () +resetFileStore ideState changes = mask $ \_ -> + forM_ changes $ \(FileEvent uri c) -> + case c of + FcChanged + | Just f <- uriToFilePath uri + -> do + -- we record FOIs document versions in all the stored values + -- so NEVER reset FOIs to avoid losing their versions + OfInterestVar foisVar <- getIdeGlobalExtras (shakeExtras ideState) + fois <- readVar foisVar + unless (HM.member (toNormalizedFilePath f) fois) $ do + deleteValue ideState (GetModificationTime_ True) (toNormalizedFilePath' f) + deleteValue ideState (GetModificationTime_ False) (toNormalizedFilePath' f) + _ -> pure () -- Dir.getModificationTime is surprisingly slow since it performs -- a ton of conversions. Since we do not actually care about @@ -188,10 +214,10 @@ getFileContents f = do pure $ internalTimeToUTCTime large small return (modTime, txt) -fileStoreRules :: VFSHandle -> Rules () -fileStoreRules vfs = do +fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules vfs isWatched = do addIdeGlobal vfs - getModificationTimeRule vfs + getModificationTimeRule vfs isWatched getFileContentsRule vfs isFileOfInterestRule diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index b39b5b2204..84c3774e86 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -9,7 +9,8 @@ module Development.IDE.Core.OfInterest( ofInterestRules, getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest, - kick, FileOfInterestStatus(..) + kick, FileOfInterestStatus(..), + OfInterestVar(..) ) where import Control.Concurrent.Extra diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index ae30b0c587..87c6148446 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -20,7 +20,6 @@ module Development.IDE.Core.Service( import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.FileStore (fileStoreRules) import Development.IDE.Core.OfInterest import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) @@ -62,7 +61,6 @@ initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hied (optShakeOptions options) $ do addIdeGlobal $ GlobalIdeOptions options - fileStoreRules vfs ofInterestRules fileExistsRules lspEnv vfs mainRule diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 658253b4a7..ccdcbacab6 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -24,16 +24,15 @@ import Development.IDE.Types.Logger import Development.IDE.Types.Options import Control.Monad.Extra -import Data.Foldable as F import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -import Data.Maybe import qualified Data.Text as Text import Control.Monad.IO.Class import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) -import Development.IDE.Core.FileStore (setFileModified, +import Development.IDE.Core.FileStore (resetFileStore, + setFileModified, setSomethingModified, typecheckParents) import Development.IDE.Core.OfInterest @@ -80,19 +79,13 @@ setHandlersNotifications = mconcat logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri , notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ - \ide (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do + \ide (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and -- what we do with them - let events = - mapMaybe - (\(FileEvent uri ev) -> - (, ev /= FcDeleted) . toNormalizedFilePath' - <$> LSP.uriToFilePath uri - ) - ( F.toList fileEvents ) - let msg = Text.pack $ show events - logDebug (ideLogger ide) $ "Files created or deleted: " <> msg - modifyFileExists ide events + let msg = Text.pack $ show fileEvents + logDebug (ideLogger ide) $ "Watched file events: " <> msg + modifyFileExists ide fileEvents + resetFileStore ide fileEvents setSomethingModified ide , notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ @@ -133,7 +126,7 @@ setHandlersNotifications = mconcat regOptions = DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind - watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} + watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True} -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, -- followed by a file with an extension 'hs'. diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index ab5a2a4387..852bcd992d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1559,14 +1559,14 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f = (&) [] id" [] "import Data.Function ((&))" , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" - , test True + , test True ["qualified Data.Text as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True + , test True [ "qualified Data.Text as T" , "qualified Data.Function as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True + , test True [ "qualified Data.Text as T" , "qualified Data.Function as T" , "qualified Data.Functor as T" @@ -5149,8 +5149,11 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do -- since the package import test creates "Data/List.hs", which otherwise has no physical home createDirectoryIfMissing True $ projDir ++ "/Data" + shakeProfiling <- getEnv "SHAKE_PROFILING" let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir] ++ extraOptions + [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir + ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] + ] ++ extraOptions -- HIE calls getXgdDirectory which assumes that HOME is set. -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False