X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fmain%2FPackages.lhs;h=76d2f08f268b5f1a2bf8fe345bb945c6fcdd0190;hb=479cc24837aa2c14c3bbed323bb640a5c53a2522;hp=6f0b867f61ca1efa7540fba9f6935f15877187cd;hpb=efbbd977b60efc357b134124c8a9152d9b704811;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 6f0b867..76d2f08 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,18 +61,13 @@ 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 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 ) @@ -205,39 +201,52 @@ 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 -- 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_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 @@ -289,20 +298,18 @@ mkPackageState dflags orig_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') expl' 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' = hideAll (pkgName (package p)) ps expl' = addOneToUniqSet expl pkgid - (ps,_) -> multiplePackagesErr str ps 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 @@ -310,6 +317,16 @@ mkPackageState dflags orig_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 @@ -329,33 +346,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, 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 -- @@ -413,13 +446,6 @@ haskell98PackageName = FSLIT("haskell98") 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] @@ -493,7 +519,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 @@ -502,7 +528,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 @@ -537,7 +566,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 @@ -546,41 +576,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 @@ -640,7 +646,7 @@ 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 -> Failed (missingPackageErr (packageIdString p)) + Nothing -> Failed (missingPackageMsg (packageIdString p)) Just pkg -> do -- Add the package's dependents also let deps = map mkPackageId (depends pkg) @@ -648,7 +654,7 @@ add_package pkg_db ps p 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 @@ -678,6 +684,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}