Improve fullModuleGraph code path

Author: wz1000

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

@@ -86,6 +86,7 @@ import Control.Concurrent.STM.TVar
 importData.IntMap.Strict (IntMap)
 importqualifiedData.IntMap.StrictasIntMap
 importData.List
+importData.List.Extra (nubOrdOn)
 importqualifiedData.MapasM
 importData.Maybe
 importqualifiedData.Text.Utf16.RopeasRope
@@ -159,6 +160,9 @@ import qualified Data.IntMap as IM
 importGHC.Unit.Module.Graph
 importGHC.Unit.Env
 #endif
+#if MIN_VERSION_ghc(9,2,0)
+importGHC (mgModSummaries)
+#endif
 
 dataLog
 =LogShakeShake.Log
@@ -792,10 +796,31 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
  depSessions <-map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
  ifaces <- uses_ GetModIface deps
 let inLoadOrder =map (\HiFileResult{..} ->HomeModInfo hirModIface hirModDetails Nothing) ifaces
- mg <-depModuleGraph <$>
+ mg <-do
 if fullModuleGraph
-then useNoFile_ GetModuleGraph
-else dependencyInfoForFiles [file]
+then depModuleGraph <$> useNoFile_ GetModuleGraph
+elsedo
+let mgs =map hsc_mod_graph depSessions
+#if MIN_VERSION_ghc(9,3,0)
+-- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
+-- also points to all the direct descendants of the current module. To get the keys for the descendants
+-- we must get their `ModSummary`s
+!final_deps <-do
+ dep_mss <-map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
+return$!!map (NodeKey_Module. msKey) dep_mss
+let module_graph_nodes =
+ nubOrdOn mkNodeKey (ModuleNode final_deps ms :concatMap mgModSummaries' mgs)
+#else
+let module_graph_nodes =
+#if MIN_VERSION_ghc(9,2,0)
+-- We don't do any instantiation for backpack at this point of time, so it is OK to use
+-- 'extendModSummaryNoDeps'.
+-- This may have to change in the future.
+map extendModSummaryNoDeps $
+#endif
+ nubOrdOn ms_mod (ms :concatMap mgModSummaries mgs)
+#endif
+pure$ mkModuleGraph module_graph_nodes
  session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions
 
 Just<$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])