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.

2 files changed, 60 insertions, 45 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index a497dedcda..f49da9358f 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 aa5a432762..12aefc0308 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