import System.FilePath
import Control.Monad
import Data.List as List
+import qualified Data.Set as Set
-- ---------------------------------------------------------------------------
-- The Package state
-- the we tack on the system paths.
pkgs <- mapM (readPackageConfig dflags)
- (reverse pkgconfs ++ reverse (extraPkgConfs dflags))
+ (pkgconfs ++ reverse (extraPkgConfs dflags))
-- later packages shadow earlier ones. extraPkgConfs
-- is in the opposite order to the flags on the
-- command line.
if exist then return [pkgconf] else return []
`catchIO` (\_ -> return [])
- return (user_pkgconf ++ [system_pkgconf])
+ return (system_pkgconf : user_pkgconf)
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
where
check (shadowed,pkgmap) pkg
| Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
- = let
- ipid_new = installedPackageId pkg
- ipid_old = installedPackageId oldpkg
- in
- if ipid_old `elem` preferred
+ , let
+ ipid_new = installedPackageId pkg
+ ipid_old = installedPackageId oldpkg
+ --
+ , ipid_old /= ipid_new
+ = if ipid_old `elem` preferred
then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
| otherwise
let
flags = reverse (packageFlags dflags)
+ -- pkgs0 with duplicate packages filtered out. This is
+ -- important: it is possible for a package in the global package
+ -- DB to have the same IPID as a package in the user DB, and
+ -- we want the latter to take precedence. This is not the same
+ -- as shadowing (below), since in this case the two packages
+ -- have the same ABI and are interchangeable.
+ --
+ -- #4072: note that we must retain the ordering of the list here
+ -- so that shadowing behaves as expected when we apply it later.
+ pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
+ where del p (s,ps)
+ | pid `Set.member` s = (s,ps)
+ | otherwise = (Set.insert pid s, p:ps)
+ where pid = installedPackageId p
+ -- XXX this is just a variant of nub
+
ipid_map = listToFM [ (installedPackageId p, p) | p <- pkgs0 ]
ipid_selected = depClosure ipid_map [ InstalledPackageId i
is_ignore IgnorePackage{} = True
is_ignore _ = False
- shadowed = shadowPackages pkgs0 ipid_selected
+ shadowed = shadowPackages pkgs0_unique ipid_selected
- ignored = ignorePackages ignore_flags pkgs0
+ ignored = ignorePackages ignore_flags pkgs0_unique
- pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0
+ pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0_unique
broken = findBroken pkgs0'
unusable = shadowed `plusFM` ignored `plusFM` broken
-- Modify the package database according to the command-line flags
-- (-package, -hide-package, -ignore-package, -hide-all-packages).
--
- pkgs1 <- foldM (applyPackageFlag unusable) pkgs0 other_flags
+ pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
let pkgs2 = filter (not . (`elemFM` unusable) . installedPackageId) pkgs1
-- Here we build up a set of the packages mentioned in -package
packageHsLibs :: DynFlags -> PackageConfig -> [String]
packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
where
- non_dyn_ways = filter ((/= WayDyn) . wayName) (ways dflags)
+ ways0 = ways dflags
+
+ ways1 = filter ((/= WayDyn) . wayName) ways0
-- the name of a shared library is libHSfoo-ghc<version>.so
-- we leave out the _dyn, because it is superfluous
- tag = mkBuildTag (filter (not . wayRTSOnly) non_dyn_ways)
- rts_tag = mkBuildTag non_dyn_ways
+ -- debug RTS includes support for -eventlog
+ ways2 | WayDebug `elem` map wayName ways1
+ = filter ((/= WayEventLog) . wayName) ways1
+ | otherwise
+ = ways1
+
+ tag = mkBuildTag (filter (not . wayRTSOnly) ways2)
+ rts_tag = mkBuildTag ways2
mkDynName | opt_Static = id
| otherwise = (++ ("-ghc" ++ cProjectVersion))