[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).

1 files changed, 34 insertions, 8 deletions

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