X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FPackages.lhs;h=21c5596b64ba28fefc8541013da2afc2e7f6757e;hb=a004ae5ab1167ddfaa4cdf4b8d9df2ce92e541a2;hp=45b083513bfda30bba824a3c6d7f5e8555cf744c;hpb=853e20a3eb86137cdb8accf69c6caa9db83a3d34;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 45b0835..21c5596 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -15,9 +15,11 @@ module Packages ( PackageIdH(..), isHomePackage, PackageState(..), initPackages, - moduleToPackageConfig, getPackageDetails, - isHomeModule, + checkForPackageConflicts, + lookupModuleInAllPackages, + + HomeModules, mkHomeModules, isHomeModule, -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -43,11 +45,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 ) +import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable @@ -60,19 +63,19 @@ import Compat.Directory ( getAppUserDataDirectory ) import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version -import System.IO ( hPutStrLn, stderr ) 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 @@ -136,11 +139,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. @@ -183,6 +191,10 @@ getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkg -- ---------------------------------------------------------------------------- -- 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; @@ -205,8 +217,9 @@ readPackageConfigs dflags = do (exists, pkgconf) <- catch (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. @@ -225,14 +238,19 @@ readPackageConfigs dflags = do 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 ("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 "$topdir" at the beginning of a path @@ -256,10 +274,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. @@ -272,18 +290,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 @@ -291,13 +309,50 @@ 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 + -- + -- 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 ]) -- - (pkgs1,explicit) <- procflags (eltsUFM pkg_db) emptyUniqSet flags + -- Eliminate any packages which have dangling dependencies (perhaps + -- because the package was removed by -ignore-package). -- let elimDanglingDeps pkgs = @@ -309,10 +364,7 @@ mkPackageState dflags pkg_db = do 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 @@ -352,35 +404,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 = expectJust "mkPackageState" (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 - -- - 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 +423,89 @@ 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 - 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,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 + 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 @@ -440,7 +540,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) (hACK (hsLibraries p)) + ++ hACK_dyn (extraLibraries p) all_opts p = map ("-l" ++) (libs p) ++ ldOptions p suffix = if null tag then "" else '_':tag @@ -449,6 +550,15 @@ getPackageLinkOpts dflags pkgs = do 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 @@ -485,6 +595,7 @@ getPackageLinkOpts dflags pkgs = do libs # endif + getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] getPackageExtraCcOpts dflags pkgs = do ps <- getExplicitPackagesAnd dflags pkgs @@ -503,15 +614,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 +630,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 +692,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 $ showSDoc $ vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) \end{code}