Technology preview: Keep track of changes to minimize rebuilds (#1862)

* Tell Shake what has changed

* Insert placeholders for missing Shake features

* disable run subset if the client doesn't support file watches

* fix another cradle test

Author: pepeiborra

ghcide/session-loader/Development/IDE/Session.hs

@@ -236,8 +236,6 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
   -- Version of the mappings above
   version <- newVar 0
   let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
-  let invalidateShakeCache = do
-        void $ modifyVar' version succ
   -- This caches the mapping from Mod.hs -> hie.yaml
   cradleLoc <- liftIO $ memoIO $ \v -> do
       res <- findCradle v
@@ -253,6 +251,9 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
   return $ do
     extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv
                       } <- getShakeExtras
+    let invalidateShakeCache = do
+            void $ modifyVar' version succ
+            recordDirtyKeys extras GhcSessionIO [emptyFilePath]
 
     IdeOptions{ optTesting = IdeTesting optTesting
               , optCheckProject = getCheckProject

ghcide/src/Development/IDE.hs

@@ -15,7 +15,7 @@ import           Development.IDE.Core.FileExists       as X (getFileExists)
 import           Development.IDE.Core.FileStore        as X (getFileContents)
 import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..),
                                                              isWorkspaceFile)
-import           Development.IDE.Core.OfInterest       as X (getFilesOfInterest)
+import           Development.IDE.Core.OfInterest       as X (getFilesOfInterestUntracked)
 import           Development.IDE.Core.RuleTypes        as X
 import           Development.IDE.Core.Rules            as X (IsHiFileStable (..),
                                                              getClientConfigAction,

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

@@ -116,7 +116,7 @@ highlightAtPoint file pos = runMaybeT $ do
 refsAtPoint :: NormalizedFilePath -> Position -> Action [Location]
 refsAtPoint file pos = do
     ShakeExtras{hiedb} <- getShakeExtras
-    fs <- HM.keys <$> getFilesOfInterest
+    fs <- HM.keys <$> getFilesOfInterestUntracked
     asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs
     AtPoint.referencesAtPoint hiedb file pos (AtPoint.FOIReferences asts)
 

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

@@ -102,9 +102,11 @@ modifyFileExists state changes = do
     void $ modifyVar' var $ HashMap.union (HashMap.mapMaybe fromChange changesMap)
     -- See Note [Invalidating file existence results]
     -- flush previous values
-    let (_fileModifChanges, fileExistChanges) =
+    let (fileModifChanges, fileExistChanges) =
             partition ((== FcChanged) . snd) (HashMap.toList changesMap)
     mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
+    recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
+    recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
 
 fromChange :: FileChangeType -> Maybe Bool
 fromChange FcCreated = Just True

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

@@ -14,7 +14,6 @@ module Development.IDE.Core.FileStore(
     VFSHandle,
     makeVFSHandle,
     makeLSPVFSHandle,
-    isFileOfInterestRule,
     resetFileStore,
     resetInterfaceStore,
     getModificationTimeImpl,
@@ -40,8 +39,7 @@ 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.OfInterest              (OfInterestVar (..),
-                                                               getFilesOfInterest)
+import           Development.IDE.Core.OfInterest              (OfInterestVar (..))
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Orphans                  ()
@@ -50,6 +48,7 @@ import           Development.IDE.Import.DependencyInformation
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
+import           Development.IDE.Types.Shake                  (SomeShakeValue)
 import           HieDb.Create                                 (deleteMissingRealFiles)
 import           Ide.Plugin.Config                            (CheckParents (..),
                                                                Config)
@@ -66,6 +65,9 @@ import qualified Development.IDE.Types.Logger                 as L
 
 import qualified Data.Binary                                  as B
 import qualified Data.ByteString.Lazy                         as LBS
+import qualified Data.HashSet                                 as HSet
+import           Data.IORef.Extra                             (atomicModifyIORef_)
+import           Data.List                                    (foldl')
 import qualified Data.Text                                    as Text
 import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
 import           Language.LSP.Server                          hiding
@@ -117,19 +119,6 @@ addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do
                 registerFileWatches [fromNormalizedFilePath f]
             Nothing -> pure $ Just False
 
-isFileOfInterestRule :: Rules ()
-isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
-    filesOfInterest <- getFilesOfInterest
-    let foi = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest
-        fp  = summarize foi
-        res = (Just fp, Just foi)
-    return res
-    where
-    summarize NotFOI                   = BS.singleton 0
-    summarize (IsFOI OnDisk)           = BS.singleton 1
-    summarize (IsFOI (Modified False)) = BS.singleton 2
-    summarize (IsFOI (Modified True))  = BS.singleton 3
-
 
 getModificationTimeRule :: VFSHandle -> Rules ()
 getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
@@ -183,20 +172,21 @@ resetInterfaceStore state f = do
 
 -- | Reset the GetModificationTime state of watched files
 resetFileStore :: IdeState -> [FileEvent] -> IO ()
-resetFileStore ideState changes = mask $ \_ ->
-    forM_ changes $ \(FileEvent uri c) ->
+resetFileStore ideState changes = mask $ \_ -> 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
+    forM_ changes $ \(FileEvent uri c) -> do
         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 (shakeExtras ideState) GetModificationTime (toNormalizedFilePath' f)
+              , nfp <- toNormalizedFilePath f
+              , not $ HM.member nfp fois
+              -> deleteValue (shakeExtras ideState) GetModificationTime nfp
             _ -> 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.
@@ -262,7 +252,6 @@ fileStoreRules vfs isWatched = do
     addIdeGlobal vfs
     getModificationTimeRule vfs
     getFileContentsRule vfs
-    isFileOfInterestRule
     addWatchedFileRule isWatched
 
 -- | Note that some buffer for a specific file has been modified but not
@@ -281,7 +270,8 @@ setFileModified state saved nfp = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setFileModified can't be called on this type of VFSHandle"
-    shakeRestart state []
+    recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
+    restartShakeSession (shakeExtras state) []
     when checkParents $
       typecheckParents state nfp
 
@@ -301,17 +291,19 @@ typecheckParentsAction nfp = do
           `catch` \(e :: SomeException) -> log (show e)
         () <$ uses GetModIface rs
 
--- | Note that some buffer somewhere has been modified, but don't say what.
+-- | Note that some keys have been modified and restart the session
 --   Only valid if the virtual file system was initialised by LSP, as that
 --   independently tracks which files are modified.
-setSomethingModified :: IdeState -> IO ()
-setSomethingModified state = do
+setSomethingModified :: IdeState -> [SomeShakeValue] -> IO ()
+setSomethingModified state keys = 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 $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles
-    void $ shakeRestart state []
+    atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x ->
+        foldl' (flip HSet.insert) x keys
+    void $ restartShakeSession (shakeExtras state) []
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool
 registerFileWatches globs = do
@@ -338,7 +330,7 @@ registerFileWatches globs = do
           -- support that: https://github.com/bubba/lsp-test/issues/77
           watchers = [ watcher (Text.pack glob) | glob <- globs ]
 
-        void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ())
+        void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response
         return True
       else return False
 

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

@@ -5,26 +5,28 @@
 {-# LANGUAGE TypeFamilies      #-}
 
 -- | Utilities and state for the files of interest - those which are currently
---   open in the editor. The useful function is 'getFilesOfInterest'.
+--   open in the editor. The rule is 'IsFileOfInterest'
 module Development.IDE.Core.OfInterest(
     ofInterestRules,
-    getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
+    getFilesOfInterestUntracked,
+    addFileOfInterest,
+    deleteFileOfInterest,
+    setFilesOfInterest,
     kick, FileOfInterestStatus(..),
     OfInterestVar(..)
     ) where
 
 import           Control.Concurrent.Strict
 import           Control.Monad
 import           Control.Monad.IO.Class
-import           Data.Binary
 import           Data.HashMap.Strict                          (HashMap)
 import qualified Data.HashMap.Strict                          as HashMap
 import qualified Data.Text                                    as T
 import           Development.IDE.Graph
 
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Maybe
-import qualified Data.ByteString.Lazy                         as LBS
+import qualified Data.ByteString                              as BS
 import           Data.List.Extra                              (nubOrd)
 import           Data.Maybe                                   (catMaybes)
 import           Development.IDE.Core.ProgressReporting
@@ -43,45 +45,59 @@ instance IsIdeGlobal OfInterestVar
 ofInterestRules :: Rules ()
 ofInterestRules = do
     addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)
-    defineEarlyCutOffNoFile $ \GetFilesOfInterest -> do
+    defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
         alwaysRerun
         filesOfInterest <- getFilesOfInterestUntracked
-        let !cutoff = LBS.toStrict $ encode $ HashMap.toList filesOfInterest
-        pure (cutoff, filesOfInterest)
+        let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest
+            fp  = summarize foi
+            res = (Just fp, Just foi)
+        return res
+    where
+    summarize NotFOI                   = BS.singleton 0
+    summarize (IsFOI OnDisk)           = BS.singleton 1
+    summarize (IsFOI (Modified False)) = BS.singleton 2
+    summarize (IsFOI (Modified True))  = BS.singleton 3
 
--- | Get the files that are open in the IDE.
-getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
-getFilesOfInterest = useNoFile_ GetFilesOfInterest
 
 ------------------------------------------------------------
 -- Exposed API
 
 -- | Set the files-of-interest - not usually necessary or advisable.
 --   The LSP client will keep this information up to date.
 setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
-setFilesOfInterest state files = modifyFilesOfInterest state (const files)
+setFilesOfInterest state files = do
+    OfInterestVar var <- getIdeGlobalState state
+    writeVar var files
 
 getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
 getFilesOfInterestUntracked = do
     OfInterestVar var <- getIdeGlobalAction
     liftIO $ readVar var
 
--- | Modify the files-of-interest - not usually necessary or advisable.
---   The LSP client will keep this information up to date.
-modifyFilesOfInterest
-  :: IdeState
-  -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus)
-  -> IO ()
-modifyFilesOfInterest state f = do
+addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
+addFileOfInterest state f v = do
     OfInterestVar var <- getIdeGlobalState state
-    files <- modifyVar' var f
-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files)
+    (prev, files) <- modifyVar var $ \dict -> do
+        let (prev, new) = HashMap.alterF (, Just v) f dict
+        pure (new, (prev, dict))
+    when (prev /= Just v) $
+        recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
+    logDebug (ideLogger state) $
+        "Set files of interest to: " <> T.pack (show files)
+
+deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
+deleteFileOfInterest state f = do
+    OfInterestVar var <- getIdeGlobalState state
+    files <- modifyVar' var $ HashMap.delete f
+    recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
+    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
+
 
 -- | Typecheck all the files of interest.
 --   Could be improved
 kick :: Action ()
 kick = do
-    files <- HashMap.keys <$> getFilesOfInterest
+    files <- HashMap.keys <$> getFilesOfInterestUntracked
     ShakeExtras{progress} <- getShakeExtras
     liftIO $ progressUpdate progress KickStarted
 

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

@@ -40,7 +40,6 @@ import           HscTypes                                     (HomeModInfo,
 import qualified Data.Binary                                  as B
 import           Data.ByteString                              (ByteString)
 import qualified Data.ByteString.Lazy                         as LBS
-import           Data.HashMap.Strict                          (HashMap)
 import           Data.Text                                    (Text)
 import           Data.Time
 import           Development.IDE.Import.FindImports           (ArtifactsLocation)
@@ -356,8 +355,6 @@ type instance RuleResult GetModSummary = ModSummaryResult
 -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff
 type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult
 
-type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus
-
 data GetParsedModule = GetParsedModule
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetParsedModule
@@ -521,12 +518,6 @@ instance Hashable GhcSessionIO
 instance NFData   GhcSessionIO
 instance Binary   GhcSessionIO
 
-data GetFilesOfInterest = GetFilesOfInterest
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetFilesOfInterest
-instance NFData   GetFilesOfInterest
-instance Binary   GetFilesOfInterest
-
 makeLensesWith
     (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
     ''Splices