#include "HsVersions.h"
import PackageConfig
-import ParsePkgConf ( loadPackageConfig )
import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) )
import StaticFlags
import Config ( cProjectVersion )
import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
+import Distribution.InstalledPackageInfo.Binary
import Distribution.Package hiding (PackageId,depends)
import FastString
import ErrUtils ( debugTraceMsg, putMsg, Message )
type InstalledPackageIdMap = FiniteMap InstalledPackageId PackageId
+type InstalledPackageIndex = FiniteMap InstalledPackageId PackageConfig
+
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM
-- System one always comes first
let system_pkgconf = systemPackageConfig dflags
- -- allow package.conf.d to contain a bunch of .conf files
- -- containing package specifications. This is an easier way
- -- to maintain the package database on systems with a package
- -- management system, or systems that don't want to run ghc-pkg
- -- to register or unregister packages. Undocumented feature for now.
- let system_pkgconf_dir = system_pkgconf <.> "d"
- system_pkgconf_dir_exists <- doesDirectoryExist system_pkgconf_dir
- system_pkgconfs <-
- if system_pkgconf_dir_exists
- then do files <- getDirectoryContents system_pkgconf_dir
- return [ system_pkgconf_dir </> file
- | file <- files
- , takeExtension file == ".conf" ]
- else return []
-
-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
-- unless the -no-user-package-conf flag was given.
- -- We only do this when getAppUserDataDirectory is available
- -- (GHC >= 6.3).
user_pkgconf <- do
+ if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do
appdir <- getAppUserDataDirectory "ghc"
let
- pkgconf = appdir
- </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
- </> "package.conf"
- flg <- doesFileExist pkgconf
- if (flg && dopt Opt_ReadUserPackageConf dflags)
- then return [pkgconf]
- else return []
+ dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
+ pkgconf = dir </> "package.conf.d"
+ --
+ exist <- doesDirectoryExist pkgconf
+ if exist then return [pkgconf] else return []
`catchIO` (\_ -> return [])
- return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf])
-
+ return (user_pkgconf ++ [system_pkgconf])
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
- debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
- proto_pkg_configs <- loadPackageConfig dflags conf_file
+ isdir <- doesDirectoryExist conf_file
+
+ proto_pkg_configs <-
+ if isdir
+ then do let filename = conf_file </> "package.cache"
+ debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
+ conf <- readBinPackageDB filename
+ return (map installedPackageInfoToPackageConfig conf)
+
+ else do
+ isfile <- doesFileExist conf_file
+ when (not isfile) $
+ ghcError $ InstallationError $
+ "can't find a package database at " ++ conf_file
+ debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
+ str <- readFile conf_file
+ return (map installedPackageInfoToPackageConfig $ read str)
+
let
top_dir = topDir dflags
pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
where new_ipids = addListToFM ipids
[ (installedPackageId p, p) | p <- new_avail ]
- depsAvailable :: FiniteMap InstalledPackageId PackageConfig
+ depsAvailable :: InstalledPackageIndex
-> PackageConfig
-> Either PackageConfig (PackageConfig, [InstalledPackageId])
depsAvailable ipids pkg
-- Eliminate shadowed packages, giving the user some feedback
-- later packages in the list should shadow earlier ones with the same
--- package name/version.
-shadowPackages :: [PackageConfig] -> UnusablePackages
-shadowPackages pkgs
- = let (_,shadowed) = foldl check (emptyUFM,[]) pkgs
+-- package name/version. Additionally, a package may be preferred if
+-- it is in the transitive closure of packages selected using -package-id
+-- flags.
+shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
+shadowPackages pkgs preferred
+ = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
in listToFM shadowed
where
- check (pkgmap,shadowed) pkg
- = (addToUFM pkgmap (packageConfigId pkg) pkg, shadowed')
- where
- shadowed'
+ check (shadowed,pkgmap) pkg
| Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
- = (installedPackageId oldpkg, ShadowedBy (installedPackageId pkg))
- :shadowed
+ , 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
- = shadowed
+ = (shadowed, pkgmap')
+ where
+ pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
-- -----------------------------------------------------------------------------
doit _ = panic "ignorePackages"
-- -----------------------------------------------------------------------------
+
+depClosure :: InstalledPackageIndex
+ -> [InstalledPackageId]
+ -> [InstalledPackageId]
+depClosure index ipids = closure emptyFM ipids
+ where
+ closure set [] = keysFM set
+ closure set (ipid : ipids)
+ | ipid `elemFM` set = closure set ipids
+ | Just p <- lookupFM index ipid = closure (addToFM set ipid p)
+ (depends p ++ ipids)
+ | otherwise = closure set ipids
+
+-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.
mkPackageState dflags pkgs0 preload0 this_package = do
+{-
+ Plan.
+
+ 1. P = transitive closure of packages selected by -package-id
+
+ 2. Apply shadowing. When there are multiple packages with the same
+ sourcePackageId,
+ * if one is in P, use that one
+ * otherwise, use the one highest in the package stack
+ [
+ rationale: we cannot use two packages with the same sourcePackageId
+ in the same program, because sourcePackageId is the symbol prefix.
+ Hence we must select a consistent set of packages to use. We have
+ a default algorithm for doing this: packages higher in the stack
+ shadow those lower down. This default algorithm can be overriden
+ by giving explicit -package-id flags; then we have to take these
+ preferences into account when selecting which other packages are
+ made available.
+
+ Our simple algorithm throws away some solutions: there may be other
+ consistent sets that would satisfy the -package flags, but it's
+ not GHC's job to be doing constraint solving.
+ ]
+
+ 3. remove packages selected by -ignore-package
+
+ 4. remove any packages with missing dependencies, or mutually recursive
+ dependencies.
+
+ 5. report (with -v) any packages that were removed by steps 2-4
+
+ 6. apply flags to set exposed/hidden on the resulting packages
+ - if any flag refers to a package which was removed by 2-4, then
+ we can give an error message explaining why
+
+ 7. hide any packages which are superseded by later exposed packages
+-}
+
let
flags = reverse (packageFlags dflags)
+
+ ipid_map = listToFM [ (installedPackageId p, p) | p <- pkgs0 ]
+
+ -- pkgs0 with duplicate packages filtered out. This is
+ -- important: it is possible for a package in the user package
+ -- DB to have the same IPID as a package in the global DB, and
+ -- we want the former 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.
+ pkgs0_unique = eltsFM ipid_map
+
+ ipid_selected = depClosure ipid_map [ InstalledPackageId i
+ | ExposePackageId i <- flags ]
+
(ignore_flags, other_flags) = partition is_ignore flags
is_ignore IgnorePackage{} = True
is_ignore _ = False
- shadowed = shadowPackages pkgs0
- ignored = ignorePackages ignore_flags pkgs0
+ shadowed = shadowPackages pkgs0_unique ipid_selected
+
+ 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))
projects / ghc-hetmet.git / blobdiff