diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index c11762692d..5ab2abc052 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -12,7 +12,8 @@ import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (. isWorkspaceFile) import Development.IDE.Core.OfInterest as X (getFilesOfInterest) import Development.IDE.Core.RuleTypes as X -import Development.IDE.Core.Rules as X (getAtPoint, +import Development.IDE.Core.Rules as X (IsHiFileStable (..), + getAtPoint, getClientConfigAction, getDefinition, getParsedModule, @@ -21,10 +22,12 @@ import Development.IDE.Core.Service as X (runAction) import Development.IDE.Core.Shake as X (FastResult (..), IdeAction (..), IdeRule, IdeState, + RuleBody (..), ShakeExtras, actionLogger, define, defineEarlyCutoff, + defineNoDiagnostics, getClientConfig, getPluginConfig, ideLogger, diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 13e094d9be..ee068c36b9 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -200,7 +200,7 @@ fileExistsRules lspEnv vfs = do -- 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 = - defineEarlyCutoff $ \GetFileExists file -> do + defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> do isWF <- isWatched file if isWF then fileExistsFast vfs file @@ -222,7 +222,7 @@ 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, ([a], Maybe Bool)) +fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) fileExistsFast vfs file = do -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] mp <- getFileExistsMapUntracked @@ -233,21 +233,21 @@ fileExistsFast vfs file = do -- 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 - pure (summarizeExists exist, ([], Just exist)) + 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 $ \GetFileExists file -> fileExistsSlow vfs file + defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file -fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) +fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) fileExistsSlow vfs file = do -- See Note [Invalidating file existence results] alwaysRerun exist <- liftIO $ getFileExistsVFS vfs file - pure (summarizeExists exist, ([], Just exist)) + pure (summarizeExists exist, Just exist) getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool getFileExistsVFS vfs file = do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 8637dc489d..8f31c863e8 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -14,9 +14,12 @@ module Development.IDE.Core.FileStore( VFSHandle, makeVFSHandle, makeLSPVFSHandle, - isFileOfInterestRule - ,resetFileStore - ,resetInterfaceStore + isFileOfInterestRule, + resetFileStore, + resetInterfaceStore, + getModificationTimeImpl, + addIdeGlobal, + getFileContentsImpl ) where import Control.Concurrent.Extra @@ -33,7 +36,8 @@ 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, OfInterestVar(..)) +import Development.IDE.Core.OfInterest (OfInterestVar (..), + getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.GHC.Orphans () @@ -67,7 +71,9 @@ import Language.LSP.Server hiding import qualified Language.LSP.Server as LSP import Language.LSP.Types (FileChangeType (FcChanged), FileEvent (FileEvent), - uriToFilePath, toNormalizedFilePath) + NormalizedFilePath (NormalizedFilePath), + toNormalizedFilePath, + uriToFilePath) import Language.LSP.VFS import System.FilePath @@ -94,14 +100,22 @@ makeLSPVFSHandle lspEnv = VFSHandle isFileOfInterestRule :: Rules () -isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do +isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do filesOfInterest <- getFilesOfInterest let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest - return (Just $ BS.pack $ show $ hash res, ([], Just res)) + return (Just $ BS.pack $ show $ hash res, Just res) getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () -getModificationTimeRule vfs isWatched = - defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do +getModificationTimeRule vfs isWatched = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file -> + getModificationTimeImpl vfs isWatched missingFileDiags file + +getModificationTimeImpl :: VFSHandle + -> (NormalizedFilePath -> Action Bool) + -> Bool + -> NormalizedFilePath + -> Action + (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) +getModificationTimeImpl vfs isWatched missingFileDiags file = do let file' = fromNormalizedFilePath file let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s)) mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file @@ -196,16 +210,21 @@ internalTimeToUTCTime large small = #endif getFileContentsRule :: VFSHandle -> Rules () -getFileContentsRule vfs = - define $ \GetFileContents 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 - pure $ Rope.toText . _text <$> mbVirtual - case res of - Left err -> return ([err], Nothing) - Right contents -> return ([], Just (time, contents)) +getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file + +getFileContentsImpl + :: VFSHandle + -> NormalizedFilePath + -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) +getFileContentsImpl vfs 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 + pure $ Rope.toText . _text <$> mbVirtual + case res of + Left err -> return ([err], Nothing) + Right contents -> return ([], Just (time, contents)) ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a) ideTryIOException fp act = diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 84c3774e86..4ea6003258 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -56,10 +56,10 @@ instance Binary GetFilesOfInterest ofInterestRules :: Rules () ofInterestRules = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) - defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do + defineEarlyCutoff $ RuleNoDiagnostics $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked - pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest)) + pure (Just $ BS.fromString $ show filesOfInterest, Just filesOfInterest) -- | Get the files that are open in the IDE. diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 933a3ed9b2..3caca775d8 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -169,13 +169,13 @@ usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,Positi usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k) defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () -defineNoFile f = define $ \k file -> do - if file == emptyFilePath then do res <- f k; return ([], Just res) else +defineNoFile f = defineNoDiagnostics $ \k file -> do + if file == emptyFilePath then do res <- f k; return (Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () -defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do - if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else +defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do + if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" ------------------------------------------------------------ @@ -308,7 +308,7 @@ priorityFilesOfInterest = Priority (-2) -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 -- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations getParsedModuleRule :: Rules () -getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do +getParsedModuleRule = defineEarlyCutoff $ Rule $ \GetParsedModule file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess @@ -372,8 +372,9 @@ mergeParseErrorsHaddock normal haddock = normal ++ -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit. +-- FIXME this rule should probably not produce diagnostics getParsedModuleWithCommentsRule :: Rules () -getParsedModuleWithCommentsRule = defineEarlyCutoff $ \GetParsedModuleWithComments file -> do +getParsedModuleWithCommentsRule = defineEarlyCutoff $ Rule $ \GetParsedModuleWithComments file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file opt <- getIdeOptions @@ -569,13 +570,13 @@ reportImportCyclesRule = -- NOTE: result does not include the argument file. getDependenciesRule :: Rules () getDependenciesRule = - defineEarlyCutoff $ \GetDependencies file -> do + defineEarlyCutoff $ RuleNoDiagnostics $ \GetDependencies file -> do depInfo <- use_ GetDependencyInformation file let allFiles = reachableModules depInfo _ <- uses_ ReportImportCycles allFiles opts <- getIdeOptions let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts - return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file)) + return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) getHieAstsRule :: Rules () getHieAstsRule = @@ -739,7 +740,7 @@ loadGhcSession = do let fingerprint = hash (sessionVersion res) return (BS.pack (show fingerprint), res) - defineEarlyCutoff $ \GhcSession file -> do + defineEarlyCutoff $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file @@ -790,7 +791,7 @@ ghcSessionDepsDefinition file = do -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. getModIfaceFromDiskRule :: Rules () -getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do +getModIfaceFromDiskRule = defineEarlyCutoff $ Rule $ \GetModIfaceFromDisk f -> do ms <- msrModSummary <$> use_ GetModSummary f (diags_session, mb_session) <- ghcSessionDepsDefinition f case mb_session of @@ -814,7 +815,7 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do -- disk since we are careful to write out the `.hie` file before writing the -- `.hi` file getModIfaceFromDiskAndIndexRule :: Rules () -getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndIndex f -> do +getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do x <- use_ GetModIfaceFromDisk f se@ShakeExtras{hiedb} <- getShakeExtras @@ -844,10 +845,10 @@ getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndInd indexHieFile se ms f hash hf let fp = hiFileFingerPrint x - return (Just fp, ([], Just x)) + return (Just fp, Just x) isHiFileStableRule :: Rules () -isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do +isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' $ ml_hi_file $ ms_location ms @@ -865,11 +866,11 @@ isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do pure $ if all (== SourceUnmodifiedAndStable) deps then SourceUnmodifiedAndStable else SourceUnmodified - return (Just (BS.pack $ show sourceModified), ([], Just sourceModified)) + return (Just (BS.pack $ show sourceModified), Just sourceModified) getModSummaryRule :: Rules () getModSummaryRule = do - defineEarlyCutoff $ \GetModSummary f -> do + defineEarlyCutoff $ Rule $ \GetModSummary f -> do session <- hscEnv <$> use_ GhcSession f (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f @@ -884,7 +885,7 @@ getModSummaryRule = do return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) - defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do + defineEarlyCutoff $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do ms <- use GetModSummary f case ms of Just res@ModSummaryResult{..} -> do @@ -893,8 +894,8 @@ getModSummaryRule = do ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" } fp = fingerprintToBS msrFingerprint - return (Just fp, ([], Just res{msrModSummary = ms})) - Nothing -> return (Nothing, ([], Nothing)) + return (Just fp, Just res{msrModSummary = ms}) + Nothing -> return (Nothing, Nothing) generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) generateCore runSimplifier file = do @@ -908,7 +909,7 @@ generateCoreRule = define $ \GenerateCore -> generateCore (RunSimplifier True) getModIfaceRule :: Rules () -getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do +getModIfaceRule = defineEarlyCutoff $ Rule $ \GetModIface f -> do fileOfInterest <- use_ IsFileOfInterest f res@(_,(_,mhmi)) <- case fileOfInterest of IsFOI status -> do @@ -937,11 +938,11 @@ getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do pure res getModIfaceWithoutLinkableRule :: Rules () -getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do +getModIfaceWithoutLinkableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetModIfaceWithoutLinkable f -> do mhfr <- use GetModIface f let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f - pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr')) + pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', mhfr') -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the @@ -1037,7 +1038,7 @@ getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f needsCompilationRule :: Rules () -needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do +needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> do graph <- useNoFile GetModuleGraph res <- case graph of -- Treat as False if some reverse dependency header fails to parse @@ -1061,7 +1062,7 @@ needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do (uses NeedsCompilation revdeps) pure $ computeLinkableType ms modsums (map join needsComps) - pure (Just $ BS.pack $ show $ hash res, ([], Just res)) + pure (Just $ BS.pack $ show $ hash res, Just res) where uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 208293310d..1b7c30e4c1 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -38,7 +38,10 @@ module Development.IDE.Core.Shake( useWithStale, usesWithStale, useWithStale_, usesWithStale_, BadDependency(..), - define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, + RuleBody(..), + define, defineNoDiagnostics, + defineEarlyCutoff, + defineOnDisk, needOnDisk, needOnDisks, getDiagnostics, mRunLspT, mRunLspTCallback, getHiddenDiagnostics, @@ -796,7 +799,12 @@ garbageCollect keep = do define :: IdeRule k v => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () -define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v +define op = defineEarlyCutoff $ Rule $ \k v -> (Nothing,) <$> op k v + +defineNoDiagnostics + :: IdeRule k v + => (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () +defineNoDiagnostics op = defineEarlyCutoff $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v -- | Request a Rule result if available use :: IdeRule k v @@ -905,12 +913,31 @@ usesWithStale key files = do -- whether the rule succeeded or not. mapM (lastValue key) files +data RuleBody k v + = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) + + -- | Define a new Rule with early cutoff defineEarlyCutoff :: IdeRule k v - => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) + => RuleBody k v -> Rules () -defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do +defineEarlyCutoff (Rule op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do + defineEarlyCutoff' True key file old mode $ op key file +defineEarlyCutoff (RuleNoDiagnostics op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do + defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file + +defineEarlyCutoff' + :: IdeRule k v + => Bool -- ^ update diagnostics + -> k + -> NormalizedFilePath + -> Maybe BS.ByteString + -> RunMode + -> Action (Maybe BS.ByteString, IdeResult v) + -> Action (RunResult (A (RuleResult k))) +defineEarlyCutoff' doDiagnostics key file old mode action = do extras@ShakeExtras{state, inProgress} <- getShakeExtras -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do @@ -921,7 +948,8 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old -- No changes in the dependencies and we have -- an existing result. Just (v, diags) -> do - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags + when doDiagnostics $ + updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing _ -> return Nothing @@ -929,7 +957,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old Just res -> return res Nothing -> do (bs, (diags, res)) <- actionCatch - (do v <- op key file; liftIO $ evaluate $ force v) $ + (do v <- action; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file (bs, res) <- case res of @@ -946,7 +974,8 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old (toShakeValue ShakeResult bs, Failed b) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) liftIO $ setValues state key file res (Vector.fromList diags) - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags + when doDiagnostics $ + updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags let eq = case (bs, fmap decodeShakeValue old) of (ShakeResult a, Just (ShakeResult b)) -> a == b (ShakeStale a, Just (ShakeStale b)) -> a == b @@ -957,13 +986,14 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res - where - withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x + where + + withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x isSuccess :: RunResult (A v) -> Bool isSuccess (RunResult _ _ (A Failed{})) = False