import Data.Maybe ( isNothing )
import System.Directory ( doesFileExist )
import Control.Monad ( foldM )
-import Data.List ( nub, partition )
+import Data.List ( nub, partition, sortBy )
#ifdef mingw32_TARGET_OS
import Data.List ( isPrefixOf )
#endif
+import Data.List ( isSuffixOf )
import FastString
import EXCEPTION ( throwDyn )
-- should be in reverse dependency order; that is, a package
-- is always mentioned before the packages it depends on.
+ origPkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig
+ -- the full package database
+
pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig
- -- mapping derived from the package databases and
- -- command-line package flags.
+ -- Derived from origPkgIdMap.
+ -- The exposed flags are adjusted according to -package and
+ -- -hide-package flags, and -ignore-package removes packages.
moduleToPkgConfAll :: ModuleEnv [(PackageConfig,Bool)],
+ -- Derived from pkgIdMap.
-- Maps Module to (pkgconf,exposed), where pkgconf is the
-- PackageConfig for the package containing the module, and
-- exposed is True if the package exposes that module.
procflags pkgs expl [] = return (pkgs,expl)
procflags pkgs expl (ExposePackage str : flags) = do
- case partition (matches str) pkgs of
- ([],_) -> missingPackageErr str
- ([p],ps) -> procflags (p':ps) (addOneToUniqSet expl pkgid) flags
+ case pick str pkgs of
+ Nothing -> missingPackageErr str
+ Just (p,ps) -> procflags (p':ps') expl' flags
where pkgid = packageConfigId p
p' = p {exposed=True}
- (ps,_) -> multiplePackagesErr str ps
+ ps' = hideAll (pkgName (package p)) ps
+ expl' = addOneToUniqSet expl pkgid
procflags pkgs expl (HidePackage str : flags) = do
case partition (matches str) pkgs of
([],_) -> missingPackageErr str
- ([p],ps) -> procflags (p':ps) expl flags
- where p' = p {exposed=False}
- (ps,_) -> multiplePackagesErr str ps
+ (ps,qs) -> procflags (map hide ps ++ qs) expl flags
+ where hide p = p {exposed=False}
procflags pkgs expl (IgnorePackage str : flags) = do
case partition (matches str) pkgs of
(ps,qs) -> procflags qs expl flags
-- because a common usage is to -ignore-package P as
-- a preventative measure just in case P exists.
+ pick str pkgs
+ = case partition (matches str) pkgs of
+ ([],_) -> Nothing
+ (ps,rest) ->
+ case sortBy (flip (comparing (pkgVersion.package))) ps of
+ (p:ps) -> Just (p, ps ++ rest)
+ _ -> panic "Packages.pick"
+
+ comparing f a b = f a `compare` f b
+
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
matches str p
= str == showPackageId (package p)
|| str == pkgName (package p)
+
+ -- When a package is requested to be exposed, we hide all other
+ -- packages with the same name.
+ hideAll name ps = map maybe_hide ps
+ where maybe_hide p | pkgName (package p) == name = p {exposed=False}
+ | otherwise = p
--
(pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) emptyUniqSet flags
--
+ -- hide all packages for which there is also a later version
+ -- that is already exposed. This just makes it non-fatal to have two
+ -- versions of a package exposed, which can happen if you install a
+ -- later version of a package in the user database, for example.
+ --
+ let
+ pkgs2 = map maybe_hide pkgs1
+ where maybe_hide p
+ | a_later_version_is_exposed = p {exposed=False}
+ | otherwise = p
+ where myname = pkgName (package p)
+ myversion = pkgVersion (package p)
+ a_later_version_is_exposed
+ = not (null [ p | p <- pkgs1, exposed p,
+ let pkg = package p,
+ pkgName pkg == myname,
+ pkgVersion pkg > myversion ])
+ --
+ -- Eliminate any packages which have dangling dependencies (perhaps
+ -- because the package was removed by -ignore-package).
+ --
let
elimDanglingDeps pkgs =
case partition (hasDanglingDeps pkgs) pkgs of
where dangling pid = pid `notElem` all_pids
all_pids = map package pkgs
--
- -- Eliminate any packages which have dangling dependencies (perhaps
- -- because the package was removed by -ignore-package).
- --
- let pkgs = elimDanglingDeps pkgs1
+ let pkgs = elimDanglingDeps pkgs2
pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
--
-- Find the transitive closure of dependencies of exposed
-- Discover any conflicts at the same time, and factor in the new exposed
-- status of each package.
--
- let mod_map = mkModuleMap orig_pkg_db dep_exposed
+ let mod_map = mkModuleMap pkg_db dep_exposed
return PackageState{ explicitPackages = dep_explicit,
- pkgIdMap = orig_pkg_db,
+ origPkgIdMap = orig_pkg_db,
+ pkgIdMap = pkg_db,
moduleToPkgConfAll = mod_map,
basePackageId = basePackageId,
rtsPackageId = rtsPackageId,
thPackageName = FSLIT("template-haskell")
-- Template Haskell libraries in here
-multiplePackagesErr str ps =
- throwDyn (CmdLineError (showSDoc (
- text "Error; multiple packages match" <+>
- text str <> colon <+>
- sep (punctuate comma (map (text.showPackageId.package) ps))
- )))
-
mkModuleMap
:: PackageConfigMap
-> [PackageId]
rts_tag = rtsBuildTag dflags
let
imp = if opt_Static then "" else "_dyn"
- libs p = map ((++imp) . addSuffix) (hACK (hsLibraries p)) ++ extraLibraries p
+ libs p = map ((++imp) . addSuffix) (hACK (hsLibraries p))
+ ++ hACK_dyn (extraLibraries p)
all_opts p = map ("-l" ++) (libs p) ++ ldOptions p
suffix = if null tag then "" else '_':tag
addSuffix rts@"HSrts" = rts ++ rts_suffix
addSuffix other_lib = other_lib ++ suffix
+ -- This is a hack that's even more horrible (and hopefully more temporary)
+ -- than the one below. HSbase_cbits and friends require the _dyn suffix
+ -- for dynamic linking, but not _p or other 'way' suffix. So we just add
+ -- _dyn to extraLibraries if they already have a _cbits suffix.
+
+ hACK_dyn = map hack
+ where hack lib | not opt_Static && "_cbits" `isSuffixOf` lib = lib ++ "_dyn"
+ | otherwise = lib
+
return (concat (map all_opts ps))
where
libs
# endif
+
getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
ps <- getExplicitPackagesAnd dflags pkgs
| p `elem` ps = return ps -- Check if we've already added this package
| otherwise =
case lookupPackage pkg_db p of
- Nothing -> Failed (missingPackageErr (packageIdString p))
+ Nothing -> Failed (missingPackageMsg (packageIdString p))
Just pkg -> do
-- Add the package's dependents also
let deps = map mkPackageId (depends pkg)
return (p : ps')
missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
-missingPackageMsg p = ptext SLIT("unknown package:") <> text p
+missingPackageMsg p = ptext SLIT("unknown package:") <+> text p
-- -----------------------------------------------------------------------------
-- The home module set
projects / ghc-hetmet.git / blobdiff