summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hadrian/src/Builder.hs2
-rw-r--r--hadrian/src/Hadrian/Builder.hs4
-rw-r--r--hadrian/src/Hadrian/Expression.hs8
-rw-r--r--hadrian/src/Hadrian/Haskell/Cabal/Parse.hs6
-rw-r--r--hadrian/src/Main.hs31
-rw-r--r--hadrian/src/Rules/Test.hs2
6 files changed, 27 insertions, 26 deletions
diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs
index e4b9628ffb..4e488504ac 100644
--- a/hadrian/src/Builder.hs
+++ b/hadrian/src/Builder.hs
@@ -308,7 +308,7 @@ instance H.Builder Builder where
-- xelatex produces an incredible amount of output, almost
-- all of which is useless. Suppress it unless user
-- requests a loud build.
- if verbosity >= Verbose
+ if verbosity >= Diagnostic
then cmd' [Cwd output] [path] buildArgs
else do (Stdouterr out, Exit code) <- cmd' [Cwd output] [path] buildArgs
when (code /= ExitSuccess) $ do
diff --git a/hadrian/src/Hadrian/Builder.hs b/hadrian/src/Hadrian/Builder.hs
index 4a3b63b88e..1f8f8595fa 100644
--- a/hadrian/src/Hadrian/Builder.hs
+++ b/hadrian/src/Hadrian/Builder.hs
@@ -121,8 +121,8 @@ doWith f info rs opts target args = do
argList <- interpret target args
trackArgsHash target -- Rerun the rule if the hash of argList has changed.
info target
- verbose <- interpret target verboseCommand
- let quietlyUnlessVerbose = if verbose then withVerbosity Verbose else quietly
+ verbose <- getVerbosity
+ let quietlyUnlessVerbose = if verbose >= Diagnostic then withVerbosity Diagnostic else quietly
quietlyUnlessVerbose $ f (builder target) $
BuildInfo { buildArgs = argList
, buildInputs = inputs target
diff --git a/hadrian/src/Hadrian/Expression.hs b/hadrian/src/Hadrian/Expression.hs
index 6630a65c7a..6effc968d7 100644
--- a/hadrian/src/Hadrian/Expression.hs
+++ b/hadrian/src/Hadrian/Expression.hs
@@ -7,7 +7,7 @@ module Hadrian.Expression (
expr, exprIO, arg, remove,
-- ** Predicates
- (?), input, inputs, output, outputs, VerboseCommand (..), verboseCommand,
+ (?), input, inputs, output, outputs,
ToPredicate(..),
-- ** Evaluation
@@ -145,9 +145,3 @@ output f = any (f ?==) <$> getOutputs
-- | Does any of the output files match any of the given patterns?
outputs :: [FilePattern] -> Predicate c b
outputs = anyM output
-
-newtype VerboseCommand c b = VerboseCommand { predicate :: Predicate c b }
- deriving Typeable
-
-verboseCommand :: (ShakeValue c, ShakeValue b) => Predicate c b
-verboseCommand = predicate =<< expr (userSetting . VerboseCommand $ return False)
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
index 49f5aa8802..d34951a5ef 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -154,7 +154,7 @@ configurePackage context@Context {..} = do
verbosity <- getVerbosity
when (verbosity >= Verbose) $
putProgressInfo $ "| Package " ++ quote (pkgName package) ++ " configuration flags: " ++ unwords argList
- let v = if verbosity >= Verbose then "-v3" else "-v0"
+ let v = if verbosity >= Diagnostic then "-v3" else "-v0"
traced "cabal-configure" $
C.defaultMainWithHooksNoReadArgs hooks gpd
(argList ++ ["--flags=" ++ unwords flagList, v])
@@ -175,7 +175,7 @@ copyPackage context@Context {..} = do
ctxPath <- Context.contextPath context
pkgDbPath <- packageDbPath stage
verbosity <- getVerbosity
- let v = if verbosity >= Verbose then "-v3" else "-v0"
+ let v = if verbosity >= Diagnostic then "-v3" else "-v0"
traced "cabal-copy" $
C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
[ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
@@ -187,7 +187,7 @@ registerPackage context@Context {..} = do
ctxPath <- Context.contextPath context
gpd <- pkgGenericDescription package
verbosity <- getVerbosity
- let v = if verbosity >= Verbose then "-v3" else "-v0"
+ let v = if verbosity >= Diagnostic then "-v3" else "-v0"
traced "cabal-register" $
C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
[ "register", "--builddir", ctxPath, v ]
diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs
index 78c5a385ca..bba30dfaa8 100644
--- a/hadrian/src/Main.hs
+++ b/hadrian/src/Main.hs
@@ -1,7 +1,6 @@
module Main (main) where
import Development.Shake
-import Hadrian.Expression
import Hadrian.Utilities
import Settings.Parser
import System.Directory (getCurrentDirectory)
@@ -9,6 +8,7 @@ import System.IO
import System.Exit
import System.Environment
import Control.Exception
+import Data.IORef
import qualified Base
import qualified CommandLine
@@ -31,7 +31,7 @@ main = do
argsMap <- CommandLine.cmdLineArgsMap
let extra = insertExtra UserSettings.buildProgressColour
$ insertExtra UserSettings.successColour
- $ insertExtra (VerboseCommand UserSettings.verboseCommand) argsMap
+ $ argsMap
BuildRoot buildRoot = CommandLine.lookupBuildRoot argsMap
@@ -100,23 +100,30 @@ main = do
Rules.topLevelTargets
Rules.toolArgsTarget
- handleShakeException options $ shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do
+ shake_opts_var <- newIORef options
+ handleShakeException shake_opts_var $ shakeArgsOptionsWith options CommandLine.optDescrs $ \shake_opts _ targets -> do
+ writeIORef shake_opts_var shake_opts
let targets' = filter (not . null) $ removeKVs targets
Environment.setupEnvironment
- return . Just $ if null targets'
- then rules
- else want targets' >> withoutActions rules
+ return . Just $ (shake_opts, if null targets'
+ then rules
+ else want targets' >> withoutActions rules)
-handleShakeException :: ShakeOptions -> IO a -> IO a
-handleShakeException opts shake_run = do
+handleShakeException :: IORef ShakeOptions -> IO a -> IO a
+handleShakeException shake_opts_var shake_run = do
args <- getArgs
catch (withArgs ("--exception" : args) $ shake_run) $ \(_e :: ShakeException) -> do
- hPrint stderr (shakeExceptionInner _e)
+ shake_opts <- readIORef shake_opts_var
+ let
+ FailureColour col = lookupExtra red (shakeExtra shake_opts)
+ esc = if shakeColor shake_opts then escape col else id
+ if shakeVerbosity shake_opts >= Verbose
+ then
+ hPrint stderr _e
+ else
+ hPrint stderr (shakeExceptionInner _e)
hPutStrLn stderr (esc "Build failed.")
exitFailure
- where
- FailureColour col = lookupExtra red (shakeExtra opts)
- esc = if shakeColor opts then escape col else id
escForeground :: String -> String
escForeground code = "\ESC[" ++ code ++ "m"
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index a9511ad0d4..7e19798b10 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -173,7 +173,7 @@ testRules = do
-- Execute the test target.
-- We override the verbosity setting to make sure the user can see
-- the test output: https://gitlab.haskell.org/ghc/ghc/issues/15951.
- withVerbosity Verbose $ buildWithCmdOptions env $
+ withVerbosity Diagnostic $ buildWithCmdOptions env $
target (vanillaContext Stage2 compiler) RunTest [] []
-- | Build the timeout program.
View Lorry Controller Status