[commit: ghc] wip/cabal-head-updates: Add extra ghc-pkg sanity check for module re-exports and duplicates (687b8b0)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/cabal-head-updates
Link       : http://ghc.haskell.org/trac/ghc/changeset/687b8b0d09424d5a1918d36f01f55805b1834411/ghc

>---------------------------------------------------------------

commit 687b8b0d09424d5a1918d36f01f55805b1834411
Author: Duncan Coutts <duncan at well-typed.com>
Date:   Fri Aug 29 14:00:57 2014 +0100

    Add extra ghc-pkg sanity check for module re-exports and duplicates
    
    For re-exports, check that the defining package exists and that it
    exposes the defining module (or for self-rexport exposed or hidden
    modules). Also check that the defining package is actually a direct
    or indirect dependency of the package doing the re-exporting.
    
    Also add a check for duplicate modules in a package, including
    re-exported modules.


>---------------------------------------------------------------

687b8b0d09424d5a1918d36f01f55805b1834411
 utils/ghc-pkg/Main.hs | 66 +++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 62 insertions(+), 4 deletions(-)

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 4d4f8e9..f2419c7 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -14,6 +14,7 @@ module Main (main) where
 import Version ( version, targetOS, targetARCH )
 import qualified GHC.PackageDb as GhcPkg
 import qualified Distribution.Simple.PackageIndex as PackageIndex
+import qualified Data.Graph as Graph
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.ModuleName (ModuleName)
 import Distribution.InstalledPackageInfo as Cabal
@@ -1519,7 +1520,9 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs
   mapM_ (checkDir True  "framework-dirs") (frameworkDirs pkg)
   mapM_ (checkFile   True "haddock-interfaces") (haddockInterfaces pkg)
   mapM_ (checkDirURL True "haddock-html")       (haddockHTMLs pkg)
-  checkModules pkg
+  checkDuplicateModules pkg
+  checkModuleFiles pkg
+  checkModuleReexports db_stack pkg
   mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
   -- ToDo: check these somehow?
   --    extra_libraries :: [String],
@@ -1653,9 +1656,8 @@ doesFileExistOnPath filenames paths = go fullFilenames
         go ((p, fp) : xs) = do b <- doesFileExist fp
                                if b then return (Just p) else go xs
 
--- XXX maybe should check reexportedModules too
-checkModules :: InstalledPackageInfo -> Validate ()
-checkModules pkg = do
+checkModuleFiles :: InstalledPackageInfo -> Validate ()
+checkModuleFiles pkg = do
   mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
   where
     findModule modl =
@@ -1667,6 +1669,62 @@ checkModules pkg = do
       when (isNothing m) $
          verror ForceFiles ("cannot find any of " ++ show files)
 
+checkDuplicateModules :: InstalledPackageInfo -> Validate ()
+checkDuplicateModules pkg
+  | null dups = return ()
+  | otherwise = verror ForceAll ("package has duplicate modules: " ++
+                                     unwords (map display dups))
+  where
+    dups = [ m | (m:_:_) <- group (sort mods) ]
+    mods = exposedModules pkg ++ hiddenModules pkg
+        ++ map moduleReexportName (reexportedModules pkg)
+
+checkModuleReexports :: PackageDBStack -> InstalledPackageInfo -> Validate ()
+checkModuleReexports db_stack pkg =
+    mapM_ checkReexport (reexportedModules pkg)
+  where
+    all_pkgs = allPackagesInStack db_stack
+    ipix     = PackageIndex.fromList all_pkgs
+
+    checkReexport ModuleReexport {
+      moduleReexportDefiningPackage = definingPkgId,
+      moduleReexportDefiningName    = definingModule
+    } = case PackageIndex.lookupInstalledPackageId ipix definingPkgId of
+          Nothing
+           -> verror ForceAll ("module re-export refers to a non-existant " ++
+                               "(or not visible) defining package: " ++
+                                       display definingPkgId)
+
+          Just definingPkg
+            | not (isIndirectDependency definingPkgId)
+           -> verror ForceAll ("module re-export refers to a defining  " ++
+                               "package that is not a direct (or indirect) " ++
+                               "dependency of this package: " ++
+                                       display definingPkgId)
+
+            | definingPkgId == installedPackageId pkg
+              && definingModule `notElem` (exposedModules definingPkg
+                                        ++ hiddenModules definingPkg)
+           -> verror ForceAll ("module (self) re-export refers to a module " ++
+                               "that is not defined in this package " ++
+                                       display definingModule)
+
+            | definingPkgId /= installedPackageId pkg
+              && definingModule `notElem` exposedModules definingPkg
+           -> verror ForceAll ("module re-export refers to a module that is " ++
+                               "not exposed by the defining package " ++
+                                       display definingModule)
+
+            | otherwise
+           -> return ()
+    
+    isIndirectDependency pkgid = fromMaybe False $ do
+      thispkg  <- graphVertex (installedPackageId pkg)
+      otherpkg <- graphVertex pkgid
+      return (Graph.path depgraph thispkg otherpkg)
+    (depgraph, _, graphVertex) = PackageIndex.dependencyGraph ipix
+
+
 checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
 checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
   | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file