Split module interface rule into interface and code outputs

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

@@ -1028,8 +1028,8 @@ writeHiFile se hscEnv tc =
     atomicFileWrite se targetPath $ \fp ->
       writeIfaceFile hscEnv fp modIface
   where
-    modIface = hirModIface tc
-    targetPath = ml_hi_file $ ms_location $ hirModSummary tc
+    modIface = hirModIface (hirIface tc)
+    targetPath = ml_hi_file $ ms_location $ hirModSummary (hirIface tc)
     dflags = hsc_dflags hscEnv
 
 handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
@@ -1562,7 +1562,7 @@ loadInterface
   -> m ([FileDiagnostic], Maybe HiFileResult)
 loadInterface session ms linkableNeeded RecompilationInfo{..} = do
     let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session
-        mb_old_iface = hirModIface . fst <$> old_value
+        mb_old_iface = hirModIface . hirIface . fst <$> old_value
 
         core_file = ml_core_file (ms_location ms)
         iface_file = ml_hi_file (ms_location ms)

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

@@ -183,7 +183,8 @@ instance NFData TcModuleResult where
 tmrModSummary :: TcModuleResult -> ModSummary
 tmrModSummary = pm_mod_summary . tmrParsed
 
-data HiFileResult = HiFileResult
+-- | Everything a module contributes to its dependents' typechecking.
+data ModIfaceResult = ModIfaceResult
     { hirModSummary     :: !ModSummary
     -- Bang patterns here are important to stop the result retaining
     -- a reference to a typechecked module
@@ -194,24 +195,38 @@ data HiFileResult = HiFileResult
     -- ^ Fingerprint for the ModIface
     , hirRuntimeModules :: !(ModuleEnv ByteString)
     -- ^ same as tmrRuntimeModules
-    , hirCoreFp         :: !(Maybe ByteString)
+    }
+
+data HiFileResult = HiFileResult
+    { hirIface  :: !ModIfaceResult
+    , hirCoreFp :: !(Maybe ByteString)
     -- ^ Hash of the core file, if written.
     }
 
+-- | Content-address for a compiled module. This covers both
+-- - the module's ABI, see 'hirIfaceFp'
+-- - the serialized corefile for linkables, see 'hirCoreFp'
+-- Changing either implies dependents of the module need to be updated.
 hiFileFingerPrint :: HiFileResult -> ByteString
-hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> fromMaybe "" hirCoreFp
+hiFileFingerPrint HiFileResult{..} = hirIfaceFp hirIface <> fromMaybe "" hirCoreFp
 
 mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe ByteString -> HiFileResult
 mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =
-    HiFileResult{..}
+    HiFileResult{hirIface = ModIfaceResult{..}, ..}
   where
     hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes
 
+instance NFData ModIfaceResult where
+    rnf = rwhnf
+
+instance Show ModIfaceResult where
+    show = show . hirModSummary
+
 instance NFData HiFileResult where
     rnf = rwhnf
 
 instance Show HiFileResult where
-    show = show . hirModSummary
+    show = show . hirIface
 
 -- | Save the uncompressed AST here, we compress it just before writing to disk
 data HieAstResult
@@ -289,8 +304,14 @@ type instance RuleResult GetModIfaceFromDisk = HiFileResult
 --   This is an internal rule, use 'GetModIface' instead.
 type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult
 
--- | Get a module interface details, either from an interface file or a typechecked module
-type instance RuleResult GetModIface = HiFileResult
+-- | Get a module interface details, either from an interface file or a typechecked module.
+type instance RuleResult GetModIface = ModIfaceResult
+
+-- | Get a compiled module's interface and the core file hash.
+type instance RuleResult GetModArtefacts = HiFileResult
+
+-- | Get a module's core file. Depend on this when you need generated code.
+type instance RuleResult GetCoreFileHash = ByteString
 
 -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
 type instance RuleResult GetFileContents = (FileVersion, Maybe Rope)
@@ -440,6 +461,16 @@ data GetModuleGraph = GetModuleGraph
 instance Hashable GetModuleGraph
 instance NFData   GetModuleGraph
 
+data GetModArtefacts = GetModArtefacts
+    deriving (Eq, Show, Generic)
+instance Hashable GetModArtefacts
+instance NFData   GetModArtefacts
+
+data GetCoreFileHash = GetCoreFileHash
+    deriving (Eq, Show, Generic)
+instance Hashable GetCoreFileHash
+instance NFData   GetCoreFileHash
+
 data GetModuleGraphTransDepsFingerprints = GetModuleGraphTransDepsFingerprints
     deriving (Eq, Show, Generic)
 instance Hashable GetModuleGraphTransDepsFingerprints

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

@@ -902,11 +902,14 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file =
                 -- Fixes the bug in #4631
                 env = msrHscEnv msr
             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
-            ifaces <- uses_ GetModIface deps
+            needsCode <- uses_ NeedsCompilation deps
+            let (codeDeps, plainDeps) = partition (isJust . snd) (zip deps needsCode)
+            ifaces <- (++) <$> uses_ GetModIface (map fst codeDeps)
+                           <*> (map hirIface <$> uses_ GetModArtefacts (map fst plainDeps))
             -- Load .hs-boot before .hs: the HPT is keyed by module name, and
             -- GHC's addHomeModInfoToHpt overwrites, so the non-boot must be last.
             let inLoadOrder = sortOn (not . isBootHmi)
-                  $ map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces
+                  $ map (\ModIfaceResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces
                 isBootHmi hmi = case mi_hsc_src (hm_iface hmi) of
                   HsBootFile -> True
                   _          -> False
@@ -960,7 +963,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
-            , get_linkable_hashes = \fs -> map (fromJust . hirCoreFp) <$> uses_ GetModIface fs
+            , get_linkable_hashes = \fs -> uses_ GetCoreFileHash fs
             , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f
             , regenerate = regenerateHiFile session f ms
             }
@@ -988,7 +991,7 @@ getModIfaceFromDiskAndIndexRule recorder =
   se@ShakeExtras{withHieDb} <- getShakeExtras
 
   -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db
-  let ms = hirModSummary x
+  let ms = hirModSummary (hirIface x)
       hie_loc = Compat.ml_hie_file $ ms_location ms
   fileHash <- liftIO $ Util.getFileHash hie_loc
   mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f))
@@ -1073,31 +1076,40 @@ generateCoreRule recorder =
     define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True)
 
 getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()
-getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do
-  fileOfInterest <- use_ IsFileOfInterest f
-  res <- case fileOfInterest of
-    IsFOI status -> do
-      -- Never load from disk for files of interest
-      tmr <- use_ TypeCheck f
-      linkableType <- getLinkableType f
-      hsc <- hscEnv <$> use_ GhcSessionDeps f
-      hsc' <- setFileCacheHook hsc
-      let compile = fmap ([],) $ use GenerateCore f
-      se <- getShakeExtras
-      (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr
-      let fp = hiFileFingerPrint <$> mbHiFile
-      hiDiags <- case mbHiFile of
-        Just hiFile
-          | OnDisk <- status
-          , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile
-        _ -> pure []
-      return (fp, (diags++hiDiags, mbHiFile))
-    NotFOI -> do
-      hiFile <- use GetModIfaceFromDiskAndIndex f
-      let fp = hiFileFingerPrint <$> hiFile
-      return (fp, ([], hiFile))
-
-  pure res
+getModIfaceRule recorder = do
+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModArtefacts f -> do
+    fileOfInterest <- use_ IsFileOfInterest f
+    res <- case fileOfInterest of
+      IsFOI status -> do
+        -- Never load from disk for files of interest
+        tmr <- use_ TypeCheck f
+        linkableType <- getLinkableType f
+        hsc <- hscEnv <$> use_ GhcSessionDeps f
+        hsc' <- setFileCacheHook hsc
+        let compile = fmap ([],) $ use GenerateCore f
+        se <- getShakeExtras
+        (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr
+        let fp = hiFileFingerPrint <$> mbHiFile
+        hiDiags <- case mbHiFile of
+          Just hiFile
+            | OnDisk <- status
+            , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile
+          _ -> pure []
+        return (fp, (diags++hiDiags, mbHiFile))
+      NotFOI -> do
+        hiFile <- use GetModIfaceFromDiskAndIndex f
+        let fp = hiFileFingerPrint <$> hiFile
+        return (fp, ([], hiFile))
+    pure res
+  -- Variants of `GetModArtefacts`, so dependents can be more precise in what
+  -- they require from a module.
+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModIface file -> do
+    hir <- fmap hirIface <$> use GetModArtefacts file
+    return (hirIfaceFp <$> hir, hir)
+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetCoreFileHash file -> do
+    hir <- use GetModArtefacts file
+    let h = hirCoreFp =<< hir
+    return (h, h)
 
 -- | Count of total times we asked GHC to recompile
 newtype RebuildCounter = RebuildCounter { getRebuildCountVar :: TVar Int }
@@ -1223,7 +1235,8 @@ usePropertyByPathAction path plId p = do
 getLinkableRule :: Recorder (WithPriority Log) -> Rules ()
 getLinkableRule recorder =
   defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithOldValue $ \GetLinkable f old_value -> do
-    HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f
+    ModIfaceResult{hirModSummary, hirModIface, hirModDetails} <- use_ GetModIface f
+    mbCoreFp <- use GetCoreFileHash f
     let obj_file  = ml_obj_file (ms_location hirModSummary)
         core_file = ml_core_file (ms_location hirModSummary)
 #if MIN_VERSION_ghc(9,11,0)
@@ -1241,7 +1254,7 @@ getLinkableRule recorder =
         -- An empty part list is treated as bytecode by isObjectLinkable
         keepLinkables t mod = [mkLinkable t mod (DotA "dummy"), LM t mod []]
 #endif
-    case hirCoreFp of
+    case mbCoreFp of
       Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f
       Just fileHash -> do
         session <- use_ GhcSessionDeps f

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

@@ -1226,7 +1226,11 @@ data RuleBody k v
     }
   | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v))
 
--- | Define a new Rule with early cutoff
+-- | Define a rule that can rerun without dirtying its dependents.
+--
+-- A rerun normally prompts every dependent to rerun. Early cutoff content
+-- addresses the result, so hls-graph reruns dependents only when the returned
+-- fingerprint has changed.
 defineEarlyCutoff
     :: IdeRule k v
     => Recorder (WithPriority Log)

ghcide/src/Development/IDE/Types/Options.hs

@@ -170,6 +170,9 @@ defaultSkipProgress key = case () of
     -- don't do progress for GetModificationTime as there are lot of redundant nodes
     -- (for the interface files)
     _ | Just GetModificationTime_{} <- cast key -> True
+    -- don't do progress for these, counted via GetModArtefacts instead
+    _ | Just GetModIface <- cast key            -> True
+    _ | Just GetCoreFileHash <- cast key        -> True
     _                                           -> False
 
 

plugins/hls-eval-plugin/test/Main.hs

@@ -213,7 +213,7 @@ tests =
         changeDoc doc []
         _ <- waitForTypecheck doc
         Right keys <- getLastBuildKeys
-        let ifaceKeys = filter ("GetModIface" `T.isPrefixOf`) keys
+        let ifaceKeys = filter (\k -> any (`T.isPrefixOf` k) ["GetModIface", "GetModArtefacts"]) keys
         liftIO $ ifaceKeys @?= []
     , goldenWithEval "Works with OPTIONS_GHC -O1" "TGHCOptionO1" "hs"
   ]