Commit 73703d9b authored by Artem Pelenitsyn's avatar Artem Pelenitsyn Committed by Marge Bot

Hide "Loading package environment" message with -v0 (fix #16879)

parent 82abc479
Pipeline #8503 passed with stages
in 349 minutes and 55 seconds
......@@ -65,6 +65,7 @@ module DynFlags (
shouldUseHexWordLiterals,
positionIndependent,
optimisationFlags,
setFlagsFromEnvFile,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags,
......@@ -150,7 +151,7 @@ module DynFlags (
settings,
programName, projectVersion,
ghcUsagePath, ghciUsagePath, topDir, tmpDir,
versionedAppDir,
versionedAppDir, versionedFilePath,
extraGccViaCFlags, systemPackageConfig,
pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T,
pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc,
......@@ -178,7 +179,6 @@ module DynFlags (
updOptLevel,
setTmpDir,
setUnitId,
interpretPackageEnv,
canonicalizeHomeModule,
canonicalizeModuleIfHome,
......@@ -295,7 +295,6 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Control.Exception (throwIO)
import Data.Ord
import Data.Bits
......@@ -309,7 +308,7 @@ import qualified Data.Set as Set
import Data.Word
import System.FilePath
import System.Directory
import System.Environment (getEnv, lookupEnv)
import System.Environment (lookupEnv)
import System.IO
import System.IO.Error
import Text.ParserCombinators.ReadP hiding (char)
......@@ -5265,170 +5264,6 @@ canonicalizeModuleIfHome dflags mod
then canonicalizeHomeModule dflags (moduleName mod)
else mod
-- -----------------------------------------------------------------------------
-- | 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 :: DynFlags -> IO DynFlags
interpretPackageEnv 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
putLogMsg dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(text ("Loaded package environment from " ++ envfile))
let setFlags :: DynP ()
setFlags = do
setGeneralFlag Opt_HideAllPackages
parseEnvFile envfile content
(_, dflags') = runCmdLine (runEwM setFlags) dflags
return dflags'
where
-- Loading environments (by name or by location)
namedEnvPath :: String -> MaybeT IO FilePath
namedEnvPath name = do
appdir <- versionedAppDir dflags
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
parseEnvFile :: FilePath -> String -> DynP ()
parseEnvFile envfile = mapM_ parseEntry . lines
where
parseEntry str = case words str of
("package-db": _) -> addPkgConfRef (PkgConfFile (envdir </> db))
-- relative package dbs are interpreted relative to the env file
where envdir = takeDirectory envfile
db = drop 11 str
["clear-package-db"] -> clearPkgConf
["global-package-db"] -> addPkgConfRef GlobalPkgConf
["user-package-db"] -> addPkgConfRef UserPkgConf
["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
-- 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 $ 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 dflags
-- 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"
-- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored).
setTarget :: HscTarget -> DynP ()
......@@ -5477,6 +5312,35 @@ setMainIs arg
addLdInputs :: Option -> DynFlags -> DynFlags
addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}
-- -----------------------------------------------------------------------------
-- Load dynflags from environment files.
setFlagsFromEnvFile :: FilePath -> String -> DynP ()
setFlagsFromEnvFile envfile content = do
setGeneralFlag Opt_HideAllPackages
parseEnvFile envfile content
parseEnvFile :: FilePath -> String -> DynP ()
parseEnvFile envfile = mapM_ parseEntry . lines
where
parseEntry str = case words str of
("package-db": _) -> addPkgConfRef (PkgConfFile (envdir </> db))
-- relative package dbs are interpreted relative to the env file
where envdir = takeDirectory envfile
db = drop 11 str
["clear-package-db"] -> clearPkgConf
["global-package-db"] -> addPkgConfRef GlobalPkgConf
["user-package-db"] -> addPkgConfRef UserPkgConf
["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
-----------------------------------------------------------------------------
-- Paths & Libraries
......
......@@ -80,15 +80,17 @@ import Panic
import GHC.Platform
import Outputable
import Maybes
import CmdLineParser
import System.Environment ( getEnv )
import FastString
import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn )
import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg )
import Exception
import System.Directory
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import System.IO.Error ( isDoesNotExistError )
import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
......@@ -2193,3 +2195,138 @@ improveUnitId pkg_map uid =
-- in the @hs-boot@ loop-breaker.
getPackageConfigMap :: DynFlags -> PackageConfigMap
getPackageConfigMap = pkgIdMap . pkgState
-- -----------------------------------------------------------------------------
-- | 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 :: DynFlags -> IO DynFlags
interpretPackageEnv 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 dflags ("Loaded package environment from " ++ envfile)
let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
return dflags'
where
-- Loading environments (by name or by location)
namedEnvPath :: String -> MaybeT IO FilePath
namedEnvPath name = do
appdir <- versionedAppDir dflags
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 $ 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 dflags
-- 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"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment