X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FPackages.lhs;h=65f8523b44ee6604290f2990ba726d41208571f5;hb=487f186dfdf4cab27dd6cf03f7e178f3a4bd491d;hp=8a4009d89a1ea032911a50cab57f709f8e7c8284;hpb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 8a4009d..65f8523 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -37,16 +37,17 @@ where #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(..), opt_Static ) +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 UniqSet import Util +import Maybes ( expectJust ) import Panic import Outputable @@ -59,8 +60,7 @@ import Compat.Directory ( getAppUserDataDirectory ) import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version -import System.IO ( hPutStrLn, stderr ) -import Data.Maybe ( fromJust, isNothing ) +import Data.Maybe ( isNothing ) import System.Directory ( doesFileExist ) import Control.Monad ( when, foldM ) import Data.List ( nub, partition ) @@ -72,6 +72,7 @@ import Data.List ( isPrefixOf ) import FastString import DATA_IOREF import EXCEPTION ( throwDyn ) +import ErrUtils ( debugTraceMsg, putMsg ) -- --------------------------------------------------------------------------- -- The Package state @@ -177,11 +178,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; @@ -201,13 +206,16 @@ readPackageConfigs dflags = do -- unless the -no-user-package-conf flag was given. -- We only do this when getAppUserDataDirectory is available -- (GHC >= 6.3). - appdir <- getAppUserDataDirectory "ghc" - let + (exists, pkgconf) <- catch (do + appdir <- getAppUserDataDirectory "ghc" + let pkgconf = appdir ++ '/':TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion ++ "/package.conf" - -- - exists <- doesFileExist pkgconf - pkg_map2 <- if (readUserPkgConf dflags && exists) + 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 @@ -221,14 +229,19 @@ readPackageConfigs dflags = do 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 "$topdir" at the beginning of a path @@ -255,7 +268,7 @@ mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState mkPackageState dflags 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. @@ -351,7 +364,7 @@ mkPackageState dflags pkg_db = do let extend_modmap modmap pkgname = do let - pkg = fromJust (lookupPackage pkg_db pkgname) + 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 @@ -364,7 +377,6 @@ mkPackageState dflags pkg_db = do -- when (not (null overlaps)) $ overlappingError pkg overlaps -- - let return (addListToUFM modmap [(m, (pkg, m `elem` exposed_mods)) | m <- all_mods]) @@ -433,13 +445,12 @@ getPackageLibraryPath dflags pkgs = do 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 "_dyn" + imp = if opt_Static then "" else "_dyn" libs p = map ((++imp) . addSuffix) (hACK (hsLibraries p)) ++ extraLibraries p - all_opts p = map ("-l" ++) (libs p) ++ extraLdOpts 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 @@ -464,6 +475,9 @@ getPackageLinkOpts dflags pkgs = do -- 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 @@ -471,8 +485,8 @@ getPackageLinkOpts dflags pkgs = do = 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 @@ -483,7 +497,7 @@ getPackageLinkOpts dflags pkgs = do 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 @@ -493,7 +507,7 @@ 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 @@ -561,6 +575,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}