X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FPackages.lhs;h=ae6b18863e7a791ccf86d81d94e3ded92c145999;hb=50bc39808cd5b483a048a4d387f937963bd0e00f;hp=21c5596b64ba28fefc8541013da2afc2e7f6757e;hpb=a004ae5ab1167ddfaa4cdf4b8d9df2ce92e541a2;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 21c5596..ae6b188 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -13,7 +13,8 @@ module Packages ( -- * Reading the package config, and processing cmdline args PackageIdH(..), isHomePackage, - PackageState(..), + PackageState(..), + mkPackageState, initPackages, getPackageDetails, checkForPackageConflicts, @@ -60,19 +61,14 @@ import System.Directory ( getAppUserDataDirectory ) 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, sortBy ) - -#ifdef mingw32_TARGET_OS -import Data.List ( isPrefixOf ) -#endif -import Data.List ( isSuffixOf ) - +import Data.List ( nub, partition, sortBy, isSuffixOf ) import FastString import EXCEPTION ( throwDyn ) import ErrUtils ( debugTraceMsg, putMsg, Message ) @@ -206,39 +202,67 @@ 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 `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 + if (flg && dopt Opt_ReadUserPackageConf dflags) + then return [pkgconf] + else return [] - -- Read all the ones mentioned in -package-conf flags - pkg_map <- foldM (readPackageConfig dflags) pkg_map2 - (extraPkgConfs dflags) - - 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 @@ -338,34 +362,49 @@ mkPackageState dflags orig_pkg_db = do -- 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 ]) + 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 -- - let pkgs = elimDanglingDeps pkgs2 - pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs + pkgs <- elimDanglingDeps pkgs2 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs -- -- Find the transitive closure of dependencies of exposed -- @@ -496,7 +535,7 @@ pkgOverlapError overlaps = vcat (map msg overlaps) 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 @@ -505,7 +544,10 @@ modOverlapError overlaps = vcat (map msg overlaps) 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 @@ -540,7 +582,7 @@ getPackageLinkOpts dflags pkgs = do rts_tag = rtsBuildTag dflags let imp = if opt_Static then "" else "_dyn" - libs p = map ((++imp) . addSuffix) (hACK (hsLibraries p)) + libs p = map ((++imp) . addSuffix) (hsLibraries p) ++ hACK_dyn (extraLibraries p) all_opts p = map ("-l" ++) (libs p) ++ ldOptions p @@ -551,7 +593,8 @@ getPackageLinkOpts dflags pkgs = do 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 + -- 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. @@ -560,41 +603,6 @@ getPackageLinkOpts dflags pkgs = do | otherwise = lib return (concat (map all_opts ps)) - where - - -- 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 - getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] getPackageExtraCcOpts dflags pkgs = do @@ -692,6 +700,6 @@ dumpPackages :: DynFlags -> IO () -- 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}