diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 7dad386ece..a5b8bcb570 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 83acfc7ed6..0d4e1edaeb 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/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 @@ -1229,7 +1235,7 @@ mainRule recorder RulesConfig{..} = do getModIfaceFromDiskAndIndexRule recorder getModIfaceRule recorder getModSummaryRule templateHaskellWarning recorder - getModuleGraphRule recorder + moduleGraphRules recorder getFileHashRule recorder knownFilesRule recorder getClientSettingsRule recorder @@ -1251,6 +1257,11 @@ mainRule recorder RulesConfig{..} = do persistentDocMapRule persistentImportMapRule getLinkableRule recorder + +-- | Rules for the module graph, which is used to track dependencies +moduleGraphRules :: Recorder (WithPriority Log) -> Rules () +moduleGraphRules recorder = do + moduleGraphRules recorder defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransDepsFingerprints file -> do di <- useNoFile_ GetModuleGraph let finger = lookupFingerprint file di (depTransDepsFingerprints di) @@ -1264,7 +1275,6 @@ mainRule recorder RulesConfig{..} = do let finger = lookupFingerprint file di (depImmediateReverseDepsFingerprints di) return (fingerprintToBS <$> finger, ([], finger)) - -- | Get HieFile for haskell file on NormalizedFilePath getHieFile :: NormalizedFilePath -> Action (Maybe HieFile) getHieFile nfp = runMaybeT $ do diff --git a/ghcide/src/Development/IDE/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs index 471cf52eab..7d169a9fc7 100644 --- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs +++ b/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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs index 1f19b5b476..8f17d4a503 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/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]