X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FPackages.lhs;h=06180a172bda30165e85c7085f302f6137a96e42;hb=50159f6c4a3560662e37c55e64af1fb0b685011e;hp=d3a942b64b8a0182880da47c6b75aec9b3450f57;hpb=f9f374cf7117348d2f52f06ce3debd1e8672b562;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index d3a942b..06180a1 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -12,7 +12,8 @@ module Packages ( extendPackageConfigMap, dumpPackages, -- * Reading the package config, and processing cmdline args - PackageState(..), + PackageIdH(..), isHomePackage, + PackageState(..), initPackages, moduleToPackageConfig, getPackageDetails, @@ -36,12 +37,11 @@ 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(..), verbosity, - opt_Static ) -import Config ( cTARGETARCH, cTARGETOS, cProjectVersion ) +import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) +import StaticFlags ( opt_Static ) +import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import Module ( Module, mkModule ) import UniqFM @@ -58,12 +58,17 @@ import Compat.Directory ( getAppUserDataDirectory ) import Distribution.InstalledPackageInfo import Distribution.Package +import Distribution.Version import System.IO ( hPutStrLn, stderr ) -import Data.Version 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 FastString import DATA_IOREF import EXCEPTION ( throwDyn ) @@ -140,12 +145,22 @@ data PackageState = PackageState { -- exposed is True if the package exposes that module. -- The PackageIds of some known packages - basePackageId :: Maybe PackageId, - rtsPackageId :: Maybe PackageId, - haskell98PackageId :: Maybe PackageId, - thPackageId :: Maybe PackageId + basePackageId :: PackageIdH, + rtsPackageId :: PackageIdH, + haskell98PackageId :: PackageIdH, + thPackageId :: PackageIdH } +data PackageIdH + = HomePackage -- The "home" package is the package curently + -- being compiled + | ExtPackage PackageId -- An "external" package is any other package + + +isHomePackage :: PackageIdH -> Bool +isHomePackage HomePackage = True +isHomePackage (ExtPackage _) = False + -- A PackageConfigMap maps a PackageId to a PackageConfig type PackageConfigMap = UniqFM PackageConfig @@ -186,13 +201,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 - pkgconf = appdir ++ '/':cTARGETARCH ++ '-':cTARGETOS + (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 @@ -207,7 +225,7 @@ readPackageConfig :: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap readPackageConfig dflags pkg_map conf_file = do when (verbosity dflags >= 2) $ - hPutStrLn stderr ("Reading package config file: " + hPutStrLn stderr ("Using package config file: " ++ conf_file) proto_pkg_configs <- loadPackageConfig conf_file top_dir <- getTopDir @@ -216,8 +234,8 @@ readPackageConfig dflags pkg_map conf_file = do mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig] --- Replace the string "$libdir" at the beginning of a path --- with the current libdir (obtained from the -B option). +-- Replace the string "$topdir" at the beginning of a path +-- with the current topdir (obtained from the -B option). mungePackagePaths top_dir ps = map munge_pkg ps where munge_pkg p = p{ importDirs = munge_paths (importDirs p), @@ -228,7 +246,7 @@ mungePackagePaths top_dir ps = map munge_pkg ps munge_paths = map munge_path munge_path p - | Just p' <- maybePrefixMatch "$libdir" p = top_dir ++ p' + | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' | otherwise = p @@ -267,8 +285,10 @@ mkPackageState dflags pkg_db = do (ps,_) -> multiplePackagesErr str ps procflags pkgs expl (IgnorePackage str : flags) = do case partition (matches str) pkgs of - ([],_) -> missingPackageErr str (ps,qs) -> procflags qs expl flags + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. -- A package named on the command line can either include the -- version, or just the name if it is unambiguous. @@ -302,12 +322,13 @@ mkPackageState dflags pkg_db = do -- Look up some known PackageIds -- let + lookupPackageByName :: FastString -> PackageIdH lookupPackageByName nm = case [ conf | p <- dep_exposed, Just conf <- [lookupPackage pkg_db p], nm == mkFastString (pkgName (package conf)) ] of - [] -> Nothing - (p:ps) -> Just (mkPackageId (package p)) + [] -> HomePackage + (p:ps) -> ExtPackage (mkPackageId (package p)) -- Get the PackageIds for some known packages (we know the names, -- but we don't know the versions). Some of these packages might @@ -320,7 +341,7 @@ mkPackageState dflags pkg_db = do -- add base & rts to the explicit packages basicLinkedPackages = [basePackageId,rtsPackageId] explicit' = addListToUniqSet explicit - [ p | Just p <- basicLinkedPackages ] + [ p | ExtPackage p <- basicLinkedPackages ] -- -- Close the explicit packages with their dependencies -- @@ -382,7 +403,7 @@ overlappingError pkg overlaps multiplePackagesErr str ps = throwDyn (CmdLineError (showSDoc ( text "Error; multiple packages match" <+> - text str <> colon <> + text str <> colon <+> sep (punctuate comma (map (text.showPackageId.package) ps)) ))) @@ -415,14 +436,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 "_imp" - libs p = map addSuffix (hACK (hsLibraries p)) ++ extraLibraries p - imp_libs p = map (++imp) (libs p) - all_opts p = map ("-l" ++) (imp_libs p) ++ extraLdOpts p + imp = if opt_Static then "" else "_dyn" + libs p = map ((++imp) . addSuffix) (hACK (hsLibraries p)) ++ extraLibraries 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 @@ -466,7 +485,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 @@ -476,7 +495,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