hadrian: Rework the verbosity levels

Before we really only had two verbosity levels, normal and verbose.
There are now three levels:

Normal: Commands show stderr (no stdout) and minimal build failure messages.
Verbose (-V): Commands also show stdout, build failure message contains
              callstack and additional information
Diagnostic (-VV): Very verbose output showing all command lines and passing -v3 to cabal commands.

-V is similar to the default verbosity from before (but a little more
verbose)

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.