X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FPackages.lhs;h=ae6b18863e7a791ccf86d81d94e3ded92c145999;hb=50bc39808cd5b483a048a4d387f937963bd0e00f;hp=3f581e2619f38c1cb188b763331c0215861aa090;hpb=15552e1454cef69c118777720531213256e91079;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 3f581e2..ae6b188 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -13,11 +13,14 @@ module Packages ( -- * Reading the package config, and processing cmdline args PackageIdH(..), isHomePackage, - PackageState(..), + PackageState(..), + mkPackageState, initPackages, - moduleToPackageConfig, getPackageDetails, - isHomeModule, + checkForPackageConflicts, + lookupModuleInAllPackages, + + HomeModules, mkHomeModules, isHomeModule, -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -43,10 +46,12 @@ 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 @@ -56,22 +61,17 @@ import System.Directory ( getAppUserDataDirectory ) import Compat.Directory ( getAppUserDataDirectory ) #endif +import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version -import System.IO ( hPutStrLn, stderr ) -import Data.Maybe ( fromJust, isNothing ) -import System.Directory ( doesFileExist ) -import Control.Monad ( when, foldM ) -import Data.List ( nub, partition ) - -#ifdef mingw32_TARGET_OS -import Data.List ( isPrefixOf ) -#endif - +import System.Directory ( doesFileExist, doesDirectoryExist, + getDirectoryContents ) +import Control.Monad ( foldM ) +import Data.List ( nub, partition, sortBy, isSuffixOf ) import FastString -import DATA_IOREF import EXCEPTION ( throwDyn ) +import ErrUtils ( debugTraceMsg, putMsg, Message ) -- --------------------------------------------------------------------------- -- The Package state @@ -135,11 +135,16 @@ data PackageState = PackageState { -- 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. @@ -177,11 +182,15 @@ extendPackageConfigMap pkg_map new_pkgs 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; @@ -193,45 +202,79 @@ initPackages dflags = do 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 ++ '/':TARGET_ARCH ++ '-':TARGET_OS - ++ '-':cProjectVersion ++ "/package.conf" + 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 - when (verbosity dflags >= 2) $ - hPutStrLn stderr ("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_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 "$topdir" at the beginning of a path @@ -255,10 +298,10 @@ mungePackagePaths top_dir ps = map munge_pkg ps -- 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. @@ -271,18 +314,18 @@ mkPackageState dflags pkg_db = do 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 @@ -290,29 +333,78 @@ mkPackageState dflags pkg_db = do -- 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 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 -- @@ -351,36 +443,16 @@ mkPackageState dflags pkg_db = do -- 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! @@ -390,22 +462,92 @@ haskell98PackageName = FSLIT("haskell98") 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 pprPkg 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"), + pprPkg pkg ] + +pprPkg :: PackageConfig -> SDoc +pprPkg p = text (showPackageId (package p)) -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope @@ -440,7 +582,8 @@ getPackageLinkOpts dflags pkgs = do 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 @@ -449,41 +592,17 @@ getPackageLinkOpts dflags pkgs = do 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 @@ -503,15 +622,14 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- 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 = @@ -520,44 +638,60 @@ 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 @@ -566,6 +700,6 @@ dumpPackages :: DynFlags -> IO () -- Show package info on console, if verbosity is >= 3 dumpPackages dflags = do let pkg_map = pkgIdMap (pkgState dflags) - hPutStrLn stderr $ showSDoc $ + putMsg dflags $ vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) \end{code}