Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/6a831be4aa73e86568256813ffa862d7cfd5732d >--------------------------------------------------------------- commit 6a831be4aa73e86568256813ffa862d7cfd5732d Author: Paolo Capriotti <[email protected]> Date: Thu May 3 11:29:51 2012 +0100 Add flags to manipulate package db stack (#5977) Introduce new flags to allow any package database stack to be set up. The `-no-user-package-conf` and `-no-global-package-conf` flags remove the corresponding package db from the initial stack, while `-user-package-conf` and `-global-package-conf` push it back on top of the stack. >--------------------------------------------------------------- compiler/main/DynFlags.hs | 24 +++++++++++-- compiler/main/Packages.lhs | 81 +++++++++++++++++++++----------------------- 2 files changed, 60 insertions(+), 45 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a497ded..f49da93 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -38,6 +38,7 @@ module DynFlags ( GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), + PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), fFlags, fWarningFlags, fLangFlags, xFlags, @@ -275,6 +276,7 @@ data DynFlag | Opt_ForceRecomp | Opt_ExcessPrecision | Opt_EagerBlackHoling + | Opt_ReadGlobalPackageConf | Opt_ReadUserPackageConf | Opt_NoHsMain | Opt_SplitObjs @@ -548,7 +550,7 @@ data DynFlags = DynFlags { depSuffixes :: [String], -- Package flags - extraPkgConfs :: [FilePath], + extraPkgConfs :: [PkgConfRef], -- ^ The @-package-conf@ flags given on the command line, in the order -- they appeared. @@ -1755,8 +1757,13 @@ dynamic_flags = [ package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - Flag "package-conf" (HasArg extraPkgConf_) + Flag "package-conf" (HasArg (extraPkgConf_ . PkgConfFile)) + , Flag "clear-package-conf" (NoArg clearPkgConf) + , Flag "no-global-package-conf" (NoArg (unSetDynFlag Opt_ReadGlobalPackageConf)) , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + , Flag "global-package-conf" (NoArg (extraPkgConf_ GlobalPkgConf)) + , Flag "user-package-conf" (NoArg (extraPkgConf_ UserPkgConf)) + , Flag "package-name" (hasArg setPackageName) , Flag "package-id" (HasArg exposePackageId) , Flag "package" (HasArg exposePackage) @@ -2066,6 +2073,7 @@ xFlags = [ defaultFlags :: [DynFlag] defaultFlags = [ Opt_AutoLinkPackages, + Opt_ReadGlobalPackageConf, Opt_ReadUserPackageConf, Opt_SharedImplib, @@ -2404,9 +2412,19 @@ setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) addCmdlineHCInclude :: String -> DynP () addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) -extraPkgConf_ :: FilePath -> DynP () +data PkgConfRef + = GlobalPkgConf + | UserPkgConf + | PkgConfFile FilePath + +extraPkgConf_ :: PkgConfRef -> DynP () extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) +clearPkgConf :: DynP () +clearPkgConf = do + unSetDynFlag Opt_ReadGlobalPackageConf + unSetDynFlag Opt_ReadUserPackageConf + exposePackage, exposePackageId, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () exposePackage p = diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index aa5a432..12aefc0 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -152,10 +152,10 @@ getPackageDetails :: PackageState -> PackageId -> PackageConfig getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid) -- ---------------------------------------------------------------------------- --- Loading the package config files and building up the package state +-- Loading the package db files and building up the package state -- | Call this after 'DynFlags.parseDynFlags'. It reads the package --- configuration files, and sets up various internal tables of package +-- database files, and sets up various internal tables of package -- information, according to the package-related flags on the -- command-line (@-package@, @-hide-package@ etc.) -- @@ -184,46 +184,43 @@ initPackages dflags = do readPackageConfigs :: DynFlags -> IO [PackageConfig] readPackageConfigs dflags = do - e_pkg_path <- tryIO (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. - - pkgs <- mapM (readPackageConfig dflags) - (pkgconfs ++ reverse (extraPkgConfs dflags)) - -- later packages shadow earlier ones. extraPkgConfs - -- is in the opposite order to the flags on the - -- command line. - - return (concat pkgs) - - -getSystemPackageConfigs :: DynFlags -> IO [FilePath] -getSystemPackageConfigs dflags = do - -- System one always comes first - let system_pkgconf = systemPackageConfig dflags - - -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) - -- unless the -no-user-package-conf flag was given. - user_pkgconf <- do - if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do - appdir <- getAppUserDataDirectory "ghc" - let - dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) - pkgconf = dir </> "package.conf.d" - -- - exist <- doesDirectoryExist pkgconf - if exist then return [pkgconf] else return [] - `catchIO` (\_ -> return []) - - return (system_pkgconf : user_pkgconf) + let -- Read global package db, unless the -no-user-package-conf flag was given + global_conf_refs = [GlobalPkgConf | dopt Opt_ReadGlobalPackageConf dflags] + -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) + -- unless the -no-user-package-conf flag was given. + user_conf_refs = [UserPkgConf | dopt Opt_ReadUserPackageConf dflags] + + system_conf_refs = global_conf_refs ++ user_conf_refs + + e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | null (last cs) + -> map PkgConfFile (init cs) ++ system_conf_refs + | otherwise + -> map PkgConfFile cs + where cs = parseSearchPath path + -- if the path ends in a separator (eg. "/foo/bar:") + -- the we tack on the base paths. + + let conf_refs = base_conf_refs ++ reverse (extraPkgConfs dflags) + -- later packages shadow earlier ones. extraPkgConfs + -- is in the opposite order to the flags on the + -- command line. + confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs + + liftM concat $ mapM (readPackageConfig dflags) confs + +resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) +resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) +resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + pkgconf = dir </> "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing +resolvePackageConfig _ (PkgConfFile name) = return $ Just name readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
