Avoid redundant work in diagnostics pass

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,

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

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 =

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.

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