From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Mon, 13 Jun 2011 21:35:23 +0000 (+0100)
Subject: Improve the reporting of module cycles, to give a nice message like this
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=735519b465ba75a5d254848fb7f100bdaea89aa9

Improve the reporting of module cycles, to give a nice message like this

  Module imports form a cycle:
    module `Foo4' imports `Foo'
            which imports `Foo2'
            which imports `Foo3'
            which imports `Foo4'

as requested by Bryan Richter
---

diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index ab65894..5df0e13 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1456,20 +1456,53 @@ multiRootsErr summs@(summ1:_)
     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
 
 cyclicModuleErr :: [ModSummary] -> SDoc
+-- From a strongly connected component we find 
+-- a single cycle to report
 cyclicModuleErr ms
-  = hang (ptext (sLit "Module imports form a cycle for modules:"))
-       2 (vcat (map show_one ms))
+  = ASSERT( not (null ms) )
+    hang (ptext (sLit "Module imports form a cycle:"))
+       2 (show_path (shortest [] root_mod))
   where
-    mods_in_cycle = map ms_mod_name ms
-    imp_modname = unLoc . ideclName . unLoc
-    just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
-
-    show_one ms = 
-           vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
-                  maybe empty (parens . text) (ml_hs_file (ms_location ms)),
-                  nest 2 $ ptext (sLit "imports:") <+> vcat [
-                     pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
-                     pp_imps HsSrcFile  (just_in_cycle $ ms_imps ms) ]
-                ]
-    show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
-    pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
+    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
+
+    show_path []         = panic "show_path"
+    show_path [m]        = ptext (sLit "module") <+> quotes (ppr 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)
+       where
+         go []     =  [ptext (sLit "which imports") <+> quotes (ppr m1)]
+         go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms
+       
+minWith :: Ord b => (a -> b) -> [a] -> a
+minWith get_key xs = ASSERT( not (null xs) )
+                     head (sortWith get_key xs)