-- * Reading the package config, and processing cmdline args
PackageIdH(..), isHomePackage,
- PackageState(..),
+ PackageState(..),
+ mkPackageState,
initPackages,
getPackageDetails,
checkForPackageConflicts,
import Compat.Directory ( getAppUserDataDirectory )
#endif
+import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
-import Data.Maybe ( isNothing )
-import System.Directory ( doesFileExist )
+import System.Directory ( doesFileExist, doesDirectoryExist,
+ getDirectoryContents )
import Control.Monad ( foldM )
-import Data.List ( nub, partition )
-
-#ifdef mingw32_TARGET_OS
-import Data.List ( isPrefixOf )
-#endif
-
+import Data.List ( nub, partition, sortBy, isSuffixOf )
import FastString
import EXCEPTION ( throwDyn )
import ErrUtils ( debugTraceMsg, putMsg, Message )
readPackageConfigs :: DynFlags -> IO PackageConfigMap
readPackageConfigs dflags = do
+ e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
+ system_pkgconfs <- getSystemPackageConfigs dflags
+
+ let pkgconfs = case e_pkg_path of
+ Left _ -> system_pkgconfs
+ Right path
+ | last cs == "" -> init cs ++ system_pkgconfs
+ | otherwise -> cs
+ where cs = parseSearchPath path
+ -- if the path ends in a separator (eg. "/foo/bar:")
+ -- the we tack on the system paths.
+
+ -- Read all the ones mentioned in -package-conf flags
+ pkg_map <- foldM (readPackageConfig dflags) emptyPackageConfigMap
+ (reverse pkgconfs ++ extraPkgConfs dflags)
+
+ return pkg_map
+
+
+getSystemPackageConfigs :: DynFlags -> IO [FilePath]
+getSystemPackageConfigs dflags = do
-- System one always comes first
system_pkgconf <- getPackageConfigPath
- pkg_map1 <- readPackageConfig dflags emptyPackageConfigMap system_pkgconf
+
+ -- 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
+ , isSuffixOf ".conf" file]
+ 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).
- (exists, pkgconf) <- catch (do
+ user_pkgconf <- handle (\_ -> return []) $ do
appdir <- getAppUserDataDirectory "ghc"
let
pkgconf = appdir
`joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
`joinFileName` "package.conf"
flg <- doesFileExist pkgconf
- return (flg, pkgconf))
- -- gobble them all up and turn into False.
- (\ _ -> return (False, ""))
- pkg_map2 <- if (dopt Opt_ReadUserPackageConf dflags && exists)
- then readPackageConfig dflags pkg_map1 pkgconf
- else return pkg_map1
-
- -- Read all the ones mentioned in -package-conf flags
- pkg_map <- foldM (readPackageConfig dflags) pkg_map2
- (extraPkgConfs dflags)
+ if (flg && dopt Opt_ReadUserPackageConf dflags)
+ then return [pkgconf]
+ else return []
- return pkg_map
+ return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf])
readPackageConfig
:: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
readPackageConfig dflags pkg_map conf_file = do
- debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file)
+ debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir
let pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
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 maybe_hide p
+ | not (exposed p) = return p
+ | (p' : _) <- later_versions = do
+ debugTraceMsg dflags 2 $
+ (ptext SLIT("hiding package") <+> text (showPackageId (package p)) <+>
+ ptext SLIT("to avoid conflict with later version") <+>
+ text (showPackageId (package p')))
+ return (p {exposed=False})
+ | otherwise = return p
+ where myname = pkgName (package p)
+ myversion = pkgVersion (package p)
+ later_versions = [ p | p <- pkgs1, exposed p,
+ let pkg = package p,
+ pkgName pkg == myname,
+ pkgVersion pkg > myversion ]
+ a_later_version_is_exposed
+ = not (null later_versions)
+
+ pkgs2 <- mapM maybe_hide pkgs1
+ --
+ -- 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
- ([],ps) -> ps
- (ps,qs) -> elimDanglingDeps qs
-
- hasDanglingDeps pkgs p = any dangling (depends p)
+ case partition (not.null.snd) (map (getDanglingDeps pkgs) pkgs) of
+ ([],ps) -> return (map fst ps)
+ (ps,qs) -> do
+ mapM_ reportElim ps
+ elimDanglingDeps (map fst qs)
+
+ reportElim (p, deps) =
+ debugTraceMsg dflags 2 $
+ (ptext SLIT("package") <+> pprPkg p <+>
+ ptext SLIT("will be ignored due to missing dependencies:") $$
+ nest 2 (hsep (map (text.showPackageId) deps)))
+
+ getDanglingDeps pkgs p = (p, filter dangling (depends p))
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
- pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
+ pkgs <- elimDanglingDeps pkgs2
+ let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
--
-- Find the transitive closure of dependencies of exposed
--
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]
msg (mod,pkgs) =
text "conflict: module" <+> quotes (ppr mod)
<+> ptext SLIT("is present in multiple packages:")
- <+> hsep (punctuate comma (map (text.showPackageId.package) pkgs))
+ <+> hsep (punctuate comma (map pprPkg pkgs))
modOverlapError overlaps = vcat (map msg overlaps)
where
quotes (ppr mod),
ptext SLIT("belongs to the current program/library"),
ptext SLIT("and also to package"),
- text (showPackageId (package pkg)) ]
+ pprPkg pkg ]
+
+pprPkg :: PackageConfig -> SDoc
+pprPkg p = text (showPackageId (package p))
-- -----------------------------------------------------------------------------
-- Extracting information from the packages in scope
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) (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
- return (concat (map all_opts ps))
- where
+ -- This is a hack that's even more horrible (and hopefully more temporary)
+ -- than the one below [referring to previous splittage of HSbase into chunks
+ -- to work around GNU ld bug]. 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
- -- This is a totally horrible (temporary) hack, for Win32. Problem is
- -- that package.conf for Win32 says that the main prelude lib is
- -- split into HSbase1, HSbase2 and HSbase3, which is needed due to a bug
- -- in the GNU linker (PEi386 backend). However, we still only
- -- have HSbase.a for static linking, not HSbase{1,2,3}.a
- -- getPackageLibraries is called to find the .a's to add to the static
- -- link line. On Win32, this hACK detects HSbase{1,2,3} and
- -- replaces them with HSbase, so static linking still works.
- -- Libraries needed for dynamic (GHCi) linking are discovered via
- -- different route (in InteractiveUI.linkPackage).
- -- See driver/PackageSrc.hs for the HSbase1/HSbase2 split definition.
- -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...)
- -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2]
- -- KAA 29 Mar 02: Same appalling hack for HSobjectio[1,2,3,4]
- --
- -- [sof 03/05: Renamed the (moribund) HSwin32 to HSwin_32 so as to
- -- avoid filename conflicts with the 'Win32' package on a case-insensitive filesystem]
- hACK libs
-# if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
- = libs
-# else
- = if "HSbase1" `elem` libs && "HSbase2" `elem` libs && "HSbase3" `elem` libs
- then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs
- else
- if "HSwin_321" `elem` libs && "HSwin_322" `elem` libs
- then "HSwin_32" : filter (not.(isPrefixOf "HSwin_32")) libs
- else
- if "HSobjectio1" `elem` libs && "HSobjectio2" `elem` libs && "HSobjectio3" `elem` libs && "HSobjectio4" `elem` libs
- then "HSobjectio" : filter (not.(isPrefixOf "HSobjectio")) libs
- else
- libs
-# endif
+ return (concat (map all_opts ps))
getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
| 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
-- Show package info on console, if verbosity is >= 3
dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags)
- putMsg $ showSDoc $
+ putMsg dflags $
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
\end{code}
projects / ghc-hetmet.git / blobdiff