From 9d500d07dcbde2244938b70671e84688a4a559b7 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 8 May 2021 16:30:13 +0100 Subject: [PATCH 1/4] Tell Shake what has changed --- .../session-loader/Development/IDE/Session.hs | 5 +- ghcide/src/Development/IDE.hs | 2 +- ghcide/src/Development/IDE/Core/Actions.hs | 2 +- ghcide/src/Development/IDE/Core/FileExists.hs | 4 +- ghcide/src/Development/IDE/Core/FileStore.hs | 56 +++++++---------- ghcide/src/Development/IDE/Core/OfInterest.hs | 58 ++++++++++------- ghcide/src/Development/IDE/Core/RuleTypes.hs | 9 --- ghcide/src/Development/IDE/Core/Shake.hs | 63 +++++++++++++++---- .../src/Development/IDE/LSP/Notifications.hs | 15 ++--- ghcide/src/Development/IDE/Types/Options.hs | 3 + ghcide/src/Development/IDE/Types/Shake.hs | 23 ++++++- .../src/Development/IDE/Graph/Database.hs | 11 +++- plugins/default/src/Ide/Plugin/Example.hs | 2 +- plugins/default/src/Ide/Plugin/Example2.hs | 2 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 5 +- .../src/Wingman/LanguageServer.hs | 4 +- 16 files changed, 164 insertions(+), 100 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c266147e99..44bfbb3b2d 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/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 diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 1c6e759b7c..ec1373f5e0 100644 --- a/ghcide/src/Development/IDE.hs +++ b/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, diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 8ac21151ae..e653a02728 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/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) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 39691c526c..80bdd84203 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 774ce30629..2bab6607d4 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 2c46bd0ba8..32129ec735 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -5,10 +5,13 @@ {-# 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 @@ -16,7 +19,6 @@ module Development.IDE.Core.OfInterest( 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 @@ -24,7 +26,7 @@ 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,15 +45,19 @@ 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 @@ -59,29 +65,39 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest -- | 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 diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 26e0cae3af..0b19fc85a4 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 499d8b043c..92c231fb5e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -30,7 +30,6 @@ module Development.IDE.Core.Shake( IdeRule, IdeResult, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, - shakeRestart, shakeEnqueue, shakeProfile, newSession, @@ -63,7 +62,7 @@ module Development.IDE.Core.Shake( FileVersion(..), Priority(..), updatePositionMapping, - deleteValue, + deleteValue, recordDirtyKeys, OnDiskRule(..), WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), @@ -91,7 +90,8 @@ import qualified Data.ByteString.Char8 as BS import Data.Dynamic import qualified Data.HashMap.Strict as HMap import Data.Hashable -import Data.List.Extra (partition, takeEnd) +import Data.List.Extra (foldl', partition, + takeEnd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -145,7 +145,13 @@ import PrelInfo import UniqSupply import Control.Exception.Extra hiding (bracket_) +import qualified Data.ByteString.Char8 as BS8 import Data.Default +import Data.Foldable (toList) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HSet +import Data.IORef.Extra (atomicModifyIORef'_, + atomicModifyIORef_) import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS @@ -187,7 +193,9 @@ data ShakeExtras = ShakeExtras ,progress :: ProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants - ,restartShakeSession :: [DelayedAction ()] -> IO () + ,restartShakeSession + :: [DelayedAction ()] + -> IO () ,ideNc :: IORef NameCache -- | A mapping of module name to known target (or candidate targets, if missing) ,knownTargetsVar :: Var (Hashed KnownTargets) @@ -204,6 +212,8 @@ data ShakeExtras = ShakeExtras , vfs :: VFSHandle , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config + , dirtyKeys :: IORef (HashSet SomeShakeValue) + -- ^ Set of dirty rule keys since the last Shake run } type WithProgressFunc = forall a. @@ -411,12 +421,23 @@ setValues state key file val diags = -- | Delete the value stored for a given ide build key deleteValue - :: (Typeable k, Hashable k, Eq k, Show k) + :: Shake.ShakeValue k => ShakeExtras -> k -> NormalizedFilePath -> IO () -deleteValue ShakeExtras{state} key file = void $ modifyVar' state $ HMap.delete (file, Key key) +deleteValue ShakeExtras{dirtyKeys, state} key file = do + void $ modifyVar' state $ HMap.delete (file, Key key) + atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) + +recordDirtyKeys + :: Shake.ShakeValue k + => ShakeExtras + -> k + -> [NormalizedFilePath] + -> IO () +recordDirtyKeys ShakeExtras{dirtyKeys} key file = + atomicModifyIORef_ dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: @@ -496,6 +517,7 @@ shakeOpen lspEnv defaultConfig logger debouncer let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv + dirtyKeys <- newIORef mempty pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase @@ -564,11 +586,13 @@ shakeRestart IdeState{..} acts = (\runner -> do (stopTime,()) <- duration (cancelShakeSession runner) res <- shakeDatabaseProfile shakeDb + backlog <- readIORef $ dirtyKeys shakeExtras let profile = case res of Just fp -> ", profile saved at " <> fp _ -> "" - let msg = T.pack $ "Restarting build session (aborting the previous one took " - ++ showDuration stopTime ++ profile ++ ")" + let msg = T.pack $ "Restarting build session " ++ keysMsg ++ abortMsg + keysMsg = "for keys " ++ show (HSet.toList backlog) ++ " " + abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" logDebug (logger shakeExtras) msg notifyTestingLogMessage shakeExtras msg ) @@ -609,9 +633,18 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. -newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession +newSession + :: ShakeExtras + -> ShakeDatabase + -> [DelayedActionInternal] + -> IO ShakeSession newSession extras@ShakeExtras{..} shakeDb acts = do + IdeOptions{optRunSubset} <- getIdeOptionsIO extras reenqueued <- atomically $ peekInProgress actionQueue + allPendingKeys <- + if optRunSubset + then Just <$> readIORef dirtyKeys + else return Nothing let -- A daemon-like action used to inject additional work -- Runs actions from the work queue sequentially @@ -632,8 +665,10 @@ newSession extras@ShakeExtras{..} shakeDb acts = do notifyTestingLogMessage extras msg workRun restore = withSpan "Shake session" $ \otSpan -> do - let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) - res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts') + whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk) + let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) + res <- try @SomeException $ + restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs let res' = case res of Left e -> "exception: " <> displayException e Right _ -> "completed" @@ -854,7 +889,7 @@ defineEarlyCutoff' -> Action (Maybe BS.ByteString, IdeResult v) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics key file old mode action = do - extras@ShakeExtras{state, progress, logger} <- getShakeExtras + extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do val <- case old of @@ -869,7 +904,7 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing _ -> return Nothing - case val of + res <- case val of Just res -> return res Nothing -> do (bs, (diags, res)) <- actionCatch @@ -903,6 +938,8 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res + liftIO $ atomicModifyIORef'_ dirtyKeys (HSet.delete $ toKey key file) + return res isSuccess :: A v -> Bool isSuccess (A Failed{}) = False diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 14f9b346de..a1b1a5b9ad 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -22,7 +22,6 @@ import Development.IDE.Types.Logger import Development.IDE.Types.Options import Control.Monad.Extra -import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import qualified Data.Text as Text @@ -35,6 +34,8 @@ import Development.IDE.Core.FileStore (registerFileWatches, setSomethingModified, typecheckParents) import Development.IDE.Core.OfInterest +import Development.IDE.Core.RuleTypes (GetClientSettings (..)) +import Development.IDE.Types.Shake (toKey) import Ide.Plugin.Config (CheckParents (CheckOnClose)) import Ide.Types @@ -49,7 +50,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open - modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True}) + addFileOfInterest ide file Modified{firstOpen=True} setFileModified ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri @@ -57,21 +58,21 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = \ide _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False}) + addFileOfInterest ide file Modified{firstOpen=False} setFileModified ide False file logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidSave $ \ide _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file OnDisk) + addFileOfInterest ide file OnDisk setFileModified ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidClose $ \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.delete file) + deleteFileOfInterest ide file -- Refresh all the files that depended on this checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide) when (checkParents >= CheckOnClose) $ typecheckParents ide file @@ -85,7 +86,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = logDebug (ideLogger ide) $ "Watched file events: " <> msg modifyFileExists ide fileEvents resetFileStore ide fileEvents - setSomethingModified ide + setSomethingModified ide [] , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ \ide _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do @@ -100,7 +101,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = let msg = Text.pack $ show cfg logDebug (ideLogger ide) $ "Configuration changed: " <> msg modifyClientSettings ide (const $ Just cfg) - setSomethingModified ide + setSomethingModified ide [toKey GetClientSettings emptyFilePath ] , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 7adfd82291..2989420f97 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -81,6 +81,8 @@ data IdeOptions = IdeOptions , optSkipProgress :: forall a. Typeable a => a -> Bool -- ^ Predicate to select which rule keys to exclude from progress reporting. , optProgressStyle :: ProgressReportingStyle + , optRunSubset :: Bool + -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed } optShakeFiles :: IdeOptions -> Maybe FilePath @@ -142,6 +144,7 @@ defaultIdeOptions session = IdeOptions ,optModifyDynFlags = mempty ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit + ,optRunSubset = False } defaultSkipProgress :: Typeable a => a -> Bool diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index a66a15160e..ae46829ac7 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -8,11 +8,12 @@ module Development.IDE.Types.Shake ValueWithDiagnostics (..), Values, Key (..), + SomeShakeValue, BadDependency (..), ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey) where import Control.DeepSeq @@ -26,7 +27,9 @@ import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Graph (RuleResult, ShakeException (shakeExceptionInner)) +import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Classes +import Development.IDE.Graph.Database (SomeShakeValue (..)) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics @@ -54,7 +57,7 @@ data ValueWithDiagnostics type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics -- | Key type -data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k +data Key = forall k . (Typeable k, Hashable k, Eq k, NFData k, Show k) => Key k instance Show Key where show (Key k) = show k @@ -64,7 +67,14 @@ instance Eq Key where | otherwise = False instance Hashable Key where - hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) + hashWithSalt salt (Key key) = hashWithSalt salt key + +instance Binary Key where + get = error "not really" + put _ = error "not really" + +instance NFData Key where + rnf (Key k) = rnf k -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action @@ -77,6 +87,13 @@ isBadDependency x | Just (_ :: BadDependency) <- fromException x = True | otherwise = False + +toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue +toKey = (SomeShakeValue .) . curry Q + +toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k, Binary k, NFData k) => k -> SomeShakeValue +toNoFileKey k = toKey k emptyFilePath + newtype Q k = Q (k, NormalizedFilePath) deriving newtype (Eq, Hashable, NFData) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index ebce4f4f56..ab3eed2084 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -1,8 +1,9 @@ module Development.IDE.Graph.Database( Shake.ShakeDatabase, + Shake.SomeShakeValue(..), shakeOpenDatabase, - shakeRunDatabase, + shakeRunDatabaseForKeys, Shake.shakeProfileDatabase, ) where @@ -14,5 +15,9 @@ import qualified Development.Shake.Database as Shake shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO Shake.ShakeDatabase, IO ()) shakeOpenDatabase a b = Shake.shakeOpenDatabase (fromShakeOptions a) (fromRules b) -shakeRunDatabase :: Shake.ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) -shakeRunDatabase a b = Shake.shakeRunDatabase a (map fromAction b) +shakeRunDatabaseForKeys + :: Maybe [Shake.SomeShakeValue] -- ^ Set of keys changed since last run + -> Shake.ShakeDatabase + -> [Action a] + -> IO ([a], [IO ()]) +shakeRunDatabaseForKeys keys a b = Shake.shakeRunDatabaseForKeys keys a (map fromAction b) diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 64098d9cc7..39a676dccd 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -77,7 +77,7 @@ exampleRules = do return ([diag], Just ()) action $ do - files <- getFilesOfInterest + files <- getFilesOfInterestUntracked void $ uses Example $ Map.keys files mkDiag :: NormalizedFilePath diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 8bc79fa5f8..dfa0fb1f4d 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -75,7 +75,7 @@ exampleRules = do return ([diag], Just ()) action $ do - files <- getFilesOfInterest + files <- getFilesOfInterestUntracked void $ uses Example2 $ Map.keys files mkDiag :: NormalizedFilePath diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 7629ef5445..24895a563e 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -120,8 +120,7 @@ type instance RuleResult GetHlintDiagnostics = () -- | Hlint rules to generate file diagnostics based on hlint hints -- | This rule is recomputed when: --- | - The files of interest have changed via `getFilesOfInterest` --- | - One of those files has been edited via +-- | - A file has been edited via -- | - `getIdeas` -> `getParsedModule` in any case -- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc -- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` @@ -140,7 +139,7 @@ rules plugin = do liftIO $ argsSettings flags action $ do - files <- getFilesOfInterest + files <- getFilesOfInterestUntracked void $ uses GetHlintDiagnostics $ Map.keys files where diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index c7052a7070..5bdbd79b41 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -27,7 +27,7 @@ import Data.Set (Set) import qualified Data.Set as S import qualified Data.Text as T import Data.Traversable -import Development.IDE (getFilesOfInterest, ShowDiagnostic (ShowDiag), srcSpanToRange) +import Development.IDE (getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange) import Development.IDE (hscEnv) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules (usePropertyAction) @@ -549,7 +549,7 @@ wingmanRules plId = do ) action $ do - files <- getFilesOfInterest + files <- getFilesOfInterestUntracked void $ uses WriteDiagnostics $ Map.keys files From 63e4fda86725a3bc63650a2fcaf3439d40388492 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 23 May 2021 07:36:57 +0100 Subject: [PATCH 2/4] Insert placeholders for missing Shake features --- .../src/Development/IDE/Graph/Database.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index ab3eed2084..9a1b534d1e 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -1,23 +1,36 @@ +{-# LANGUAGE ExistentialQuantification #-} module Development.IDE.Graph.Database( Shake.ShakeDatabase, - Shake.SomeShakeValue(..), + SomeShakeValue(..), shakeOpenDatabase, shakeRunDatabaseForKeys, Shake.shakeProfileDatabase, ) where +import Data.Typeable import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Rules +import Development.Shake (ShakeValue) +import Development.Shake.Classes import qualified Development.Shake.Database as Shake shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO Shake.ShakeDatabase, IO ()) shakeOpenDatabase a b = Shake.shakeOpenDatabase (fromShakeOptions a) (fromRules b) +data SomeShakeValue = forall k . ShakeValue k => SomeShakeValue k +instance Eq SomeShakeValue where SomeShakeValue a == SomeShakeValue b = cast a == Just b +instance Hashable SomeShakeValue where hashWithSalt s (SomeShakeValue x) = hashWithSalt s x +instance Show SomeShakeValue where show (SomeShakeValue x) = show x + shakeRunDatabaseForKeys - :: Maybe [Shake.SomeShakeValue] -- ^ Set of keys changed since last run + :: Maybe [SomeShakeValue] + -- ^ Set of keys changed since last run. 'Nothing' means everything has changed -> Shake.ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) -shakeRunDatabaseForKeys keys a b = Shake.shakeRunDatabaseForKeys keys a (map fromAction b) +shakeRunDatabaseForKeys _keys a b = + -- Shake upstream does not accept the set of keys changed yet + -- https://github.com/ndmitchell/shake/pull/802 + Shake.shakeRunDatabase a (map fromAction b) From 3ebe65dc1bd5c305d2e41e040adc15db975dec09 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 2 Jun 2021 10:55:53 +0100 Subject: [PATCH 3/4] disable run subset if the client doesn't support file watches --- ghcide/src/Development/IDE/Main.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 008c80bad0..cad2574d3a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -26,7 +26,8 @@ import Development.IDE (Action, Rules, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) -import Development.IDE.Core.FileStore (makeVFSHandle) +import Development.IDE.Core.FileStore (isWatchSupported, + makeVFSHandle) import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), registerIdeConfiguration) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), @@ -58,7 +59,7 @@ import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') import Development.IDE.Types.Logger (Logger (Logger)) import Development.IDE.Types.Options (IdeGhcSession, - IdeOptions (optCheckParents, optCheckProject, optReportProgress), + IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), clientSupportsProgress, defaultIdeOptions, optModifyDynFlags) @@ -215,12 +216,18 @@ defaultMain Arguments{..} = do setInitialDynFlags argsSessionLoadingOptions `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader - options = def_options + + -- disable runSubset if the client doesn't support watched files + runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported + + let options = def_options { optReportProgress = clientSupportsProgress caps , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins + , optRunSubset = runSubset } caps = LSP.resClientCapabilities env initialise From 488bdd24b44194a7fc3ef3b8efbb319ff2a0a1e6 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 2 Jun 2021 10:10:55 +0100 Subject: [PATCH 4/4] fix another cradle test --- ghcide/test/exe/Main.hs | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8ca24ef20e..461eda9123 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4694,7 +4694,6 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do let hieContents = "cradle: {bios: {shell: \"false\"}}" hiePath = dir "hie.yaml" liftIO $ writeFile hiePath hieContents - hieDoc <- createDoc hiePath "yaml" $ T.pack hieContents let aPath = dir "A.hs" doc <- createDoc aPath "haskell" "main = return ()" Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc @@ -4703,15 +4702,8 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do -- Fix the cradle and typecheck again let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - changeDoc - hieDoc - [ TextDocumentContentChangeEvent - { _range = Nothing, - _rangeLength = Nothing, - _text = validCradle - } - ] - + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] -- Force a session restart by making an edit, just to dirty the typecheck node changeDoc doc