define rules without diagnostics

Author: pepeiborra

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,8 +14,12 @@ module Development.IDE.Core.FileStore(
     VFSHandle,
     makeVFSHandle,
     makeLSPVFSHandle,
-    isFileOfInterestRule
-    ,resetFileStore) where
+    isFileOfInterestRule,
+    resetFileStore,
+    getModificationTimeImpl,
+    addIdeGlobal,
+    getFileContentsRule,
+    ) where
 
 import           Control.Concurrent.Extra
 import           Control.Concurrent.STM                       (atomically)
@@ -31,7 +35,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                  ()
@@ -65,7 +70,8 @@ import           Language.LSP.Server                          hiding
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.Types                           (FileChangeType (FcChanged),
                                                                FileEvent (FileEvent),
-                                                               uriToFilePath, toNormalizedFilePath)
+                                                               toNormalizedFilePath,
+                                                               uriToFilePath)
 import           Language.LSP.VFS
 
 makeVFSHandle :: IO VFSHandle
@@ -91,14 +97,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

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

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,30 @@ 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' 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' key file old mode $ second (mempty,) <$> op key file
+
+defineEarlyCutoff'
+    :: IdeRule k v
+    => k
+    -> NormalizedFilePath
+    -> Maybe BS.ByteString
+    -> RunMode
+    -> Action (Maybe BS.ByteString, IdeResult v)
+    -> Action (RunResult (A (RuleResult k)))
+defineEarlyCutoff' 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
@@ -929,7 +955,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
@@ -957,13 +983,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