implement restriction to transitive deps for module graph

Author: soulomoon

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

@@ -262,9 +262,12 @@ typecheckParents :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePat
 typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) parents
   where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp)
 
+
+useReverseTransDeps :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
+useReverseTransDeps file = transitiveReverseDependencies file <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file
 typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action ()
 typecheckParentsAction recorder nfp = do
-    revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp
+    revs <- useReverseTransDeps nfp
     case revs of
       Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp
       Just rs -> do

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

@@ -12,6 +12,7 @@ module Development.IDE.Core.Rules(
     -- * Types
     IdeState, GetParsedModule(..), TransitiveDependencies(..),
     GhcSessionIO(..), GetClientSettings(..),
+    useTransDepModuleGraph,
     -- * Functions
     runAction,
     toIdeResult,
@@ -472,7 +473,7 @@ rawDependencyInformation fs = do
 reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules ()
 reportImportCyclesRule recorder =
     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do
-        DependencyInformation{..} <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file
+        DependencyInformation {depErrorNodes, depPathIdMap} <- useTransDepModuleGraph file
         case pathToId depPathIdMap file of
           -- The header of the file does not parse, so it can't be part of any import cycles.
           Nothing -> pure []
@@ -633,17 +634,17 @@ dependencyInfoForFiles fs = do
   (rawDepInfo, bm) <- rawDependencyInformation fs
   let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo
   msrs <- uses GetModSummaryWithoutTimestamps all_fs
-  let mss = map (fmap msrModSummary) msrs
+  let mss = zip _all_ids $ map (fmap msrModSummary) msrs
   let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids
-      nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss
+      nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi (_, mms) -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss
       mns = catMaybes $ zipWith go mss deps
-      go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms
+      go (pid,Just ms) (Just (Right (ModuleImports xs))) = Just $ (pid, ModuleNode this_dep_keys ms)
         where this_dep_ids = mapMaybe snd xs
               this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids
-      go (Just ms) _ = Just $ ModuleNode [] ms
+      go (pid, Just ms) _ = Just $ (pid, ModuleNode [] ms)
       go _ _ = Nothing
-      mg = mkModuleGraph mns
-  let shallowFingers = IntMap.fromList $ foldr' (\(i, m) acc -> case m of
+      mg = IntMap.fromList $ map (first getFilePathId) mns
+  let shallowFingers = IntMap.fromList $! foldr' (\(i, m) acc -> case m of
                                         Just x -> (getFilePathId i,msrFingerprint x):acc
                                         Nothing -> acc) [] $ zip _all_ids msrs
   pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg shallowFingers)
@@ -663,7 +664,7 @@ typeCheckRuleDefinition hsc pm fp = do
   unlift <- askUnliftIO
   let dets = TypecheckHelpers
            { getLinkables = unliftIO unlift . uses_ GetLinkable
-           , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp
+           , getModuleGraph = unliftIO unlift $ useTransDepModuleGraph fp
            }
   addUsageDependencies $ liftIO $
     typecheckModule defer hsc dets pm
@@ -735,6 +736,11 @@ instance Default GhcSessionDepsConfig where
     { fullModuleGraph = True
     }
 
+useTransDepModuleGraph :: NormalizedFilePath -> Action DependencyInformation
+useTransDepModuleGraph file = filterDependencyInformationReachable file <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file
+useImmediateDepsModuleGraph :: NormalizedFilePath -> Action (Maybe DependencyInformation)
+useImmediateDepsModuleGraph file = useWithSeparateFingerprintRule GetModuleGraphTransDepsFingerprints GetModuleGraph file
+
 -- | Note [GhcSessionDeps]
 --   ~~~~~~~~~~~~~~~~~~~~~
 -- For a file 'Foo', GhcSessionDeps "Foo.hs" results in an HscEnv which includes
@@ -760,10 +766,10 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
             ifaces <- uses_ GetModIface deps
             let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces
-            de <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file
-            mg <- do
+            de <- useTransDepModuleGraph file
+            mg <- mkModuleGraph <$> do
               if fullModuleGraph
-              then return $ depModuleGraph de
+              then return $ IntMap.elems $ depModuleGraph de
               else do
                 let mgs = map hsc_mod_graph depSessions
                 -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
@@ -775,7 +781,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
                 let module_graph_nodes =
                       nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)
                 liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes
-                return $ mkModuleGraph module_graph_nodes
+                return module_graph_nodes
             session' <- liftIO $ mergeEnvs hsc mg de ms inLoadOrder depSessions
 
             -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new
@@ -805,7 +811,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
-            , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f
+            , get_module_graph = useTransDepModuleGraph f
             , regenerate = regenerateHiFile session f ms
             }
       hsc_env' <- setFileCacheHook (hscEnv session)
@@ -1139,7 +1145,7 @@ needsCompilationRule file
   | "boot" `isSuffixOf` fromNormalizedFilePath file =
     pure (Just $ encodeLinkableType Nothing, Just Nothing)
 needsCompilationRule file = do
-  graph <- useWithSeparateFingerprintRule GetModuleGraphImmediateReverseDepsFingerprints GetModuleGraph file
+  graph <- useImmediateDepsModuleGraph file
   res <- case graph of
     -- Treat as False if some reverse dependency header fails to parse
     Nothing -> pure Nothing

ghcide/src/Development/IDE/Import/DependencyInformation.hs

@@ -4,6 +4,7 @@
 
 module Development.IDE.Import.DependencyInformation
   ( DependencyInformation(..)
+  , filterDependencyInformationReachable
   , ModuleImports(..)
   , RawDependencyInformation(..)
   , NodeError(..)
@@ -137,6 +138,26 @@ data RawDependencyInformation = RawDependencyInformation
     , rawModuleMap :: !(FilePathIdMap ShowableModule)
     } deriving Show
 
+filterFilePathIdMap :: (IntMap.Key -> Bool) -> FilePathIdMap a -> FilePathIdMap a
+filterFilePathIdMap p = IntMap.filterWithKey (\k _ -> p k)
+
+filterDependencyInformationReachable :: NormalizedFilePath -> DependencyInformation -> DependencyInformation
+filterDependencyInformationReachable fileId depInfo@DependencyInformation{..} =
+  let reachableIds = transitiveDepIds depInfo fileId
+      curId = getFilePathId <$> lookupPathToId depPathIdMap fileId
+      isReachable k = IntSet.member k reachableIds || Just k == curId
+      filterMap = filterFilePathIdMap isReachable
+      rawModDeps = filterMap depModules
+  in depInfo {
+             depErrorNodes = filterMap depErrorNodes
+             , depModules  = rawModDeps
+             , depModuleDeps = filterMap depModuleDeps
+             , depReverseModuleDeps = filterMap depReverseModuleDeps
+             , depBootMap = filterMap depBootMap
+             , depModuleGraph = filterMap depModuleGraph
+             , depModuleFiles = ShowableModuleEnv $ mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModDeps
+  }
+
 data DependencyInformation =
   DependencyInformation
     { depErrorNodes         :: !(FilePathIdMap (NonEmpty NodeError))
@@ -153,7 +174,7 @@ data DependencyInformation =
     -- ^ Map from hs-boot file to the corresponding hs file
     , depModuleFiles        :: !(ShowableModuleEnv FilePathId)
     -- ^ Map from Module to the corresponding non-boot hs file
-    , depModuleGraph        :: !ModuleGraph
+    , depModuleGraph        :: !(FilePathIdMap ModuleGraphNode)
     , depTransDepsFingerprints :: !(FilePathIdMap Fingerprint)
     -- ^ Map from Module to fingerprint of the transitive dependencies of the module.
     , depTransReverseDepsFingerprints :: !(FilePathIdMap Fingerprint)
@@ -187,7 +208,10 @@ reachableModules DependencyInformation{..} =
     map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
 
 instance NFData DependencyInformation
-
+instance NFData ModuleGraphNode where
+    rnf = rwhnf
+instance Show (ModuleGraphNode) where
+    show (_) = "ModuleGraphNode"
 -- | This does not contain the actual parse error as that is already reported by GetParsedModule.
 data ModuleParseError = ModuleParseError
   deriving (Show, Generic)
@@ -243,7 +267,7 @@ instance Semigroup NodeResult where
    SuccessNode _ <> ErrorNode errs   = ErrorNode errs
    SuccessNode a <> SuccessNode _    = SuccessNode a
 
-processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> FilePathIdMap Fingerprint -> DependencyInformation
+processDependencyInformation :: RawDependencyInformation -> BootIdMap -> FilePathIdMap ModuleGraphNode -> FilePathIdMap Fingerprint -> DependencyInformation
 processDependencyInformation RawDependencyInformation{..} rawBootMap mg shallowFingerMap =
   DependencyInformation
     { depErrorNodes = IntMap.fromList errorNodes
@@ -359,6 +383,23 @@ immediateReverseDependencies file DependencyInformation{..} = do
   FilePathId cur_id <- lookupPathToId depPathIdMap file
   return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps))
 
+-- | returns all transitive dependencies ids
+transitiveDepIds :: DependencyInformation -> NormalizedFilePath -> IntSet.IntSet
+transitiveDepIds DependencyInformation{..} file = fromMaybe mempty $ do
+  !fileId <- pathToId depPathIdMap file
+  reachableVs <-
+      -- Delete the starting node
+      IntSet.delete (getFilePathId fileId) .
+      IntSet.fromList . map (fst3 . fromVertex) .
+      reachable g <$> toVertex (getFilePathId fileId)
+  let transitiveModuleDepIds = IntSet.fromList $ filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
+  return transitiveModuleDepIds
+  where
+    (g, fromVertex, toVertex) = graphFromEdges edges
+    edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps
+    boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]
+    vs = vertices g
+
 -- | returns all transitive dependencies in topological order.
 transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
 transitiveDeps DependencyInformation{..} file = do
@@ -372,7 +413,7 @@ transitiveDeps DependencyInformation{..} file = do
         filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
   let transitiveModuleDeps =
         map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
-  pure TransitiveDependencies {..}
+  pure TransitiveDependencies {transitiveModuleDeps}
   where
     (g, fromVertex, toVertex) = graphFromEdges edges
     edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs

@@ -43,7 +43,7 @@ import qualified Data.Text                                    as T
 import qualified Data.Text.Utf16.Rope.Mixed                   as Rope
 import           Development.IDE.Core.FileStore               (getUriContents, setSomethingModified)
 import           Development.IDE.Core.Rules                   (IdeState,
-                                                               runAction)
+                                                               runAction, useTransDepModuleGraph)
 import           Development.IDE.Core.Shake                   (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_)
 import           Development.IDE.GHC.Compat                   hiding (typeKind,
                                                                unitState)
@@ -253,7 +253,7 @@ initialiseSessionForEval needs_quickcheck st nfp = do
     ms <- msrModSummary <$> use_ GetModSummary nfp
     deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp
 
-    linkables_needed <- transitiveDeps <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph nfp <*> pure nfp
+    linkables_needed <- transitiveDeps <$> useTransDepModuleGraph nfp <*> pure nfp
     linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed)
     -- We unset the global rdr env in mi_globals when we generate interfaces
     -- See Note [Clearing mi_globals after generating an iface]