Commit e8590218 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Implement a findCycle function in Digraph,

and use it to report module loops nicely

This fixes Trac #5307. Now we get

    Module imports form a cycle:
             module `M8' (.\M8.hs)
            imports `M1' (M1.hs)
      which imports `M9' (.\M9.hs-boot)
      which imports `M8' (.\M8.hs)

And the algorithm is linear time.
parent 9500b166
{-# LANGUAGE ScopedTypeVariables #-}
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2011
......@@ -1459,51 +1461,32 @@ multiRootsErr summs@(summ1:_)
cyclicModuleErr :: [ModSummary] -> SDoc
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr ms
= ASSERT( not (null ms) )
hang (ptext (sLit "Module imports form a cycle:"))
2 (show_path (shortest [] root_mod))
cyclicModuleErr mss
= ASSERT( not (null mss) )
case findCycle graph of
Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss
Just path -> vcat [ ptext (sLit "Module imports form a cycle:")
, nest 2 (show_path path) ]
where
deps :: [(ModuleName, [ModuleName])]
deps = [ (moduleName (ms_mod m), get_deps m) | m <- ms ]
get_deps :: ModSummary -> [ModuleName]
get_deps m = filter (\k -> Map.member k dep_env) (map unLoc (ms_home_imps m))
dep_env :: Map.Map ModuleName [ModuleName]
dep_env = Map.fromList deps
-- Find the module with fewest imports among the SCC modules
-- This is just a heuristic to find some plausible root module
root_mod :: ModuleName
root_mod = fst (minWith (length . snd) deps)
shortest :: [ModuleName] -> ModuleName -> [ModuleName]
-- (shortest [v1,v2,..,vn] m) assumes that
-- m is imported by v1
-- which is imported by v2
-- ...
-- which is imported by vn
-- It retuns an import chain [w1, w2, ..wm]
-- where w1 imports w2 imports .... imports wm imports w1
shortest visited m
| m `elem` visited
= m : reverse (takeWhile (/= m) visited)
| otherwise
= minWith length (map (shortest (m:visited)) deps)
where
Just deps = Map.lookup m dep_env
graph :: [Node NodeKey ModSummary]
graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
get_deps :: ModSummary -> [NodeKey]
get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++
[ (unLoc m, HsSrcFile) | m <- ms_home_imps ms ])
show_path [] = panic "show_path"
show_path [m] = ptext (sLit "module") <+> quotes (ppr m)
show_path [m] = ptext (sLit "module") <+> ppr_ms m
<+> ptext (sLit "imports itself")
show_path (m1:m2:ms) = ptext (sLit "module") <+> quotes (ppr m1)
<+> sep ( nest 6 (ptext (sLit "imports") <+> quotes (ppr m2))
: go ms)
show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1)
: nest 6 (ptext (sLit "imports") <+> ppr_ms m2)
: go ms )
where
go [] = [ptext (sLit "which imports") <+> quotes (ppr m1)]
go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms
go [] = [ptext (sLit "which imports") <+> ppr_ms m1]
go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms
minWith :: Ord b => (a -> b) -> [a] -> a
minWith get_key xs = ASSERT( not (null xs) )
head (sortWith get_key xs)
ppr_ms :: ModSummary -> SDoc
ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
(parens (text (msHsFilePath ms)))
......@@ -3,10 +3,11 @@
%
\begin{code}
{-# LANGUAGE ScopedTypeVariables #-}
module Digraph(
Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices,
SCC(..), flattenSCC, flattenSCCs,
SCC(..), Node, flattenSCC, flattenSCCs,
stronglyConnCompG, topologicalSortG,
verticesG, edgesG, hasVertexG,
reachableG, transposeG,
......@@ -14,6 +15,8 @@ module Digraph(
vertexGroupsG, emptyG,
componentsG,
findCycle,
-- For backwards compatability with the simpler version of Digraph
stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR,
......@@ -37,7 +40,7 @@ module Digraph(
------------------------------------------------------------------------------
import Util ( sortLe )
import Util ( sortLe, minWith, count )
import Outputable
import Maybes ( expectJust )
import MonadUtils ( allM )
......@@ -51,6 +54,8 @@ import Data.Maybe
import Data.Array
import Data.List ( (\\) )
import Data.Array.ST
import qualified Data.Map as Map
import qualified Data.Set as Set
\end{code}
%************************************************************************
......@@ -78,6 +83,13 @@ data Graph node = Graph {
data Edge node = Edge node node
type Node key payload = (payload, key, [key])
-- The payload is user data, just carried around in this module
-- The keys are ordered
-- The [key] are the dependencies of the node;
-- it's ok to have extra keys in the dependencies that
-- are not the key of any Node in the graph
emptyGraph :: Graph a
emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
......@@ -101,10 +113,10 @@ graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vert
graphFromEdgedVertices
:: Ord key
=> [(node, key, [key])] -- The graph; its ok for the
=> [Node key payload] -- The graph; its ok for the
-- out-list to contain keys which arent
-- a vertex key, they are ignored
-> Graph (node, key, [key])
-> Graph (Node key payload)
graphFromEdgedVertices [] = emptyGraph
graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
where key_extractor (_, k, _) = k
......@@ -146,6 +158,63 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte
%* *
%************************************************************************
\begin{code}
type WorkItem key payload
= (Node key payload, -- Tip of the path
[payload]) -- Rest of the path;
-- [a,b,c] means c depends on b, b depends on a
-- | Find a reasonably short cycle a->b->c->a, in a strongly
-- connected component. The input nodes are presumed to be
-- a SCC, so you can start anywhere.
findCycle :: forall payload key. Ord key
=> [Node key payload] -- The nodes. The dependencies can
-- contain extra keys, which are ignored
-> Maybe [payload] -- A cycle, starting with node
-- so each depends on the next
findCycle graph
= go Set.empty (new_work root_deps []) []
where
env :: Map.Map key (Node key payload)
env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ]
-- Find the node with fewest dependencies among the SCC modules
-- This is just a heuristic to find some plausible root module
root :: Node key payload
root = fst (minWith snd [ (node, count (`Map.member` env) deps)
| node@(_,_,deps) <- graph ])
(root_payload,root_key,root_deps) = root
-- 'go' implements Dijkstra's algorithm, more or less
go :: Set.Set key -- Visited
-> [WorkItem key payload] -- Work list, items length n
-> [WorkItem key payload] -- Work list, items length n+1
-> Maybe [payload] -- Returned cycle
-- Invariant: in a call (go visited ps qs),
-- visited = union (map tail (ps ++ qs))
go _ [] [] = Nothing -- No cycles
go visited [] qs = go visited qs []
go visited (((payload,key,deps), path) : ps) qs
| key == root_key = Just (root_payload : reverse path)
| key `Set.member` visited = go visited ps qs
| key `Map.notMember` env = go visited ps qs
| otherwise = go (Set.insert key visited)
ps (new_qs ++ qs)
where
new_qs = new_work deps (payload : path)
new_work :: [key] -> [payload] -> [WorkItem key payload]
new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
\end{code}
%************************************************************************
%* *
%* SCC
%* *
%************************************************************************
\begin{code}
data SCC vertex = AcyclicSCC vertex
| CyclicSCC [vertex]
......@@ -194,8 +263,8 @@ stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }
-- The following two versions are provided for backwards compatability:
stronglyConnCompFromEdgedVertices
:: Ord key
=> [(node, key, [key])]
-> [SCC node]
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
where get_node (n, _, _) = n
......@@ -203,8 +272,8 @@ stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEd
-- the (some of) the result of SCC, so you dont want to lose the dependency info
stronglyConnCompFromEdgedVerticesR
:: Ord key
=> [(node, key, [key])]
-> [SCC (node, key, [key])]
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
\end{code}
......
......@@ -41,7 +41,7 @@ module Util (
nTimes,
-- * Sorting
sortLe, sortWith, on,
sortLe, sortWith, minWith, on,
-- * Comparisons
isEqual, eqListBy,
......@@ -543,6 +543,10 @@ sortWith get_key xs = sortLe le xs
where
x `le` y = get_key x < get_key y
minWith :: Ord b => (a -> b) -> [a] -> a
minWith get_key xs = ASSERT( not (null xs) )
head (sortWith get_key xs)
on :: (a -> a -> c) -> (b -> a) -> b -> b -> c
on cmp sel = \x y -> sel x `cmp` sel y
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment