extendPackageConfigMap, dumpPackages,
-- * Reading the package config, and processing cmdline args
- PackageState(..),
+ PackageIdH(..), isHomePackage,
+ PackageState(..),
initPackages,
- moduleToPackageConfig,
getPackageDetails,
- isHomeModule,
+ checkForPackageConflicts,
+ lookupModuleInAllPackages,
+
+ HomeModules, mkHomeModules, isHomeModule,
-- * Inspecting the set of packages in scope
getPackageIncludePath,
#include "HsVersions.h"
import PackageConfig
-import DriverState ( v_Build_tag, v_RTS_Build_tag, v_Static )
import SysTools ( getTopDir, getPackageConfigPath )
import ParsePkgConf ( loadPackageConfig )
-import CmdLineOpts ( DynFlags(..), PackageFlag(..), verbosity,
- opt_Static )
-import Config ( cTARGETARCH, cTARGETOS, cProjectVersion )
+import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) )
+import StaticFlags ( opt_Static )
+import Config ( cProjectVersion )
import Name ( Name, nameModule_maybe )
-import Module ( Module, mkModule )
import UniqFM
+import Module
+import FiniteMap
import UniqSet
import Util
+import Maybes ( expectJust, MaybeErr(..) )
import Panic
import Outputable
import Distribution.InstalledPackageInfo
import Distribution.Package
-import System.IO ( hPutStrLn, stderr )
-import Data.Version
-import Data.Maybe ( fromJust, isNothing )
+import Distribution.Version
+import Data.Maybe ( isNothing )
import System.Directory ( doesFileExist )
-import Control.Monad ( when, foldM )
-import Data.List ( nub, partition )
+import Control.Monad ( foldM )
+import Data.List ( nub, partition, sortBy )
+
+#ifdef mingw32_TARGET_OS
+import Data.List ( isPrefixOf )
+#endif
+import Data.List ( isSuffixOf )
+
import FastString
-import DATA_IOREF
import EXCEPTION ( throwDyn )
+import ErrUtils ( debugTraceMsg, putMsg, Message )
-- ---------------------------------------------------------------------------
-- The Package state
-- 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.
- moduleToPkgConf :: UniqFM (PackageConfig,Bool),
+ 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.
-- The PackageIds of some known packages
- basePackageId :: Maybe PackageId,
- rtsPackageId :: Maybe PackageId,
- haskell98PackageId :: Maybe PackageId,
- thPackageId :: Maybe PackageId
+ basePackageId :: PackageIdH,
+ rtsPackageId :: PackageIdH,
+ haskell98PackageId :: PackageIdH,
+ thPackageId :: PackageIdH
}
+data PackageIdH
+ = HomePackage -- The "home" package is the package curently
+ -- being compiled
+ | ExtPackage PackageId -- An "external" package is any other package
+
+
+isHomePackage :: PackageIdH -> Bool
+isHomePackage HomePackage = True
+isHomePackage (ExtPackage _) = False
+
-- A PackageConfigMap maps a PackageId to a PackageConfig
type PackageConfigMap = UniqFM PackageConfig
where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
getPackageDetails :: PackageState -> PackageId -> PackageConfig
-getPackageDetails dflags ps = fromJust (lookupPackage (pkgIdMap dflags) ps)
+getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkgIdMap dflags) ps)
-- ----------------------------------------------------------------------------
-- Loading the package config files and building up the package state
+-- | Call this after parsing the DynFlags. It reads the package
+-- configuration files, and sets up various internal tables of package
+-- information, according to the package-related flags on the
+-- command-line (@-package@, @-hide-package@ etc.)
initPackages :: DynFlags -> IO DynFlags
initPackages dflags = do
pkg_map <- readPackageConfigs dflags;
-- unless the -no-user-package-conf flag was given.
-- We only do this when getAppUserDataDirectory is available
-- (GHC >= 6.3).
- appdir <- getAppUserDataDirectory "ghc"
- let
- pkgconf = appdir ++ '/':cTARGETARCH ++ '-':cTARGETOS
- ++ '-':cProjectVersion ++ "/package.conf"
- --
- exists <- doesFileExist pkgconf
- pkg_map2 <- if (readUserPkgConf dflags && exists)
+ (exists, pkgconf) <- catch (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
readPackageConfig
:: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
readPackageConfig dflags pkg_map conf_file = do
- when (verbosity dflags >= 2) $
- hPutStrLn stderr ("Reading package config file: "
- ++ conf_file)
+ debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file)
proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir
- let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
- return (extendPackageConfigMap pkg_map pkg_configs)
-
+ let pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
+ pkg_configs2 = maybeHidePackages dflags pkg_configs1
+ return (extendPackageConfigMap pkg_map pkg_configs2)
+
+maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig]
+maybeHidePackages dflags pkgs
+ | dopt Opt_HideAllPackages dflags = map hide pkgs
+ | otherwise = pkgs
+ where
+ hide pkg = pkg{ exposed = False }
mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
--- Replace the string "$libdir" at the beginning of a path
--- with the current libdir (obtained from the -B option).
+-- Replace the string "$topdir" at the beginning of a path
+-- with the current topdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
where
munge_pkg p = p{ importDirs = munge_paths (importDirs p),
munge_paths = map munge_path
munge_path p
- | Just p' <- maybePrefixMatch "$libdir" p = top_dir ++ p'
+ | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
| otherwise = p
-- settings and populate the package state.
mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState
-mkPackageState dflags pkg_db = do
+mkPackageState dflags orig_pkg_db = do
--
-- Modify the package database according to the command-line flags
- -- (-package, -hide-package, -ignore-package).
+ -- (-package, -hide-package, -ignore-package, -hide-all-packages).
--
-- Also, here we build up a set of the packages mentioned in -package
-- flags on the command line; these are called the "explicit" packages.
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
- ([],_) -> missingPackageErr str
(ps,qs) -> procflags qs expl flags
+ -- missing package is not an error for -ignore-package,
+ -- 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
--
- (pkgs1,explicit) <- procflags (eltsUFM 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 =
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
-- Look up some known PackageIds
--
let
+ lookupPackageByName :: FastString -> PackageIdH
lookupPackageByName nm =
case [ conf | p <- dep_exposed,
Just conf <- [lookupPackage pkg_db p],
nm == mkFastString (pkgName (package conf)) ] of
- [] -> Nothing
- (p:ps) -> Just (mkPackageId (package p))
+ [] -> HomePackage
+ (p:ps) -> ExtPackage (mkPackageId (package p))
-- Get the PackageIds for some known packages (we know the names,
-- but we don't know the versions). Some of these packages might
-- add base & rts to the explicit packages
basicLinkedPackages = [basePackageId,rtsPackageId]
explicit' = addListToUniqSet explicit
- [ p | Just p <- basicLinkedPackages ]
+ [ p | ExtPackage p <- basicLinkedPackages ]
--
-- Close the explicit packages with their dependencies
--
-- Discover any conflicts at the same time, and factor in the new exposed
-- status of each package.
--
- let
- extend_modmap modmap pkgname = do
- let
- pkg = fromJust (lookupPackage pkg_db pkgname)
- exposed_mods = map mkModule (exposedModules pkg)
- hidden_mods = map mkModule (hiddenModules pkg)
- all_mods = exposed_mods ++ hidden_mods
- --
- -- check for overlaps
- --
- let
- overlaps = [ (m,pkg) | m <- all_mods,
- Just (pkg,_) <- [lookupUFM modmap m] ]
- --
- when (not (null overlaps)) $ overlappingError pkg overlaps
- --
- let
- return (addListToUFM modmap
- [(m, (pkg, m `elem` exposed_mods))
- | m <- all_mods])
- --
- mod_map <- foldM extend_modmap emptyUFM dep_exposed
-
- return PackageState{ explicitPackages = dep_explicit,
- pkgIdMap = pkg_db,
- moduleToPkgConf = mod_map,
- basePackageId = basePackageId,
- rtsPackageId = rtsPackageId,
- haskell98PackageId = haskell98PackageId,
- thPackageId = thPackageId
+ let mod_map = mkModuleMap pkg_db dep_exposed
+
+ return PackageState{ explicitPackages = dep_explicit,
+ origPkgIdMap = orig_pkg_db,
+ pkgIdMap = pkg_db,
+ moduleToPkgConfAll = mod_map,
+ basePackageId = basePackageId,
+ rtsPackageId = rtsPackageId,
+ haskell98PackageId = haskell98PackageId,
+ thPackageId = thPackageId
}
-- done!
thPackageName = FSLIT("template-haskell")
-- Template Haskell libraries in here
-overlappingError pkg overlaps
- = throwDyn (CmdLineError (showSDoc (vcat (map msg overlaps))))
+mkModuleMap
+ :: PackageConfigMap
+ -> [PackageId]
+ -> ModuleEnv [(PackageConfig, Bool)]
+mkModuleMap pkg_db pkgs = foldr extend_modmap emptyUFM pkgs
+ where
+ extend_modmap pkgname modmap =
+ addListToUFM_C (++) modmap
+ [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
+ where
+ pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgname)
+ exposed_mods = map mkModule (exposedModules pkg)
+ hidden_mods = map mkModule (hiddenModules pkg)
+ all_mods = exposed_mods ++ hidden_mods
+
+-- -----------------------------------------------------------------------------
+-- Check for conflicts in the program.
+
+-- | A conflict arises if the program contains two modules with the same
+-- name, which can arise if the program depends on multiple packages that
+-- expose the same module, or if the program depends on a package that
+-- contains a module also present in the program (the "home package").
+--
+checkForPackageConflicts
+ :: DynFlags
+ -> [Module] -- modules in the home package
+ -> [PackageId] -- packages on which the program depends
+ -> MaybeErr Message ()
+
+checkForPackageConflicts dflags mods pkgs = do
+ let
+ state = pkgState dflags
+ pkg_db = pkgIdMap state
+ --
+ dep_pkgs <- closeDepsErr pkg_db pkgs
+
+ let
+ extend_modmap pkgname modmap =
+ addListToFM_C (++) modmap
+ [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
+ where
+ pkg = expectJust "checkForPackageConflicts"
+ (lookupPackage pkg_db pkgname)
+ exposed_mods = map mkModule (exposedModules pkg)
+ hidden_mods = map mkModule (hiddenModules pkg)
+ all_mods = exposed_mods ++ hidden_mods
+
+ mod_map = foldr extend_modmap emptyFM pkgs
+ mod_map_list :: [(Module,[(PackageConfig,Bool)])]
+ mod_map_list = fmToList mod_map
+
+ overlaps = [ (m, map fst ps) | (m,ps@(_:_:_)) <- mod_map_list ]
+ --
+ if not (null overlaps)
+ then Failed (pkgOverlapError overlaps)
+ else do
+
+ let
+ overlap_mods = [ (mod,pkg)
+ | mod <- mods,
+ Just ((pkg,_):_) <- [lookupFM mod_map mod] ]
+ -- will be only one package here
+ if not (null overlap_mods)
+ then Failed (modOverlapError overlap_mods)
+ else do
+
+ return ()
+
+pkgOverlapError overlaps = vcat (map msg overlaps)
+ where
+ msg (mod,pkgs) =
+ text "conflict: module" <+> quotes (ppr mod)
+ <+> ptext SLIT("is present in multiple packages:")
+ <+> hsep (punctuate comma (map (text.showPackageId.package) pkgs))
+
+modOverlapError overlaps = vcat (map msg overlaps)
where
- this_pkg = text (showPackageId (package pkg))
- msg (mod,other_pkg) =
- text "Error: module '" <> ppr mod
- <> text "' is exposed by package "
- <> this_pkg <> text " and package "
- <> text (showPackageId (package other_pkg))
-
-multiplePackagesErr str ps =
- throwDyn (CmdLineError (showSDoc (
- text "Error; multiple packages match" <+>
- text str <> colon <+>
- sep (punctuate comma (map (text.showPackageId.package) ps))
- )))
+ msg (mod,pkg) = fsep [
+ text "conflict: module",
+ quotes (ppr mod),
+ ptext SLIT("belongs to the current program/library"),
+ ptext SLIT("and also to package"),
+ text (showPackageId (package pkg)) ]
-- -----------------------------------------------------------------------------
-- Extracting information from the packages in scope
getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
getPackageLinkOpts dflags pkgs = do
ps <- getExplicitPackagesAnd dflags pkgs
- tag <- readIORef v_Build_tag
- rts_tag <- readIORef v_RTS_Build_tag
- static <- readIORef v_Static
+ let tag = buildTag dflags
+ rts_tag = rtsBuildTag dflags
let
- imp = if static then "" else "_imp"
- libs p = map addSuffix (hACK (hsLibraries p)) ++ extraLibraries p
- imp_libs p = map (++imp) (libs p)
- all_opts p = map ("-l" ++) (imp_libs p) ++ extraLdOpts p
+ imp = if opt_Static then "" else "_dyn"
+ 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
rts_suffix = if null rts_tag then "" else '_':rts_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
-- 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
= if "HSbase1" `elem` libs && "HSbase2" `elem` libs && "HSbase3" `elem` libs
then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs
else
- if "HSwin321" `elem` libs && "HSwin322" `elem` libs
- then "HSwin32" : filter (not.(isPrefixOf "HSwin32")) libs
+ 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
libs
# endif
+
getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
ps <- getExplicitPackagesAnd dflags pkgs
- return (concatMap extraCcOpts ps)
+ return (concatMap ccOptions ps)
getPackageFrameworkPath :: DynFlags -> [PackageId] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
getPackageFrameworks :: DynFlags -> [PackageId] -> IO [String]
getPackageFrameworks dflags pkgs = do
ps <- getExplicitPackagesAnd dflags pkgs
- return (concatMap extraFrameworks ps)
+ return (concatMap frameworks ps)
-- -----------------------------------------------------------------------------
-- Package Utils
--- Takes a Module, and if the module is in a package returns
--- (pkgconf,exposed) where pkgconf is the PackageConfig for that package,
+-- | Takes a Module, and if the module is in a package returns
+-- @(pkgconf,exposed)@ where pkgconf is the PackageConfig for that package,
-- and exposed is True if the package exposes the module.
-moduleToPackageConfig :: DynFlags -> Module -> Maybe (PackageConfig,Bool)
-moduleToPackageConfig dflags m =
- lookupUFM (moduleToPkgConf (pkgState dflags)) m
-
-isHomeModule :: DynFlags -> Module -> Bool
-isHomeModule dflags mod = isNothing (moduleToPackageConfig dflags mod)
+lookupModuleInAllPackages :: DynFlags -> Module -> [(PackageConfig,Bool)]
+lookupModuleInAllPackages dflags m =
+ case lookupModuleEnv (moduleToPkgConfAll (pkgState dflags)) m of
+ Nothing -> []
+ Just ps -> ps
getExplicitPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
getExplicitPackagesAnd dflags pkgids =
pkg_map = pkgIdMap state
expl = explicitPackages state
in do
- all_pkgs <- foldM (add_package pkg_map) expl pkgids
+ all_pkgs <- throwErr (foldM (add_package pkg_map) expl pkgids)
return (map (getPackageDetails state) all_pkgs)
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
closeDeps :: PackageConfigMap -> [PackageId] -> IO [PackageId]
-closeDeps pkg_map ps = foldM (add_package pkg_map) [] ps
+closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps)
+
+throwErr :: MaybeErr Message a -> IO a
+throwErr m = case m of
+ Failed e -> throwDyn (CmdLineError (showSDoc e))
+ Succeeded r -> return r
+
+closeDepsErr :: PackageConfigMap -> [PackageId]
+ -> MaybeErr Message [PackageId]
+closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
-- internal helper
-add_package :: PackageConfigMap -> [PackageId] -> PackageId -> IO [PackageId]
+add_package :: PackageConfigMap -> [PackageId] -> PackageId
+ -> MaybeErr Message [PackageId]
add_package pkg_db ps p
| p `elem` ps = return ps -- Check if we've already added this package
| otherwise =
case lookupPackage pkg_db p of
- Nothing -> missingPackageErr (packageIdString p)
+ Nothing -> Failed (missingPackageMsg (packageIdString p))
Just pkg -> do
-- Add the package's dependents also
let deps = map mkPackageId (depends pkg)
ps' <- foldM (add_package pkg_db) ps deps
return (p : ps')
-missingPackageErr p = throwDyn (CmdLineError ("unknown package: " ++ p))
+missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
+missingPackageMsg p = ptext SLIT("unknown package:") <+> text p
-- -----------------------------------------------------------------------------
+-- The home module set
+
+newtype HomeModules = HomeModules ModuleSet
+
+mkHomeModules :: [Module] -> HomeModules
+mkHomeModules = HomeModules . mkModuleSet
+
+isHomeModule :: HomeModules -> Module -> Bool
+isHomeModule (HomeModules set) mod = elemModuleSet mod set
+
-- Determining whether a Name refers to something in another package or not.
-- Cross-package references need to be handled differently when dynamically-
-- linked libraries are involved.
-isDllName :: DynFlags -> Name -> Bool
-isDllName dflags name
+isDllName :: HomeModules -> Name -> Bool
+isDllName pdeps name
| opt_Static = False
- | otherwise =
- case nameModule_maybe name of
- Nothing -> False -- no, it is not even an external name
- Just mod ->
- case lookupUFM (moduleToPkgConf (pkgState dflags)) mod of
- Just _ -> True -- yes, its a package module
- Nothing -> False -- no, must be a home module
+ | Just mod <- nameModule_maybe name = not (isHomeModule pdeps mod)
+ | otherwise = False -- no, it is not even an external name
-- -----------------------------------------------------------------------------
-- Displaying packages
-- Show package info on console, if verbosity is >= 3
dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags)
- hPutStrLn stderr $ showSDoc $
+ putMsg $ showSDoc $
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
\end{code}