Improve recompilation avoidance in the presence of TH

.github/workflows/test.yml

@@ -208,11 +208,11 @@ jobs:
         name: Test hls-explicit-imports-plugin test suite
         run: cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS" || cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test
+      - if: matrix.test && matrix.os != 'windows-latest'
         name: Test hls-call-hierarchy-plugin test suite
         run: cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS" || cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test
+      - if: matrix.test && matrix.os != 'windows-latest'
         name: Test hls-rename-plugin test suite
         run: cabal test hls-rename-plugin --test-options="$TEST_OPTS" || cabal test hls-rename-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-rename-plugin --test-options="$TEST_OPTS"
 

ghcide/src/Development/IDE.hs

@@ -17,8 +17,7 @@ import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (.
                                                              isWorkspaceFile)
 import           Development.IDE.Core.OfInterest       as X (getFilesOfInterestUntracked)
 import           Development.IDE.Core.RuleTypes        as X
-import           Development.IDE.Core.Rules            as X (IsHiFileStable (..),
-                                                             getClientConfigAction,
+import           Development.IDE.Core.Rules            as X (getClientConfigAction,
                                                              getParsedModule)
 import           Development.IDE.Core.Service          as X (runAction)
 import           Development.IDE.Core.Shake            as X (FastResult (..),

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

@@ -138,6 +138,9 @@ data TcModuleResult = TcModuleResult
     -- ^ Typechecked splice information
     , tmrDeferedError    :: !Bool
     -- ^ Did we defer any type errors for this module?
+    , tmrRuntimeModules  :: !(ModuleEnv UTCTime)
+        -- ^ Which modules did we need at runtime while compiling this file?
+        -- Used for recompilation checking in the presence of TH
     }
 instance Show TcModuleResult where
     show = show . pm_mod_summary . tmrParsed
@@ -158,13 +161,15 @@ data HiFileResult = HiFileResult
     -- ^ Fingerprint for the ModIface
     , hirLinkableFp :: ByteString
     -- ^ Fingerprint for the Linkable
+    , hirRuntimeModules :: !(ModuleEnv UTCTime)
+    -- ^ same as tmrRuntimeModules
     }
 
 hiFileFingerPrint :: HiFileResult -> ByteString
 hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp
 
-mkHiFileResult :: ModSummary -> HomeModInfo -> HiFileResult
-mkHiFileResult hirModSummary hirHomeMod = HiFileResult{..}
+mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult
+mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..}
   where
     hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes
     hirLinkableFp = case hm_linkable hirHomeMod of

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

@@ -30,7 +30,6 @@ module Development.IDE.Core.Rules(
     usePropertyAction,
     -- * Rules
     CompiledLinkables(..),
-    IsHiFileStable(..),
     getParsedModuleRule,
     getParsedModuleWithCommentsRule,
     getLocatedImportsRule,
@@ -42,7 +41,6 @@ module Development.IDE.Core.Rules(
     getModIfaceFromDiskRule,
     getModIfaceRule,
     getModSummaryRule,
-    isHiFileStableRule,
     getModuleGraphRule,
     knownFilesRule,
     getClientSettingsRule,
@@ -100,7 +98,7 @@ import           Data.Tuple.Extra
 import           Development.IDE.Core.Compile
 import           Development.IDE.Core.FileExists hiding (LogShake, Log)
 import           Development.IDE.Core.FileStore               (getFileContents,
-                                                               resetInterfaceStore, modificationTime)
+                                                               resetInterfaceStore)
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest hiding (LogShake, Log)
 import           Development.IDE.Core.PositionMapping
@@ -121,7 +119,6 @@ import           Development.IDE.GHC.ExactPrint hiding (LogShake, Log)
 import           Development.IDE.GHC.Util                     hiding
                                                               (modifyDynFlags)
 import           Development.IDE.Graph
-import           Development.IDE.Graph.Classes
 import           Development.IDE.Import.DependencyInformation
 import           Development.IDE.Import.FindImports
 import qualified Development.IDE.Spans.AtPoint                as AtPoint
@@ -131,7 +128,6 @@ import           Development.IDE.Types.Diagnostics            as Diag
 import           Development.IDE.Types.HscEnvEq
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
-import           GHC.Generics                                 (Generic)
 import qualified GHC.LanguageExtensions                       as LangExt
 import qualified HieDb
 import           Ide.Plugin.Config
@@ -156,8 +152,9 @@ import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriori
 import qualified Development.IDE.Core.Shake as Shake
 import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake)
 import qualified Development.IDE.Types.Logger as Logger
+import qualified Development.IDE.Types.Shake as Shake
 
-data Log 
+data Log
   = LogShake Shake.Log
   | LogReindexingHieFile !NormalizedFilePath
   | LogLoadingHieFile !NormalizedFilePath
@@ -407,7 +404,7 @@ type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Act
 execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
 execRawDepM act =
     execStateT act
-        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
+        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty
         , IntMap.empty
         )
 
@@ -434,6 +431,11 @@ rawDependencyInformation fs = do
           let al = modSummaryToArtifactsLocation f msum
           -- Get a fresh FilePathId for the new file
           fId <- getFreshFid al
+          -- Record this module and its location
+          whenJust msum $ \ms ->
+            modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId)
+                                                                           (ShowableModuleName (moduleName $ ms_mod ms))
+                                                                           (rawModuleNameMap rd)})
           -- Adding an edge to the bootmap so we can make sure to
           -- insert boot nodes before the real files.
           addBootMap al fId
@@ -684,13 +686,10 @@ typeCheckRuleDefinition hsc pm = do
 
 -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload.
 -- Doesn't actually contain the code, since we don't need it to unload
-currentLinkables :: Action [Linkable]
+currentLinkables :: Action (ModuleEnv UTCTime)
 currentLinkables = do
     compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
-    hm <- liftIO $ readVar compiledLinkables
-    pure $ map go $ moduleEnvToList hm
-  where
-    go (mod, time) = LM time mod []
+    liftIO $ readVar compiledLinkables
 
 loadGhcSession :: Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules ()
 loadGhcSession recorder ghcSessionDepsConfig = do
@@ -768,15 +767,25 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env 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 :: Recorder (WithPriority Log) -> Rules ()
-getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIfaceFromDisk f -> do
+getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithOldValue $ \GetModIfaceFromDisk f old -> do
   ms <- msrModSummary <$> use_ GetModSummary f
   mb_session <- use GhcSessionDeps f
   case mb_session of
     Nothing -> return (Nothing, ([], Nothing))
     Just session -> do
-      sourceModified <- use_ IsHiFileStable f
       linkableType <- getLinkableType f
-      r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms)
+      ver <- use_ GetModificationTime f
+      let m_old = case old of
+            Shake.Succeeded (Just old_version) v -> Just (v, old_version)
+            Shake.Stale _   (Just old_version) v -> Just (v, old_version)
+            _ -> Nothing
+          recompInfo = RecompilationInfo
+            { source_version = ver
+            , old_value = m_old
+            , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
+            , regenerate = regenerateHiFile session f ms
+            }
+      r <- loadInterface (hscEnv session) ms linkableType recompInfo
       case r of
         (diags, Nothing) -> return (Nothing, (diags, Nothing))
         (diags, Just x) -> do
@@ -827,31 +836,6 @@ getModIfaceFromDiskAndIndexRule recorder =
 
   return (Just x)
 
-isHiFileStableRule :: Recorder (WithPriority Log) -> Rules ()
-isHiFileStableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsHiFileStable f -> do
-    ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f
-    let hiFile = toNormalizedFilePath'
-                $ Compat.ml_hi_file $ ms_location ms
-    mbHiVersion <- use  GetModificationTime_{missingFileDiagnostics=False} hiFile
-    modVersion  <- use_ GetModificationTime f
-    sourceModified <- case mbHiVersion of
-        Nothing -> pure SourceModified
-        Just x ->
-            if modificationTime x < modificationTime modVersion
-                then pure SourceModified
-                else do
-                    fileImports <- use_ GetLocatedImports f
-                    let imports = fmap artifactFilePath . snd <$> fileImports
-                    deps <- uses_ IsHiFileStable (catMaybes imports)
-                    pure $ if all (== SourceUnmodifiedAndStable) deps
-                           then SourceUnmodifiedAndStable
-                           else SourceUnmodified
-    return (Just (summarize sourceModified), Just sourceModified)
-  where
-      summarize SourceModified            = BS.singleton 1
-      summarize SourceUnmodified          = BS.singleton 2
-      summarize SourceUnmodifiedAndStable = BS.singleton 3
-
 displayTHWarning :: LspT c IO ()
 displayTHWarning
   | not isWindows && not hostIsDynamic = do
@@ -1148,7 +1132,6 @@ mainRule recorder RulesConfig{..} = do
     getModIfaceFromDiskAndIndexRule recorder
     getModIfaceRule recorder
     getModSummaryRule recorder
-    isHiFileStableRule recorder
     getModuleGraphRule recorder
     knownFilesRule recorder
     getClientSettingsRule recorder
@@ -1170,13 +1153,3 @@ mainRule recorder RulesConfig{..} = do
     persistentHieFileRule recorder
     persistentDocMapRule
     persistentImportMapRule
-
--- | Given the path to a module src file, this rule returns True if the
--- corresponding `.hi` file is stable, that is, if it is newer
---   than the src file, and all its dependencies are stable too.
-data IsHiFileStable = IsHiFileStable
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable IsHiFileStable
-instance NFData   IsHiFileStable
-
-type instance RuleResult IsHiFileStable = SourceModified

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

@@ -1034,6 +1034,7 @@ data RuleBody k v
     { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool
     , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)
     }
+  | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v))
 
 -- | Define a new Rule with early cutoff
 defineEarlyCutoff
@@ -1046,20 +1047,26 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe
     let diagnostics diags = do
             traceDiagnostics diags
             updateFileDiagnostics recorder file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
-    defineEarlyCutoff' diagnostics (==) key file old mode $ op key file
+    defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file
 defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do
     let diagnostics diags = do
             traceDiagnostics diags
             mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags
-    defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file
+    defineEarlyCutoff' diagnostics (==) key file old mode $ const $ second (mempty,) <$> op key file
 defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} =
     addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode ->
         otTracedAction key file mode traceA $ \ traceDiagnostics -> do
             let diagnostics diags = do
                     traceDiagnostics diags
                     mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags
             defineEarlyCutoff' diagnostics newnessCheck key file old mode $
-                second (mempty,) <$> build key file
+                const $ second (mempty,) <$> build key file
+defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do
+    extras <- getShakeExtras
+    let diagnostics diags = do
+            traceDiagnostics diags
+            updateFileDiagnostics recorder file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
+    defineEarlyCutoff' diagnostics (==) key file old mode $ op key file
 
 defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
 defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do
@@ -1080,7 +1087,7 @@ defineEarlyCutoff'
     -> NormalizedFilePath
     -> Maybe BS.ByteString
     -> RunMode
-    -> Action (Maybe BS.ByteString, IdeResult v)
+    -> (Value v -> Action (Maybe BS.ByteString, IdeResult v))
     -> Action (RunResult (A (RuleResult k)))
 defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
     ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras
@@ -1103,8 +1110,13 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
         res <- case val of
             Just res -> return res
             Nothing -> do
+                staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case
+                    Nothing                   -> Failed False
+                    Just (Succeeded ver v, _) -> Stale Nothing ver v
+                    Just (Stale d ver v, _)   -> Stale d ver v
+                    Just (Failed b, _)        -> Failed b
                 (bs, (diags, res)) <- actionCatch
-                    (do v <- action; liftIO $ evaluate $ force v) $
+                    (do v <- action staleV; liftIO $ evaluate $ force v) $
                     \(e :: SomeException) -> do
                         pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
 
@@ -1116,11 +1128,6 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
 
                 (bs, res) <- case res of
                     Nothing -> do
-                        staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case
-                            Nothing                   -> Failed False
-                            Just (Succeeded ver v, _) -> Stale Nothing ver v
-                            Just (Stale d ver v, _)   -> Stale d ver v
-                            Just (Failed b, _)        -> Failed b
                         pure (toShakeValue ShakeStale bs, staleV)
                     Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded modTime v)
                 liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags)