Teach ghc-pkg about environment fileswip/ghc-pkg-env-files

8 files changed, 346 insertions, 231 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 2d2de4550b..aad4434a63 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -394,6 +394,7 @@ import GHC.Types.Name.Ppr
 import GHC.Types.TypeEnv
 import GHC.Types.BreakInfo
 import GHC.Types.PkgQual
+import GHC.EnvironmentFiles
 
 import GHC.Unit
 import GHC.Unit.Env
@@ -423,8 +424,7 @@ import Control.Applicative ((<|>))
 import Control.Monad.Catch as MC
 
 import GHC.Data.Maybe
-import System.IO.Error  ( isDoesNotExistError )
-import System.Environment ( getEnv, getProgName )
+import System.Environment ( getProgName )
 import System.Directory
 import Data.List (isPrefixOf)
 import qualified Data.Set as S
@@ -886,6 +886,20 @@ parseDynamicFlags logger dflags cmdline = do
   dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1
   return (dflags2, leftovers, warns)
 
+interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
+interpretPackageEnv logger dflags = do
+  let output = compilationProgressMsg logger
+  mb_env <- findPackageEnv (output . text)
+                   (packageEnv dflags)
+                   (gopt Opt_HideAllPackages dflags)
+                   (programName dflags)
+                   (platformArchOS (targetPlatform dflags))
+  return $ case mb_env of
+    Nothing -> dflags
+    Just pkg_env -> snd (runCmdLine (runEwM (setFlagsFromEnvFile pkg_env)) dflags)
+
+
+
 -- | Parse command line arguments that look like files.
 -- First normalises its arguments and then splits them into source files
 -- and object files.
@@ -1843,142 +1857,6 @@ parser str dflags filename =
          let (warns,_) = getPsMessages pst in
          (GhcPsMessage <$> warns, Right rdr_module)
 
--- -----------------------------------------------------------------------------
--- | Find the package environment (if one exists)
---
--- We interpret the package environment as a set of package flags; to be
--- specific, if we find a package environment file like
---
--- > clear-package-db
--- > global-package-db
--- > package-db blah/package.conf.d
--- > package-id id1
--- > package-id id2
---
--- we interpret this as
---
--- > [ -hide-all-packages
--- > , -clear-package-db
--- > , -global-package-db
--- > , -package-db blah/package.conf.d
--- > , -package-id id1
--- > , -package-id id2
--- > ]
---
--- There's also an older syntax alias for package-id, which is just an
--- unadorned package id
---
--- > id1
--- > id2
---
-interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
-interpretPackageEnv logger dflags = do
-    mPkgEnv <- runMaybeT $ msum $ [
-                   getCmdLineArg >>= \env -> msum [
-                       probeNullEnv env
-                     , probeEnvFile env
-                     , probeEnvName env
-                     , cmdLineError env
-                     ]
-                 , getEnvVar >>= \env -> msum [
-                       probeNullEnv env
-                     , probeEnvFile env
-                     , probeEnvName env
-                     , envError     env
-                     ]
-                 , notIfHideAllPackages >> msum [
-                       findLocalEnvFile >>= probeEnvFile
-                     , probeEnvName defaultEnvName
-                     ]
-                 ]
-    case mPkgEnv of
-      Nothing ->
-        -- No environment found. Leave DynFlags unchanged.
-        return dflags
-      Just "-" -> do
-        -- Explicitly disabled environment file. Leave DynFlags unchanged.
-        return dflags
-      Just envfile -> do
-        content <- readFile envfile
-        compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)
-        let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
-
-        return dflags'
-  where
-    -- Loading environments (by name or by location)
-
-    archOS = platformArchOS (targetPlatform dflags)
-
-    namedEnvPath :: String -> MaybeT IO FilePath
-    namedEnvPath name = do
-     appdir <- versionedAppDir (programName dflags) archOS
-     return $ appdir </> "environments" </> name
-
-    probeEnvName :: String -> MaybeT IO FilePath
-    probeEnvName name = probeEnvFile =<< namedEnvPath name
-
-    probeEnvFile :: FilePath -> MaybeT IO FilePath
-    probeEnvFile path = do
-      guard =<< liftMaybeT (doesFileExist path)
-      return path
-
-    probeNullEnv :: FilePath -> MaybeT IO FilePath
-    probeNullEnv "-" = return "-"
-    probeNullEnv _   = mzero
-
-    -- Various ways to define which environment to use
-
-    getCmdLineArg :: MaybeT IO String
-    getCmdLineArg = MaybeT $ return $ packageEnv dflags
-
-    getEnvVar :: MaybeT IO String
-    getEnvVar = do
-      mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT"
-      case mvar of
-        Right var -> return var
-        Left err  -> if isDoesNotExistError err then mzero
-                                                else liftMaybeT $ throwIO err
-
-    notIfHideAllPackages :: MaybeT IO ()
-    notIfHideAllPackages =
-      guard (not (gopt Opt_HideAllPackages dflags))
-
-    defaultEnvName :: String
-    defaultEnvName = "default"
-
-    -- e.g. .ghc.environment.x86_64-linux-7.6.3
-    localEnvFileName :: FilePath
-    localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS
-
-    -- Search for an env file, starting in the current dir and looking upwards.
-    -- Fail if we get to the users home dir or the filesystem root. That is,
-    -- we don't look for an env file in the user's home dir. The user-wide
-    -- env lives in ghc's versionedAppDir/environments/default
-    findLocalEnvFile :: MaybeT IO FilePath
-    findLocalEnvFile = do
-        curdir  <- liftMaybeT getCurrentDirectory
-        homedir <- tryMaybeT getHomeDirectory
-        let probe dir | isDrive dir || dir == homedir
-                      = mzero
-            probe dir = do
-              let file = dir </> localEnvFileName
-              exists <- liftMaybeT (doesFileExist file)
-              if exists
-                then return file
-                else probe (takeDirectory dir)
-        probe curdir
-
-    -- Error reporting
-
-    cmdLineError :: String -> MaybeT IO a
-    cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
-      "Package environment " ++ show env ++ " not found"
-
-    envError :: String -> MaybeT IO a
-    envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
-         "Package environment "
-      ++ show env
-      ++ " (specified in GHC_ENVIRONMENT) not found"
 
 -- | An error thrown if the GHC API is used in an incorrect fashion.
 newtype GhcApiError = GhcApiError String
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index f75a5e0d92..33bc1630e1 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -220,7 +220,6 @@ import GHC.Platform
 import GHC.Platform.Ways
 import GHC.Platform.Profile
 
-import GHC.UniqueSubdir (uniqueSubdir)
 import GHC.Unit.Types
 import GHC.Unit.Parser
 import GHC.Unit.Module
@@ -285,6 +284,9 @@ import qualified GHC.Data.EnumSet as EnumSet
 import GHC.Foreign (withCString, peekCString)
 import qualified GHC.LanguageExtensions as LangExt
 
+import qualified GHC.EnvironmentFiles as E
+import GHC.AppDir
+
 -- Note [Updating flag description in the User's Guide]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
@@ -887,32 +889,7 @@ opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags
 opt_i                 :: DynFlags -> [String]
 opt_i dflags= toolSettings_opt_i $ toolSettings dflags
 
--- | The directory for this version of ghc in the user's app directory
--- The appdir used to be in ~/.ghc but to respect the XDG specification
--- we want to move it under $XDG_DATA_HOME/
--- However, old tooling (like cabal) might still write package environments
--- to the old directory, so we prefer that if a subdirectory of ~/.ghc
--- with the correct target and GHC version suffix exists.
---
--- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that
--- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR
---
--- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version
-versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath
-versionedAppDir appname platform = do
-  -- Make sure we handle the case the HOME isn't set (see #11678)
-  -- We need to fallback to the old scheme if the subdirectory exists.
-  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))
-       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/
-       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/
-       ]
-  where
-    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case
-      True -> pure dir
-      False -> MaybeT (pure Nothing)
 
-versionedFilePath :: ArchOS -> FilePath
-versionedFilePath platform = uniqueSubdir platform
 
 -- | The 'GhcMode' tells us whether we're doing multi-module
 -- compilation (controlled via the "GHC" API) or one-shot
@@ -4422,31 +4399,21 @@ addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}
 -- -----------------------------------------------------------------------------
 -- Load dynflags from environment files.
 
-setFlagsFromEnvFile :: FilePath -> String -> DynP ()
-setFlagsFromEnvFile envfile content = do
+setFlagsFromEnvFile :: E.PackageEnvironment -> DynP ()
+setFlagsFromEnvFile (E.PackageEnvironment envfile) = do
   setGeneralFlag Opt_HideAllPackages
-  parseEnvFile envfile content
+  mapM_ run_package_env envfile
 
-parseEnvFile :: FilePath -> String -> DynP ()
-parseEnvFile envfile = mapM_ parseEntry . lines
   where
-    parseEntry str = case words str of
-      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))
-        -- relative package dbs are interpreted relative to the env file
-        where envdir = takeDirectory envfile
-              db     = drop 11 str
-      ["clear-package-db"]  -> clearPkgDb
-      ["hide-package", pkg]  -> hidePackage pkg
-      ["global-package-db"] -> addPkgDbRef GlobalPkgDb
-      ["user-package-db"]   -> addPkgDbRef UserPkgDb
-      ["package-id", pkgid] -> exposePackageId pkgid
-      (('-':'-':_):_)       -> return () -- comments
-      -- and the original syntax introduced in 7.10:
-      [pkgid]               -> exposePackageId pkgid
-      []                    -> return ()
-      _                     -> throwGhcException $ CmdLineError $
-                                    "Can't parse environment file entry: "
-                                 ++ envfile ++ ": " ++ str
+    run_package_env cmd =
+      case cmd of
+        E.ClearPackageDb -> clearPkgDb
+        E.PackageDb db   -> addPkgDbRef (PkgDbPath db)
+        E.PackageId pkg  -> exposePackageId pkg
+        E.HidePackage pkg -> hidePackage pkg
+        E.GlobalPackageDb    -> addPkgDbRef GlobalPkgDb
+        E.UserPackageDb      -> addPkgDbRef UserPkgDb
+
 
 
 -----------------------------------------------------------------------------
diff --git a/libraries/ghc-boot/GHC/AppDir.hs b/libraries/ghc-boot/GHC/AppDir.hs
new file mode 100644
index 0000000000..81e5ff0780
--- /dev/null
+++ b/libraries/ghc-boot/GHC/AppDir.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE LambdaCase #-}
+module GHC.AppDir where
+
+import Prelude
+import GHC.Platform.ArchOS
+import Control.Monad.Trans.Maybe
+import Control.Monad
+import System.Directory
+import System.FilePath
+import GHC.UniqueSubdir
+import Control.Exception
+
+-- | The directory for this version of ghc in the user's app directory
+-- The appdir used to be in ~/.ghc but to respect the XDG specification
+-- we want to move it under $XDG_DATA_HOME/
+-- However, old tooling (like cabal) might still write package environments
+-- to the old directory, so we prefer that if a subdirectory of ~/.ghc
+-- with the correct target and GHC version suffix exists.
+--
+-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that
+-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR
+--
+-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version
+versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath
+versionedAppDir appname platform = do
+  -- Make sure we handle the case the HOME isn't set (see #11678)
+  -- We need to fallback to the old scheme if the subdirectory exists.
+  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))
+       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/
+       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/
+       ]
+  where
+    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case
+      True -> pure dir
+      False -> MaybeT (pure Nothing)
+
+versionedFilePath :: ArchOS -> FilePath
+versionedFilePath platform = uniqueSubdir platform
+
+-- | Try performing an 'IO' action, failing on error.
+tryMaybeT :: IO a -> MaybeT IO a
+tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler
+  where
+    handler (SomeException _) = return Nothing
diff --git a/libraries/ghc-boot/GHC/EnvironmentFiles.hs b/libraries/ghc-boot/GHC/EnvironmentFiles.hs
new file mode 100644
index 0000000000..947d5089fd
--- /dev/null
+++ b/libraries/ghc-boot/GHC/EnvironmentFiles.hs
@@ -0,0 +1,193 @@
+-- | Logic for finding and parsing environemnt files
+module GHC.EnvironmentFiles where
+
+import GHC.Platform.ArchOS
+import GHC.AppDir
+import Prelude
+import Control.Monad.Trans.Maybe
+import Control.Monad.IO.Class
+import Control.Monad
+import System.Directory
+import System.FilePath
+import Control.Exception
+import Data.Maybe
+import System.IO.Error
+import System.Environment
+
+data PackageEnvironment = PackageEnvironment [PackageFlag] deriving Show
+
+
+-- -----------------------------------------------------------------------------
+-- | Find the package environment (if one exists)
+--
+-- We interpret the package environment as a set of package flags; to be
+-- specific, if we find a package environment file like
+--
+-- > clear-package-db
+-- > global-package-db
+-- > package-db blah/package.conf.d
+-- > package-id id1
+-- > package-id id2
+--
+-- we interpret this as
+--
+-- > [ -hide-all-packages
+-- > , -clear-package-db
+-- > , -global-package-db
+-- > , -package-db blah/package.conf.d
+-- > , -package-id id1
+-- > , -package-id id2
+-- > ]
+--
+-- There's also an older syntax alias for package-id, which is just an
+-- unadorned package id
+--
+-- > id1
+-- > id2
+--
+findPackageEnv :: (String -> IO ()) -> Maybe String -> Bool -> String -> ArchOS -> IO (Maybe PackageEnvironment)
+findPackageEnv logger packageEnv hide_all_packages prog_name archOS = do
+    mPkgEnv <- runMaybeT $ msum $ [
+                   getCmdLineArg >>= \env -> msum [
+                       probeNullEnv env
+                     , probeEnvFile env
+                     , probeEnvName env
+                     , cmdLineError env
+                     ]
+                 , getEnvVar >>= \env -> msum [
+                       probeNullEnv env
+                     , probeEnvFile env
+                     , probeEnvName env
+                     , envError     env
+                     ]
+                 , notIfHideAllPackages >> msum [
+                       findLocalEnvFile >>= probeEnvFile
+                     , probeEnvName defaultEnvName
+                     ]
+                 ]
+    case mPkgEnv of
+      Nothing ->
+        -- No environment found. Leave DynFlags unchanged.
+        return Nothing
+      Just "-" -> do
+        -- Explicitly disabled environment file. Leave DynFlags unchanged.
+        return Nothing
+      Just envfile -> do
+        content <- readFile envfile
+        logger ("Loaded package environment from " ++ envfile)
+        let res = parseEnvFile envfile content
+        case res of
+          Left err -> error err
+          Right p_e -> return (Just p_e)
+--        let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
+
+ --       return dflags'
+  where
+    -- Loading environments (by name or by location)
+
+--    archOS = platformArchOS (targetPlatform dflags)
+
+    namedEnvPath :: String -> MaybeT IO FilePath
+    namedEnvPath name = do
+     appdir <- versionedAppDir prog_name archOS
+     return $ appdir </> "environments" </> name
+
+    probeEnvName :: String -> MaybeT IO FilePath
+    probeEnvName name = probeEnvFile =<< namedEnvPath name
+
+    probeEnvFile :: FilePath -> MaybeT IO FilePath
+    probeEnvFile path = do
+      guard =<< liftIO (doesFileExist path)
+      return path
+
+    probeNullEnv :: FilePath -> MaybeT IO FilePath
+    probeNullEnv "-" = return "-"
+    probeNullEnv _   = mzero
+    -- Various ways to define which environment to use
+
+    getCmdLineArg :: MaybeT IO String
+    getCmdLineArg = MaybeT $ return packageEnv
+
+    getEnvVar :: MaybeT IO String
+    getEnvVar = do
+      mvar <- liftIO $ try $ getEnv "GHC_ENVIRONMENT"
+      case mvar of
+        Right var -> return var
+        Left err  -> if isDoesNotExistError err then mzero
+                                                else liftIO $ throwIO err
+
+    notIfHideAllPackages :: MaybeT IO ()
+    notIfHideAllPackages =
+      guard (not hide_all_packages)
+
+    defaultEnvName :: String
+    defaultEnvName = "default"
+
+    -- e.g. .ghc.environment.x86_64-linux-7.6.3
+    localEnvFileName :: FilePath
+    localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS
+
+    -- Search for an env file, starting in the current dir and looking upwards.
+    -- Fail if we get to the users home dir or the filesystem root. That is,
+    -- we don't look for an env file in the user's home dir. The user-wide
+    -- env lives in ghc's versionedAppDir/environments/default
+    findLocalEnvFile :: MaybeT IO FilePath
+    findLocalEnvFile = do
+        curdir  <- liftIO getCurrentDirectory
+        homedir <- tryMaybeT getHomeDirectory
+        let probe dir | isDrive dir || dir == homedir
+                      = mzero
+            probe dir = do
+              let file = dir </> localEnvFileName
+              exists <- liftIO (doesFileExist file)
+              if exists
+                then return file
+                else probe (takeDirectory dir)
+        probe curdir
+
+    -- Error reporting
+
+    cmdLineError :: String -> MaybeT IO a
+    cmdLineError env = liftIO . ioError $
+      mkIOError doesNotExistErrorType
+        ("Package environment " ++ show env ++ " not found")
+        Nothing
+        (Just env)
+
+    envError :: String -> MaybeT IO a
+    envError env = liftIO . ioError $
+      mkIOError doesNotExistErrorType
+        ( ("Package environment "
+        ++ show env
+        ++ " (specified in GHC_ENVIRONMENT) not found") )
+        Nothing
+        (Just env)
+
+data PackageFlag = PackageDb String
+                 | ClearPackageDb
+                 | HidePackage String
+                 | GlobalPackageDb
+                 | UserPackageDb
+                 | PackageId String
+                 deriving Show
+
+parseEnvFile :: FilePath -> String -> Either String PackageEnvironment
+parseEnvFile envfile = fmap (PackageEnvironment . catMaybes) . mapM parseEntry . lines
+  where
+    parseEntry str = case words str of
+      ("package-db": _)     -> return (Just (PackageDb (envdir </> db)))
+        -- relative package dbs are interpreted relative to the env file
+        where envdir = takeDirectory envfile
+              db     = drop 11 str
+      ["clear-package-db"]  -> return (Just ClearPackageDb)
+      ["hide-package", pkg] -> return (Just (HidePackage pkg))
+      ["global-package-db"] -> return (Just GlobalPackageDb)
+      ["user-package-db"]   -> return (Just UserPackageDb)
+      ["package-id", pkgid] -> return (Just (PackageId pkgid))
+      (('-':'-':_):_)       -> return Nothing -- comments
+      -- and the original syntax introduced in 7.10:
+      [pkgid]               -> return (Just (PackageId pkgid))
+      []                    -> return Nothing
+      _                     -> Left $
+                                    "Can't parse environment file entry: "
+                                 ++ envfile ++ ": " ++ str
diff --git a/libraries/ghc-boot/GHC/Settings/Utils.hs b/libraries/ghc-boot/GHC/Settings/Utils.hs
index 4ccbbf23b6..266fdbf17f 100644
--- a/libraries/ghc-boot/GHC/Settings/Utils.hs
+++ b/libraries/ghc-boot/GHC/Settings/Utils.hs
@@ -70,3 +70,5 @@ readRawSetting settingsFile settings key = case Map.lookup key settings of
     Just v -> Right v
     Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs
   Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
+
+
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index efac404501..b0ce0d066a 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -55,6 +55,8 @@ Library
             GHC.Settings.Utils
             GHC.UniqueSubdir
             GHC.Version
+            GHC.AppDir
+            GHC.EnvironmentFiles
 
     -- reexport modules from ghc-boot-th so that packages don't have to import
     -- both ghc-boot and ghc-boot-th. It makes the dependency graph easier to
@@ -76,6 +78,7 @@ Library
                    directory  >= 1.2 && < 1.4,
                    filepath   >= 1.3 && < 1.5,
                    deepseq    >= 1.4 && < 1.5,
+                   transformers,
                    ghc-boot-th == @ProjectVersionMunged@
     if !os(windows)
         build-depends:
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 7bc14094d1..5e820c783f 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -30,13 +30,16 @@
 
 module Main (main) where
 
+import GHC.EnvironmentFiles
+import GHC.Platform.ArchOS
+import GHC.AppDir
+import Control.Monad.Trans.Maybe
 import qualified GHC.Unit.Database as GhcPkg
 import GHC.Unit.Database hiding (mkMungePathUrl)
 import GHC.HandleEncoding
 import GHC.BaseDir (getBaseDir)
 import GHC.Settings.Utils (getTargetArchOS, maybeReadFuzzy)
 import GHC.Platform.Host (hostPlatformArchOS)
-import GHC.UniqueSubdir (uniqueSubdir)
 import qualified GHC.Data.ShortText as ST
 import GHC.Version ( cProjectVersion )
 import qualified Distribution.Simple.PackageIndex as PackageIndex
@@ -58,8 +61,8 @@ import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File)
 import qualified Data.Version as Version
 import System.FilePath as FilePath
 import qualified System.FilePath.Posix as FilePath.Posix
-import System.Directory ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory,
-                          getModificationTime, XdgDirectory ( XdgData ) )
+import System.Directory ( createDirectoryIfMissing,
+                          getModificationTime )
 import Text.Printf
 
 import Prelude
@@ -123,6 +126,9 @@ anyM p (x:xs) = do
     then return True
     else anyM p xs
 
+getPackageEnv :: (String -> IO ()) -> Maybe FilePath -> ArchOS -> IO (Maybe PackageEnvironment)
+getPackageEnv logger mb_db target_os = findPackageEnv logger mb_db False "ghc" target_os
+
 -- -----------------------------------------------------------------------------
 -- Entry point
 
@@ -130,7 +136,6 @@ main :: IO ()
 main = do
   configureHandleEncoding
   args <- getArgs
-
   case getOpt Permute (flags ++ deprecFlags) args of
         (cli,_,[]) | FlagHelp `elem` cli -> do
            prog <- getProgramName
@@ -156,6 +161,7 @@ data Flag
   | FlagConfig FilePath
   | FlagGlobalConfig FilePath
   | FlagUserConfig FilePath
+  | FlagPackageEnv FilePath
   | FlagForce
   | FlagForceFiles
   | FlagMultiInstance
@@ -189,6 +195,8 @@ flags = [
         "location of the user package database (use instead of default)",
   Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
         "never read the user package database (DEPRECATED)",
+  Option [] ["package-env"] (ReqArg FlagPackageEnv "FILE/DIR")
+        "use the specified package environment file",
   Option [] ["force"] (NoArg FlagForce)
          "ignore missing dependencies, directories, and libraries",
   Option [] ["force-files"] (NoArg FlagForceFiles)
@@ -590,6 +598,20 @@ allPackagesInStack = concatMap packages
 stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack
 stackUpTo to_modify = dropWhile ((/= to_modify) . location)
 
+-- An environment file provides a complete specification about the visible packages
+parseEnvironmentFile :: PackageEnvironment -> ([String], Bool, Bool)
+parseEnvironmentFile (PackageEnvironment env) = foldl' go start_state env
+  where
+    start_state = ([], False, False)
+
+    go _ ClearPackageDb = start_state
+    go (dbs, gbl, lcl) (PackageDb s) = (s:dbs, gbl, lcl)
+    go (dbs, _, lcl) GlobalPackageDb = (dbs, True, lcl)
+    go (dbs, gbl, _) UserPackageDb = (dbs, gbl, True)
+    -- Ignore package ids
+    go db_env _ = db_env
+
+
 getPkgDatabases :: Verbosity
                 -> GhcPkg.DbOpenMode mode DbModifySelector
                 -> Bool    -- use the user db
@@ -626,6 +648,8 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
                        Just path -> return path
         fs -> return (last fs)
 
+
+
   -- The value of the $topdir variable used in some package descriptions
   -- Note that the way we calculate this is slightly different to how it
   -- is done in ghc itself. We rely on the convention that the global
@@ -634,6 +658,26 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
 
   let no_user_db = FlagNoUserDb `elem` my_flags
 
+  -- See Note [Settings file] about this file, and why we need GHC to share it with us.
+  let settingsFile = top_dir </> "settings"
+  exists_settings_file <- doesFileExist settingsFile
+  targetArchOS <- case exists_settings_file of
+    False -> do
+      warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
+      warn "cannot know target platform so guessing target == host (native compiler)."
+      pure hostPlatformArchOS
+    True -> do
+      settingsStr <- readFile settingsFile
+      mySettings <- case maybeReadFuzzy settingsStr of
+        Just s -> pure $ Map.fromList s
+        -- It's excusable to not have a settings file (for now at
+        -- least) but completely inexcusable to have a malformed one.
+        Nothing -> die $ "Can't parse settings file " ++ show settingsFile
+      case getTargetArchOS settingsFile mySettings of
+        Right archOS -> pure archOS
+        Left e -> die e
+
+
   -- get the location of the user package database, and create it if necessary
   -- getXdgDirectory can fail (e.g. if $HOME isn't set)
 
@@ -641,45 +685,9 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
     case [ f | FlagUserConfig f <- my_flags ] of
       _ | no_user_db -> return Nothing
       [] -> do
-        -- See Note [Settings file] about this file, and why we need GHC to share it with us.
-        let settingsFile = top_dir </> "settings"
-        exists_settings_file <- doesFileExist settingsFile
-        targetArchOS <- case exists_settings_file of
-          False -> do
-            warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
-            warn "cannot know target platform so guessing target == host (native compiler)."
-            pure hostPlatformArchOS
-          True -> do
-            settingsStr <- readFile settingsFile
-            mySettings <- case maybeReadFuzzy settingsStr of
-              Just s -> pure $ Map.fromList s
-              -- It's excusable to not have a settings file (for now at
-              -- least) but completely inexcusable to have a malformed one.
-              Nothing -> die $ "Can't parse settings file " ++ show settingsFile
-            case getTargetArchOS settingsFile mySettings of
-              Right archOS -> pure archOS
-              Left e -> die e
-        let subdir = uniqueSubdir targetArchOS
-
-            getFirstSuccess :: [IO a] -> IO (Maybe a)
-            getFirstSuccess [] = pure Nothing
-            getFirstSuccess (a:as) = tryIO a >>= \case
-              Left _ -> getFirstSuccess as
-              Right d -> pure (Just d)
-        -- The appdir used to be in ~/.ghc but to respect the XDG specification
-        -- we want to move it under $XDG_DATA_HOME/
-        -- However, old tooling (like cabal) might still write package environments
-        -- to the old directory, so we prefer that if a subdirectory of ~/.ghc
-        -- with the correct target and GHC version exists.
-        --
-        -- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we prefer that
-        -- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR
-        --
-        -- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version
-        m_appdir <- getFirstSuccess $ map (fmap (</> subdir))
-          [ getAppUserDataDirectory "ghc"  -- this is ~/.ghc/
-          , getXdgDirectory XdgData "ghc"  -- this is $XDG_DATA_HOME/
-          ]
+
+        m_appdir <- runMaybeT $ versionedAppDir "ghc" targetArchOS
+
         case m_appdir of
           Nothing -> return Nothing
           Just dir -> do
@@ -688,14 +696,33 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
               Just f  -> return (Just (f, True))
       fs -> return (Just (last fs, True))
 
+  let mb_packageenv = listToMaybe [ fp | FlagPackageEnv fp <- my_flags ]
+      output s = if verbosity /= Silent then info s else return ()
+  package_env <- getPackageEnv output mb_packageenv targetArchOS
+
   -- If the user database exists, and for "use_user" commands (which includes
   -- "ghc-pkg check" and all commands that modify the db) we will attempt to
   -- use the user db.
-  let sys_databases
+  let default_sys_databases
         | Just (user_conf,user_exists) <- mb_user_conf,
           use_user || user_exists = [user_conf, global_conf]
         | otherwise               = [global_conf]
 
+      pkg_env_sys_databases pkg_flags =
+        let (pkg_dbs, gbl, lcl) = parseEnvironmentFile pkg_flags
+            lcl_db
+              | Just (user_conf, user_exists) <- mb_user_conf
+              , lcl
+              , use_user || user_exists = Just user_conf
+              | otherwise = Nothing
+            gbl_db | gbl = Just global_conf
+                   | otherwise = Nothing
+        in pkg_dbs ++ catMaybes [lcl_db, gbl_db]
+
+  let sys_databases = case package_env of
+                       Nothing -> default_sys_databases
+                       Just env_flags -> pkg_env_sys_databases env_flags
+
   e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
   let env_stack =
         case e_pkg_path of
diff --git a/utils/ghc-pkg/ghc-pkg.cabal.in b/utils/ghc-pkg/ghc-pkg.cabal.in
index 4d9402c2d3..33b5617299 100644
--- a/utils/ghc-pkg/ghc-pkg.cabal.in
+++ b/utils/ghc-pkg/ghc-pkg.cabal.in
@@ -34,7 +34,8 @@ Executable ghc-pkg
                    Cabal-syntax,
                    binary,
                    ghc-boot,
-                   bytestring
+                   bytestring,
+                   transformers
     if !os(windows) && flag(terminfo)
         Build-Depends: terminfo
         Cpp-Options: -DWITH_TERMINFO