Drive GetModificationTime using watched file events

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
 

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
 

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

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

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'.

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