[haddock @ 2002-05-09 10:37:07 by simonmar]

The last commit to Main.lhs broke the delicate balance of laziness
which was being used to avoid computing the dependency graph of
modules.

So I finally bit the bullet and did a proper topological sort of the
module graph, which turned out to be easy (stealing the Digraph module
from GHC - this really ought to be in the libraries somewhere).

2 files changed, 431 insertions, 8 deletions

diff --git a/src/Digraph.lhs b/src/Digraph.lhs
new file mode 100644
index 00000000..cc97a4a6
--- /dev/null
+++ b/src/Digraph.lhs
@@ -0,0 +1,397 @@
+--
+-- Taken from ghc/compiler/utils/Digraph.lhs v1.15
+-- (c) The University of Glasgow, 2002
+--
+
+\begin{code}
+{-# OPTIONS -cpp #-}
+module Digraph(
+
+	-- At present the only one with a "nice" external interface
+	stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
+
+	Graph, Vertex, 
+	graphFromEdges, buildG, transposeG, reverseE, outdegree, indegree,
+
+	Tree(..), Forest,
+	showTree, showForest,
+
+	dfs, dff,
+	topSort,
+	components,
+	scc,
+	back, cross, forward,
+	reachable, path,
+	bcc
+
+    ) where
+
+------------------------------------------------------------------------------
+-- A version of the graph algorithms described in:
+-- 
+-- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
+--   by David King and John Launchbury
+-- 
+-- Also included is some additional code for printing tree structures ...
+------------------------------------------------------------------------------
+
+
+#define ARR_ELT		(COMMA)
+
+-- Extensions
+import ST
+
+-- std interfaces
+import Maybe
+import Array
+import List
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*	External interface
+%*									*
+%************************************************************************
+
+\begin{code}
+data SCC vertex = AcyclicSCC vertex
+	        | CyclicSCC  [vertex]
+
+flattenSCCs :: [SCC a] -> [a]
+flattenSCCs = concatMap flattenSCC
+
+flattenSCC (AcyclicSCC v) = [v]
+flattenSCC (CyclicSCC vs) = vs
+\end{code}
+
+\begin{code}
+stronglyConnComp
+	:: Ord key
+	=> [(node, key, [key])]		-- The graph; its ok for the
+					-- out-list to contain keys which arent
+					-- a vertex key, they are ignored
+	-> [SCC node]
+
+stronglyConnComp edges
+  = map get_node (stronglyConnCompR edges)
+  where
+    get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
+    get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]
+
+-- The "R" interface is used when you expect to apply SCC to
+-- the (some of) the result of SCC, so you dont want to lose the dependency info
+stronglyConnCompR
+	:: Ord key
+	=> [(node, key, [key])]		-- The graph; its ok for the
+					-- out-list to contain keys which arent
+					-- a vertex key, they are ignored
+	-> [SCC (node, key, [key])]
+
+stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF
+stronglyConnCompR edges
+  = map decode forest
+  where
+    (graph, vertex_fn) = graphFromEdges edges
+    forest	       = scc graph
+    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
+		       | otherwise	   = AcyclicSCC (vertex_fn v)
+    decode other = CyclicSCC (dec other [])
+		 where
+		   dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
+    mentions_itself v = v `elem` (graph ! v)
+\end{code}
+
+%************************************************************************
+%*									*
+%*	Graphs
+%*									*
+%************************************************************************
+
+
+\begin{code}
+type Vertex  = Int
+type Table a = Array Vertex a
+type Graph   = Table [Vertex]
+type Bounds  = (Vertex, Vertex)
+type Edge    = (Vertex, Vertex)
+\end{code}
+
+\begin{code}
+vertices :: Graph -> [Vertex]
+vertices  = indices
+
+edges    :: Graph -> [Edge]
+edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
+
+mapT    :: (Vertex -> a -> b) -> Table a -> Table b
+mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
+
+buildG :: Bounds -> [Edge] -> Graph
+buildG bounds edges = accumArray (flip (:)) [] bounds edges
+
+transposeG  :: Graph -> Graph
+transposeG g = buildG (bounds g) (reverseE g)
+
+reverseE    :: Graph -> [Edge]
+reverseE g   = [ (w, v) | (v, w) <- edges g ]
+
+outdegree :: Graph -> Table Int
+outdegree  = mapT numEdges
+             where numEdges v ws = length ws
+
+indegree :: Graph -> Table Int
+indegree  = outdegree . transposeG
+\end{code}
+
+
+\begin{code}
+graphFromEdges
+	:: Ord key
+	=> [(node, key, [key])]
+	-> (Graph, Vertex -> (node, key, [key]))
+graphFromEdges edges
+  = (graph, \v -> vertex_map ! v)
+  where
+    max_v      	    = length edges - 1
+    bounds          = (0,max_v) :: (Vertex, Vertex)
+    sorted_edges    = sortBy lt edges
+    edges1	    = zipWith (,) [0..] sorted_edges
+
+    graph	    = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_,    _, ks) <- edges1]
+    key_map	    = array bounds [(,) v k			   | (,) v (_,    k, _ ) <- edges1]
+    vertex_map	    = array bounds edges1
+
+    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
+
+    -- key_vertex :: key -> Maybe Vertex
+    -- 	returns Nothing for non-interesting vertices
+    key_vertex k   = find 0 max_v 
+		   where
+		     find a b | a > b 
+			      = Nothing
+		     find a b = case compare k (key_map ! mid) of
+				   LT -> find a (mid-1)
+				   EQ -> Just mid
+				   GT -> find (mid+1) b
+			      where
+			 	mid = (a + b) `div` 2
+\end{code}
+
+%************************************************************************
+%*									*
+%*	Trees and forests
+%*									*
+%************************************************************************
+
+\begin{code}
+data Tree a   = Node a (Forest a)
+type Forest a = [Tree a]
+
+mapTree              :: (a -> b) -> (Tree a -> Tree b)
+mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
+\end{code}
+
+\begin{code}
+instance Show a => Show (Tree a) where
+  showsPrec p t s = showTree t ++ s
+
+showTree :: Show a => Tree a -> String
+showTree  = drawTree . mapTree show
+
+showForest :: Show a => Forest a -> String
+showForest  = unlines . map showTree
+
+drawTree        :: Tree String -> String
+drawTree         = unlines . draw
+
+draw (Node x ts) = grp this (space (length this)) (stLoop ts)
+ where this          = s1 ++ x ++ " "
+
+       space n       = replicate n ' '
+
+       stLoop []     = [""]
+       stLoop [t]    = grp s2 "  " (draw t)
+       stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
+
+       rsLoop [t]    = grp s5 "  " (draw t)
+       rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
+
+       grp fst rst   = zipWith (++) (fst:repeat rst)
+
+       [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*	Depth first search
+%*									*
+%************************************************************************
+
+\begin{code}
+type Set s    = STArray s Vertex Bool
+
+mkEmpty      :: Bounds -> ST s (Set s)
+mkEmpty bnds  = newSTArray bnds False
+
+contains     :: Set s -> Vertex -> ST s Bool
+contains m v  = readSTArray m v
+
+include      :: Set s -> Vertex -> ST s ()
+include m v   = writeSTArray m v True
+\end{code}
+
+\begin{code}
+dff          :: Graph -> Forest Vertex
+dff g         = dfs g (vertices g)
+
+dfs          :: Graph -> [Vertex] -> Forest Vertex
+dfs g vs      = prune (bounds g) (map (generate g) vs)
+
+generate     :: Graph -> Vertex -> Tree Vertex
+generate g v  = Node v (map (generate g) (g!v))
+
+prune        :: Bounds -> Forest Vertex -> Forest Vertex
+prune bnds ts = runST (mkEmpty bnds  >>= \m ->
+                       chop m ts)
+
+chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
+chop m []     = return []
+chop m (Node v ts : us)
+              = contains m v >>= \visited ->
+                if visited then
+                  chop m us
+                else
+                  include m v >>= \_  ->
+                  chop m ts   >>= \as ->
+                  chop m us   >>= \bs ->
+                  return (Node v as : bs)
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*	Algorithms
+%*									*
+%************************************************************************
+
+------------------------------------------------------------
+-- Algorithm 1: depth first search numbering
+------------------------------------------------------------
+
+\begin{code}
+--preorder            :: Tree a -> [a]
+preorder (Node a ts) = a : preorderF ts
+
+preorderF           :: Forest a -> [a]
+preorderF ts         = concat (map preorder ts)
+
+tabulate        :: Bounds -> [Vertex] -> Table Int
+tabulate bnds vs = array bnds (zipWith (,) vs [1..])
+
+preArr          :: Bounds -> Forest Vertex -> Table Int
+preArr bnds      = tabulate bnds . preorderF
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 2: topological sorting
+------------------------------------------------------------
+
+\begin{code}
+--postorder :: Tree a -> [a]
+postorder (Node a ts) = postorderF ts ++ [a]
+
+postorderF   :: Forest a -> [a]
+postorderF ts = concat (map postorder ts)
+
+postOrd      :: Graph -> [Vertex]
+postOrd       = postorderF . dff
+
+topSort      :: Graph -> [Vertex]
+topSort       = reverse . postOrd
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 3: connected components
+------------------------------------------------------------
+
+\begin{code}
+components   :: Graph -> Forest Vertex
+components    = dff . undirected
+
+undirected   :: Graph -> Graph
+undirected g  = buildG (bounds g) (edges g ++ reverseE g)
+\end{code}
+
+
+-- Algorithm 4: strongly connected components
+
+\begin{code}
+scc  :: Graph -> Forest Vertex
+scc g = dfs g (reverse (postOrd (transposeG g)))
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 5: Classifying edges
+------------------------------------------------------------
+
+\begin{code}
+back              :: Graph -> Table Int -> Graph
+back g post        = mapT select g
+ where select v ws = [ w | w <- ws, post!v < post!w ]
+
+cross             :: Graph -> Table Int -> Table Int -> Graph
+cross g pre post   = mapT select g
+ where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
+
+forward           :: Graph -> Graph -> Table Int -> Graph
+forward g tree pre = mapT select g
+ where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 6: Finding reachable vertices
+------------------------------------------------------------
+
+\begin{code}
+reachable    :: Graph -> Vertex -> [Vertex]
+reachable g v = preorderF (dfs g [v])
+
+path         :: Graph -> Vertex -> Vertex -> Bool
+path g v w    = w `elem` (reachable g v)
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 7: Biconnected components
+------------------------------------------------------------
+
+\begin{code}
+bcc :: Graph -> Forest [Vertex]
+bcc g = (concat . map bicomps . map (do_label g dnum)) forest
+ where forest = dff g
+       dnum   = preArr (bounds g) forest
+
+do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
+do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
+ where us = map (do_label g dnum) ts
+       lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
+                     ++ [lu | Node (u,du,lu) xs <- us])
+
+bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
+bicomps (Node (v,dv,lv) ts)
+      = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
+
+collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
+collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
+ where collected = map collect ts
+       vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
+       cs = concat [ if lw<dv then us else [Node (v:ws) us]
+                        | (lw, Node ws us) <- collected ]
+\end{code}
+
diff --git a/src/Main.hs b/src/Main.hs
index f868210f..1c377947 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -13,6 +13,7 @@ import HaddockDB
 import HaddockHtml
 import HaddockTypes
 import HaddockUtil
+import Digraph
 
 import HsLexer hiding (Token)
 import HsParser
@@ -109,15 +110,21 @@ run flags files = do
   writeIORef saved_flags flags
   parsed_mods <- sequence (map parse_file files)
 
-  let ifaces = [ runWriter (mkInterface module_map file parsed)
-	       | (file,parsed) <- zip files parsed_mods ]
+  sorted_mods <- sortModules parsed_mods
+	-- emits an error message if there are recursive modules
 
-      mod_ifaces = [ (m,i) | ((m,i),msgs) <- ifaces ]
-      all_msgs = concat (map snd ifaces)
-	
-      module_map = listToFM mod_ifaces
+  -- process the modules in sorted order, building up a mapping from
+  -- modules to interfaces.
+  let 
+	loop ifaces [] _ = return ifaces
+	loop ifaces (hsmod:hsmods) (file:files) = do 
+	   let ((mod,iface),msgs) = runWriter (mkInterface ifaces file hsmod)
+	       new_ifaces = addToFM ifaces mod iface
+	   mapM (hPutStrLn stderr) msgs
+	   loop new_ifaces hsmods files    
 
-  mapM (hPutStrLn stderr) all_msgs
+  module_map <- loop emptyFM sorted_mods files
+  let mod_ifaces = fmToList module_map
 
   when (Flag_DocBook `elem` flags) $
     putStr (ppDocBook odir mod_ifaces)
@@ -256,7 +263,7 @@ mkInterface mod_map filename
       name_strings = nub (map show missing_names ++ missing_names_doc)
 
   when (not (null name_strings)) $
-	  tell ["Warning: in module " ++ (case mod of Module m -> m) ++ 
+	  tell ["Warning: in module " ++ show mod ++ 
 		", the following names could not be resolved:\n\ 
 		\   " ++ concat (map (' ':) name_strings)
 		]
@@ -680,6 +687,25 @@ parseOption "ignore-exports" = return (Just OptIgnoreExports)
 parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing
 
 -- -----------------------------------------------------------------------------
+-- Topologically sort the modules
+
+sortModules :: [HsModule] -> IO [HsModule]
+sortModules hsmodules = mapM for_each_scc sccs
+  where
+	sccs = stronglyConnComp edges
+
+	edges :: [(HsModule, Module, [Module])]
+	edges = [ (hsmod, mod, [ imp | HsImportDecl _ imp _ _ _ <- impdecls ]) 
+		| hsmod@(HsModule mod _ impdecls _ _ _) <- hsmodules
+		]
+
+	for_each_scc (AcyclicSCC hsmodule) = return hsmodule
+	for_each_scc (CyclicSCC  hsmodules) = 
+	   dieMsg ("modules are recursive: " ++ 
+		   unwords (map show [ mod | HsModule mod _ _ _ _ _ 
+						<- hsmodules ]))
+
+-- -----------------------------------------------------------------------------
 -- A monad which collects error messages
 
 type ErrMsg = String