diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2022-03-10 16:56:06 +0000 |
---|---|---|
committer | Matthew Pickering <matthewtpickering@gmail.com> | 2022-03-21 15:02:51 +0000 |
commit | 4ff0cae3fc7d3d4a544a376e0afce753d5759d56 (patch) | |
tree | 234f8253c4c19c29cdcde747387f785398c9ebdd | |
parent | 18b9ba5602121c75f184f29e5b3e70bd7d4779c4 (diff) | |
download | haskell-4ff0cae3fc7d3d4a544a376e0afce753d5759d56.tar.gz |
Teach ghc-pkg about environment fileswip/ghc-pkg-env-files
-rw-r--r-- | compiler/GHC.hs | 154 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 63 | ||||
-rw-r--r-- | libraries/ghc-boot/GHC/AppDir.hs | 44 | ||||
-rw-r--r-- | libraries/ghc-boot/GHC/EnvironmentFiles.hs | 193 | ||||
-rw-r--r-- | libraries/ghc-boot/GHC/Settings/Utils.hs | 2 | ||||
-rw-r--r-- | libraries/ghc-boot/ghc-boot.cabal.in | 3 | ||||
-rw-r--r-- | utils/ghc-pkg/Main.hs | 115 | ||||
-rw-r--r-- | utils/ghc-pkg/ghc-pkg.cabal.in | 3 |
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 |