@@ -0,0 +1,52 @@
1+module Stackage.ModuleNameConflict
2+ ( ModuleNameConflicts
3+ , getModuleNameConflicts
4+ , renderModuleNameConflicts
5+ , parseModuleNameConflicts
6+ ) where
7+
8+import Distribution.Simple.Configure (configCompiler, getInstalledPackages)
9+import Distribution.Simple.Compiler (CompilerFlavor (GHC), PackageDB (GlobalPackageDB, SpecificPackageDB))
10+import Distribution.Verbosity (normal)
11+import Distribution.Simple.Program (defaultProgramConfiguration)
12+import Distribution.Simple.PackageIndex (moduleNameIndex)
13+import Distribution.InstalledPackageInfo (sourcePackageId)
14+import Distribution.Package (PackageIdentifier (PackageIdentifier), PackageName (PackageName))
15+import qualified Data.Map as Map
16+import qualified Data.Set as Set
17+import Data.List (intercalate)
18+import Distribution.ModuleName (components)
19+
20+type ModuleNameConflicts = Map.Map (Set.Set String) (Set.Set String)
21+
22+getModuleNameConflicts :: FilePath -> IO ModuleNameConflicts
23+getModuleNameConflicts path = do
24+ (compiler, progConfig) <-
25+ configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration normal
26+ let stack =
27+ [ GlobalPackageDB
28+ , SpecificPackageDB path
29+ ]
30+ packageIndex <- getInstalledPackages normal compiler stack progConfig
31+ let modMap = moduleNameIndex packageIndex
32+ packageName (PackageIdentifier (PackageName x) _) = x
33+ simpleMN = intercalate "." . components
34+ overlaps = Map.unionsWith Set.union
35+ $ map (\(mn, pkgs) -> Map.singleton pkgs (Set.singleton $ simpleMN mn))
36+ $ Map.toList
37+ $ Map.filter (\x -> Set.size x > 1)
38+ $ Map.map Set.fromList
39+ $ fmap (map (packageName . sourcePackageId)) modMap
40+ return overlaps
41+
42+renderModuleNameConflicts :: ModuleNameConflicts -> String
43+renderModuleNameConflicts =
44+ unlines . map (unwords . Set.toList) . concatMap (\(x, y) -> [x, y]) . Map.toList
45+
46+parseModuleNameConflicts :: String -> ModuleNameConflicts
47+parseModuleNameConflicts =
48+ Map.fromList . toPairs . map (Set.fromList . words) . lines
49+ where
50+ toPairs [] = []
51+ toPairs [_] = []
52+ toPairs (x:y:z) = (x, y) : toPairs z