From 7fbe8df701e72411e532ba86862caa92ef36ef1c Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 18 Feb 2014 16:30:02 +0200
Subject: [PATCH] Module name conflict detection

---
 .gitignore                     |  1 +
 Stackage/Build.hs              |  7 +++++
 Stackage/ModuleNameConflict.hs | 52 ++++++++++++++++++++++++++++++++++
 stackage.cabal                 |  1 +
 4 files changed, 61 insertions(+)
 create mode 100644 Stackage/ModuleNameConflict.hs

diff --git a/.gitignore b/.gitignore
index 7f0ef6f5..171539c9 100644
--- a/.gitignore
+++ b/.gitignore
@@ -15,3 +15,4 @@ cabal-dev
 /logs-tools/
 build-plan.txt
 hackage-map.txt
+module-name-conflicts.txt
diff --git a/Stackage/Build.hs b/Stackage/Build.hs
index 04d5c3f0..35944615 100644
--- a/Stackage/Build.hs
+++ b/Stackage/Build.hs
@@ -9,12 +9,14 @@ import           Prelude                    hiding (pi)
 import           Stackage.CheckCabalVersion (checkCabalVersion)
 import           Stackage.Config
 import           Stackage.InstallInfo
+import           Stackage.ModuleNameConflict
 import           Stackage.Types
 import           Stackage.Util
 import           System.Exit                (ExitCode (ExitSuccess), exitWith)
 import           System.IO                  (BufferMode (NoBuffering),
                                              IOMode (WriteMode), hPutStrLn,
                                              hSetBuffering, withBinaryFile)
+import qualified System.IO.UTF8
 import           System.Process             (rawSystem, runProcess,
                                              waitForProcess)
 
@@ -104,3 +106,8 @@ build settings' bp = do
     unless (ec == ExitSuccess) $ do
         putStrLn "Build failed, please see build.log"
         exitWith ec
+
+    putStrLn "Build completed successfully, checking for module name conflicts"
+    conflicts <- getModuleNameConflicts $ packageDir settings
+    System.IO.UTF8.writeFile "module-name-conflicts.txt"
+        $ renderModuleNameConflicts conflicts
diff --git a/Stackage/ModuleNameConflict.hs b/Stackage/ModuleNameConflict.hs
new file mode 100644
index 00000000..4b09ad3f
--- /dev/null
+++ b/Stackage/ModuleNameConflict.hs
@@ -0,0 +1,52 @@
+module Stackage.ModuleNameConflict
+    ( ModuleNameConflicts
+    , getModuleNameConflicts
+    , renderModuleNameConflicts
+    , parseModuleNameConflicts
+    ) where
+
+import Distribution.Simple.Configure (configCompiler, getInstalledPackages)
+import Distribution.Simple.Compiler (CompilerFlavor (GHC), PackageDB (GlobalPackageDB, SpecificPackageDB))
+import Distribution.Verbosity (normal)
+import Distribution.Simple.Program (defaultProgramConfiguration)
+import Distribution.Simple.PackageIndex (moduleNameIndex)
+import Distribution.InstalledPackageInfo (sourcePackageId)
+import Distribution.Package (PackageIdentifier (PackageIdentifier), PackageName (PackageName))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.List (intercalate)
+import Distribution.ModuleName (components)
+
+type ModuleNameConflicts = Map.Map (Set.Set String) (Set.Set String)
+
+getModuleNameConflicts :: FilePath -> IO ModuleNameConflicts
+getModuleNameConflicts path = do
+    (compiler, progConfig) <-
+        configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration normal
+    let stack =
+            [ GlobalPackageDB
+            , SpecificPackageDB path
+            ]
+    packageIndex <- getInstalledPackages normal compiler stack progConfig
+    let modMap = moduleNameIndex packageIndex
+        packageName (PackageIdentifier (PackageName x) _) = x
+        simpleMN = intercalate "." . components
+        overlaps = Map.unionsWith Set.union
+                 $ map (\(mn, pkgs) -> Map.singleton pkgs (Set.singleton $ simpleMN mn))
+                 $ Map.toList
+                 $ Map.filter (\x -> Set.size x > 1)
+                 $ Map.map Set.fromList
+                 $ fmap (map (packageName . sourcePackageId)) modMap
+    return overlaps
+
+renderModuleNameConflicts :: ModuleNameConflicts -> String
+renderModuleNameConflicts =
+    unlines . map (unwords . Set.toList) . concatMap (\(x, y) -> [x, y]) . Map.toList
+
+parseModuleNameConflicts :: String -> ModuleNameConflicts
+parseModuleNameConflicts =
+    Map.fromList . toPairs . map (Set.fromList . words) . lines
+  where
+    toPairs [] = []
+    toPairs [_] = []
+    toPairs (x:y:z) = (x, y) : toPairs z
diff --git a/stackage.cabal b/stackage.cabal
index ff8f44bf..7de4cfad 100644
--- a/stackage.cabal
+++ b/stackage.cabal
@@ -15,6 +15,7 @@ library
   exposed-modules:     Stackage.NarrowDatabase
                        Stackage.LoadDatabase
                        Stackage.HaskellPlatform
+                       Stackage.ModuleNameConflict
                        Stackage.Util
                        Stackage.Types
                        Stackage.Config