mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 07:18:31 +01:00
53 lines
2.1 KiB
Haskell
53 lines
2.1 KiB
Haskell
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
|