Track file versions accurately

Author: wz1000

ghcide/ghcide.cabal

@@ -50,6 +50,7 @@ library
         dlist,
         exceptions,
         extra >= 1.7.4,
+        enummapset,
         fuzzy,
         filepath,
         fingertree,
@@ -148,6 +149,7 @@ library
         Development.IDE.Main.HeapStats
         Development.IDE.Core.Debouncer
         Development.IDE.Core.FileStore
+        Development.IDE.Core.FileUtils
         Development.IDE.Core.IdeConfiguration
         Development.IDE.Core.OfInterest
         Development.IDE.Core.PositionMapping

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

@@ -157,8 +157,8 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext
 -- | Installs the 'getFileExists' rules.
 --   Provides a fast implementation if client supports dynamic watched files.
 --   Creates a global state as a side effect in that case.
-fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules ()
-fileExistsRules lspEnv vfs = do
+fileExistsRules :: Maybe (LanguageContextEnv Config) -> Rules ()
+fileExistsRules lspEnv = do
   supportsWatchedFiles <- case lspEnv of
     Nothing      -> pure False
     Just lspEnv' -> liftIO $  runLspT lspEnv' isWatchSupported
@@ -179,19 +179,19 @@ fileExistsRules lspEnv vfs = do
         else const $ pure False
 
   if supportsWatchedFiles
-    then fileExistsRulesFast isWatched vfs
-    else fileExistsRulesSlow vfs
+    then fileExistsRulesFast isWatched
+    else fileExistsRulesSlow
 
-  fileStoreRules vfs isWatched
+  fileStoreRules isWatched
 
 -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked.
-fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules ()
-fileExistsRulesFast isWatched vfs =
+fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> Rules ()
+fileExistsRulesFast isWatched =
     defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> do
         isWF <- isWatched file
         if isWF
-            then fileExistsFast vfs file
-            else fileExistsSlow vfs file
+            then fileExistsFast file
+            else fileExistsSlow file
 
 {- Note [Invalidating file existence results]
 We have two mechanisms for getting file existence information:
@@ -209,8 +209,8 @@ For the VFS lookup, however, we won't get prompted to flush the result, so inste
 we use 'alwaysRerun'.
 -}
 
-fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
-fileExistsFast vfs file = do
+fileExistsFast :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
+fileExistsFast file = do
     -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results]
     mp <- getFileExistsMapUntracked
 
@@ -219,28 +219,27 @@ fileExistsFast vfs file = do
       Just exist -> pure exist
       -- We don't know about it: use the slow route.
       -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'.
-      Nothing    -> liftIO $ getFileExistsVFS vfs file
+      Nothing    -> getFileExistsVFS file
     pure (summarizeExists exist, Just exist)
 
 summarizeExists :: Bool -> Maybe BS.ByteString
 summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
 
-fileExistsRulesSlow :: VFSHandle -> Rules ()
-fileExistsRulesSlow vfs =
-  defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file
+fileExistsRulesSlow :: Rules ()
+fileExistsRulesSlow =
+  defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file
 
-fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
-fileExistsSlow vfs file = do
+fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
+fileExistsSlow file = do
     -- See Note [Invalidating file existence results]
     alwaysRerun
-    exist <- liftIO $ getFileExistsVFS vfs file
+    exist <- getFileExistsVFS file
     pure (summarizeExists exist, Just exist)
 
-getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
-getFileExistsVFS vfs file = do
-    -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
-    -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
-    -- cached 'No' rather than an exception in the wrong place
-    handle (\(_ :: IOException) -> return False) $
-        (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
-        Dir.doesFileExist (fromNormalizedFilePath file)
+getFileExistsVFS :: NormalizedFilePath -> Action Bool
+getFileExistsVFS file = do
+  vf <- getVirtualFile file
+  if isJust vf
+  then pure True
+  else liftIO $ handle (\(_ :: IOException) -> return False) $
+         Dir.doesFileExist (fromNormalizedFilePath file)

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

@@ -5,15 +5,11 @@
 
 module Development.IDE.Core.FileStore(
     getFileContents,
-    getVirtualFile,
     setFileModified,
     setSomethingModified,
     fileStoreRules,
     modificationTime,
     typecheckParents,
-    VFSHandle,
-    makeVFSHandle,
-    makeLSPVFSHandle,
     resetFileStore,
     resetInterfaceStore,
     getModificationTimeImpl,
@@ -27,20 +23,18 @@ module Development.IDE.Core.FileStore(
 import           Control.Concurrent.STM.Stats                 (STM, atomically,
                                                                modifyTVar')
 import           Control.Concurrent.STM.TQueue                (writeTQueue)
-import           Control.Concurrent.Strict
 import           Control.Exception
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import qualified Data.ByteString                              as BS
 import           Data.Either.Extra
-import qualified Data.Map.Strict                              as Map
-import           Data.Maybe
 import qualified Data.Rope.UTF16                              as Rope
 import qualified Data.Text                                    as T
 import           Data.Time
 import           Data.Time.Clock.POSIX
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
+import           Development.IDE.Core.FileUtils
 import           Development.IDE.GHC.Orphans                  ()
 import           Development.IDE.Graph
 import           Development.IDE.Import.DependencyInformation
@@ -55,8 +49,6 @@ import           System.IO.Error
 #ifdef mingw32_HOST_OS
 import qualified System.Directory                             as Dir
 #else
-import           System.Posix.Files                           (getFileStatus,
-                                                               modificationTimeHiRes)
 #endif
 
 import qualified Development.IDE.Types.Logger                 as L
@@ -67,8 +59,6 @@ import qualified Data.HashSet                                 as HSet
 import           Data.List                                    (foldl')
 import qualified Data.Text                                    as Text
 import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
-import           Language.LSP.Server                          hiding
-                                                              (getVirtualFile)
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
                                                                FileChangeType (FcChanged),
@@ -80,27 +70,6 @@ import qualified Language.LSP.Types.Capabilities              as LSP
 import           Language.LSP.VFS
 import           System.FilePath
 
-makeVFSHandle :: IO VFSHandle
-makeVFSHandle = do
-    vfsVar <- newVar (1, Map.empty)
-    pure VFSHandle
-        { getVirtualFile = \uri -> do
-              (_nextVersion, vfs) <- readVar vfsVar
-              pure $ Map.lookup uri vfs
-        , setVirtualFileContents = Just $ \uri content ->
-              void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $
-                  case content of
-                    Nothing -> Map.delete uri vfs
-                    -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.
-                    Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs
-        }
-
-makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle
-makeLSPVFSHandle lspEnv = VFSHandle
-    { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile
-    , setVirtualFileContents = Nothing
-   }
-
 addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()
 addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do
   isAlreadyWatched <- isWatched f
@@ -114,20 +83,19 @@ addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do
             Nothing -> pure $ Just False
 
 
-getModificationTimeRule :: VFSHandle -> Rules ()
-getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
-    getModificationTimeImpl vfs missingFileDiags file
+getModificationTimeRule :: Rules ()
+getModificationTimeRule = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
+    getModificationTimeImpl missingFileDiags file
 
-getModificationTimeImpl :: VFSHandle
-    -> Bool
-    -> NormalizedFilePath
-    -> Action
-        (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
-getModificationTimeImpl vfs missingFileDiags file = do
+getModificationTimeImpl
+  :: Bool
+  -> NormalizedFilePath
+  -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
+getModificationTimeImpl missingFileDiags file = do
     let file' = fromNormalizedFilePath file
     let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
-    mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
-    case mbVirtual of
+    mbVf <- getVirtualFile file
+    case mbVf of
         Just (virtualFileVersion -> ver) -> do
             alwaysRerun
             pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
@@ -180,43 +148,23 @@ resetFileStore ideState changes = mask $ \_ -> do
             _ -> pure ()
 
 
--- Dir.getModificationTime is surprisingly slow since it performs
--- a ton of conversions. Since we do not actually care about
--- the format of the time, we can get away with something cheaper.
--- For now, we only try to do this on Unix systems where it seems to get the
--- time spent checking file modifications (which happens on every change)
--- from > 0.5s to ~0.15s.
--- We might also want to try speeding this up on Windows at some point.
--- TODO leverage DidChangeWatchedFile lsp notifications on clients that
--- support them, as done for GetFileExists
-getModTime :: FilePath -> IO POSIXTime
-getModTime f =
-#ifdef mingw32_HOST_OS
-    utcTimeToPOSIXSeconds <$> Dir.getModificationTime f
-#else
-    modificationTimeHiRes <$> getFileStatus f
-#endif
-
 modificationTime :: FileVersion -> Maybe UTCTime
 modificationTime VFSVersion{}             = Nothing
 modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix
 
-getFileContentsRule :: VFSHandle -> Rules ()
-getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file
+getFileContentsRule :: Rules ()
+getFileContentsRule = define $ \GetFileContents file -> getFileContentsImpl file
 
 getFileContentsImpl
-    :: VFSHandle
-    -> NormalizedFilePath
+    :: NormalizedFilePath
     -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))
-getFileContentsImpl vfs file = do
+getFileContentsImpl file = do
     -- need to depend on modification time to introduce a dependency with Cutoff
     time <- use_ GetModificationTime file
-    res <- liftIO $ ideTryIOException file $ do
-        mbVirtual <- getVirtualFile vfs $ filePathToUri' file
+    res <- do
+        mbVirtual <- getVirtualFile file
         pure $ Rope.toText . _text <$> mbVirtual
-    case res of
-        Left err       -> return ([err], Nothing)
-        Right contents -> return ([], Just (time, contents))
+    pure ([], Just (time, res))
 
 ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
 ideTryIOException fp act =
@@ -240,11 +188,10 @@ getFileContents f = do
             pure $ posixSecondsToUTCTime posix
     return (modTime, txt)
 
-fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
-fileStoreRules vfs isWatched = do
-    addIdeGlobal vfs
-    getModificationTimeRule vfs
-    getFileContentsRule vfs
+fileStoreRules :: (NormalizedFilePath -> Action Bool) -> Rules ()
+fileStoreRules isWatched = do
+    getModificationTimeRule
+    getFileContentsRule
     addWatchedFileRule isWatched
 
 -- | Note that some buffer for a specific file has been modified but not
@@ -260,9 +207,6 @@ setFileModified state saved nfp = do
           AlwaysCheck -> True
           CheckOnSave -> saved
           _           -> False
-    VFSHandle{..} <- getIdeGlobalState state
-    when (isJust setVirtualFileContents) $
-        fail "setFileModified can't be called on this type of VFSHandle"
     join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
     restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") []
     when checkParents $
@@ -289,9 +233,6 @@ typecheckParentsAction nfp = do
 --   independently tracks which files are modified.
 setSomethingModified :: IdeState -> [Key] -> String -> IO ()
 setSomethingModified state keys reason = do
-    VFSHandle{..} <- getIdeGlobalState state
-    when (isJust setVirtualFileContents) $
-        fail "setSomethingModified can't be called on this type of VFSHandle"
     -- Update database to remove any files that might have been renamed/deleted
     atomically $ do
         writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)

ghcide/src/Development/IDE/Core/FileUtils.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE CPP          #-}
+
+module Development.IDE.Core.FileUtils(
+    getModTime,
+    ) where
+
+
+import           Data.Time.Clock.POSIX
+#ifdef mingw32_HOST_OS
+import qualified System.Directory                             as Dir
+#else
+import           System.Posix.Files                           (getFileStatus,
+                                                               modificationTimeHiRes)
+#endif
+
+-- Dir.getModificationTime is surprisingly slow since it performs
+-- a ton of conversions. Since we do not actually care about
+-- the format of the time, we can get away with something cheaper.
+-- For now, we only try to do this on Unix systems where it seems to get the
+-- time spent checking file modifications (which happens on every change)
+-- from > 0.5s to ~0.15s.
+-- We might also want to try speeding this up on Windows at some point.
+-- TODO leverage DidChangeWatchedFile lsp notifications on clients that
+-- support them, as done for GetFileExists
+getModTime :: FilePath -> IO POSIXTime
+getModTime f =
+#ifdef mingw32_HOST_OS
+    utcTimeToPOSIXSeconds <$> Dir.getModificationTime f
+#else
+    modificationTimeHiRes <$> getFileStatus f
+#endif

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

@@ -290,10 +290,12 @@ pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
 -- | Get the modification time of a file.
 type instance RuleResult GetModificationTime = FileVersion
 
+-- | Either athe mtime from disk or an LSP version
+-- LSP versions always compare as greater than on disk versions
 data FileVersion
-    = VFSVersion !Int32
-    | ModificationTime !POSIXTime
-    deriving (Show, Generic)
+    = ModificationTime !POSIXTime
+    | VFSVersion !Int32
+    deriving (Show, Generic, Eq, Ord)
 
 instance NFData FileVersion
 

ghcide/src/Development/IDE/Core/Rules.hs

@@ -84,6 +84,7 @@ import qualified Data.HashMap.Strict                          as HM
 import qualified Data.HashSet                                 as HashSet
 import           Data.Hashable
 import           Data.IORef
+import           Control.Concurrent.STM.TVar
 import           Data.IntMap.Strict                           (IntMap)
 import qualified Data.IntMap.Strict                           as IntMap
 import           Data.List
@@ -98,8 +99,7 @@ import           Data.Tuple.Extra
 import           Development.IDE.Core.Compile
 import           Development.IDE.Core.FileExists
 import           Development.IDE.Core.FileStore               (getFileContents,
-                                                               modificationTime,
-                                                               resetInterfaceStore)
+                                                               resetInterfaceStore, modificationTime)
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest
 import           Development.IDE.Core.PositionMapping
@@ -524,12 +524,11 @@ getHieAstsRule =
 persistentHieFileRule :: Rules ()
 persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do
   res <- readHieFileForSrcFromDisk file
-  vfs <- asks vfs
-  (currentSource,ver) <- liftIO $ do
-    mvf <- getVirtualFile vfs $ filePathToUri' file
-    case mvf of
-      Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
-      Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf)
+  vfsRef <- asks vfs
+  vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef
+  (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of
+    Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
+    Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf)
   let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res
       del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource
   pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver)