- maybeLookupUFM ufm u = case lookupUFM ufm u of
- Nothing -> []
- Just val -> [(u, val)]
-
--- Needed to clean up HPT so that we don't get duplicates in inst env
-downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName]
-downwards_closure_of_module summaries root
- = let toEdge :: ModSummary -> (ModuleName,[ModuleName])
- toEdge summ = (modSummaryName summ,
- filter (`elem` all_mods) (ms_allimps summ))
-
- all_mods = map modSummaryName summaries
-
- res = simple_transitive_closure (map toEdge summaries) [root]
- in
--- trace (showSDoc (text "DC of mod" <+> ppr root
--- <+> text "=" <+> ppr res)) $
- res
-
--- Calculate transitive closures from a set of roots given an adjacency list
-simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
-simple_transitive_closure graph set
- = let set2 = nub (concatMap dsts set ++ set)
- dsts node = fromMaybe [] (lookup node graph)
- in
- if length set == length set2
- then set
- else simple_transitive_closure graph set2
-
-
--- Calculate SCCs of the module graph, with or without taking into
--- account source imports.
-topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
-topological_sort include_source_imports summaries
- = let
- toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
- toEdge summ
- = (summ, modSummaryName summ,
- (if include_source_imports
- then ms_srcimps summ else []) ++ ms_imps summ)
-
- mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
- mash_edge (summ, m, m_imports)
- = case lookup m key_map of
- Nothing -> panic "reverse_topological_sort"
- Just mk -> (summ, mk,
- -- ignore imports not from the home package
- catMaybes (map (flip lookup key_map) m_imports))
-
- edges = map toEdge summaries
- key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
- scc_input = map mash_edge edges
- sccs = stronglyConnComp scc_input
- in
- sccs
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+ | otherwise = HsBootFile
+
+ -- We use integers as the keys for the SCC algorithm
+ nodes :: [(ModSummary, Int, [Int])]
+ nodes = [(s, fromJust (lookup_key (ms_hsc_src s) (ms_mod s)),
+ out_edge_keys hs_boot_key (ms_srcimps s) ++
+ out_edge_keys HsSrcFile (ms_imps s) )
+ | s <- summaries
+ , not (ms_hsc_src s == HsBootFile && drop_hs_boot_nodes) ]
+ -- Drop the hi-boot ones if told to do so
+
+ key_map :: NodeMap Int
+ key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries]
+ `zip` [1..])
+
+ lookup_key :: HscSource -> Module -> Maybe Int
+ lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
+
+ out_edge_keys :: HscSource -> [Module] -> [Int]
+ out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- the IsBootInterface parameter True; else False