Hadrian: display command line above errors (#20490)

4 files changed, 127 insertions, 18 deletions

diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs
index 975d33cbff..23b709b3c2 100644
--- a/hadrian/src/Builder.hs
+++ b/hadrian/src/Builder.hs
@@ -268,8 +268,6 @@ instance H.Builder Builder where
                 msgIn  = "[runBuilderWith] Exactly one input file expected."
                 output = fromSingleton msgOut buildOutputs
                 msgOut = "[runBuilderWith] Exactly one output file expected."
-                -- Suppress stdout depending on the Shake's verbosity setting.
-                echo = EchoStdout (verbosity >= Verbose)
                 -- Capture stdout and write it to the output file.
                 captureStdout = do
                     Stdout stdout <- cmd' [path] buildArgs
@@ -280,18 +278,18 @@ instance H.Builder Builder where
                     if useTempFile then runAr                path buildArgs
                                    else runArWithoutTempFile path buildArgs
 
-                Ar Unpack _ -> cmd' echo [Cwd output] [path] buildArgs
+                Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs
 
                 Autoreconf dir -> do
                   bash <- bashPath
-                  cmd' echo [Cwd dir] [bash, path] buildArgs
+                  cmd' [Cwd dir] [bash, path] buildArgs
 
                 Configure  dir -> do
                     -- Inject /bin/bash into `libtool`, instead of /bin/sh,
                     -- otherwise Windows breaks. TODO: Figure out why.
                     bash <- bashPath
                     let env = AddEnv "CONFIG_SHELL" bash
-                    cmd' echo env [Cwd dir] ["sh", path] buildOptions buildArgs
+                    cmd' env [Cwd dir] ["sh", path] buildOptions buildArgs
 
                 GenApply -> captureStdout
 
@@ -310,15 +308,17 @@ instance H.Builder Builder where
                     cmd' (Stdin pkgDesc) [path] (buildArgs ++ ["-"])
 
                 GhcPkg Unregister _ -> do
-                    Exit _ <- cmd' echo [path] (buildArgs ++ [input])
+                    -- unregistering is allowed to fail (e.g. when a package
+                    -- isn't already present)
+                    Exit _ <- cmd' [path] (buildArgs ++ [input])
                     return ()
 
                 HsCpp    -> captureStdout
 
-                Make dir -> cmd' echo path ["-C", dir] buildArgs
+                Make dir -> cmd' path ["-C", dir] buildArgs
 
                 Makeinfo -> do
-                  cmd' echo [path] "--no-split" [ "-o", output] [input]
+                  cmd' [path] "--no-split" [ "-o", output] [input]
 
                 Xelatex   ->
                   -- xelatex produces an incredible amount of output, almost
@@ -334,16 +334,16 @@ instance H.Builder Builder where
 
                 Makeindex -> unit $ cmd' [Cwd output] [path] (buildArgs ++ [input])
 
-                Tar _ -> cmd' buildOptions echo [path] buildArgs
+                Tar _ -> cmd' buildOptions [path] buildArgs
 
                 -- RunTest produces a very large amount of (colorised) output;
                 -- Don't attempt to capture it.
                 Testsuite RunTest -> do
-                  Exit code <- cmd echo [path] buildArgs
+                  Exit code <- cmd [path] buildArgs
                   when (code /= ExitSuccess) $ do
                     fail "tests failed"
 
-                _  -> cmd' echo [path] buildArgs
+                _  -> cmd' [path] buildArgs
 
 -- TODO: Some builders are required only on certain platforms. For example,
 -- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
@@ -442,7 +442,107 @@ applyPatch dir patch = do
     putBuild $ "| Apply patch " ++ file
     quietly $ cmd' [Cwd dir, FileStdin file] [path, "-p0"]
 
--- | Wrapper for 'cmd' that suppresses the double reporting of StdErr and
--- Stdout when a command fails.
-cmd' :: (Partial, CmdArguments args) => args :-> Action r
-cmd' = cmd [WithStderr False, WithStdout False]
+-- Note [cmd wrapper]
+-- ~~~~~~~~~~~~~~~~~~
+-- `cmd'` is a wrapper for Shake's `cmd` that allows us to customize what is
+-- output in the terminal in case of failure.
+--
+-- However `cmd` is quite a complex function because:
+--
+--  1) it relies on a CmdArguments type class to be variadic -- it can be called
+--  with any number of arguments, as long as they are valid arguments -- and to
+--  return either "Action r" or "IO r".
+--
+--  2) its behavior depends on the returned "r" type! In particular, if it has
+--  to return a value of type Exit or ExitCode, then it doesn't raise an
+--  exception if the exit code isn't 0! It also doesn't echo the command
+--  stdout/stderr if it is requested in a Stdout/Stderr/Stdouterr result. Result
+--  types are handled via CmdResult type class.
+--
+-- To wrap `cmd` while keeping its behavior, we need to replicate some of these
+-- type classes.
+--
+--  1) CmdWrap corresponds to CmdArguments except that we do our own stuff in
+--  the base case (i.e. in the instance for `Action r`).
+--
+--  2) Sadly CmdResult internals aren't exposed by Shake, so when we get a
+--  `CmdResult r => r` we can't tell anything about `r`. In particular, we can't
+--  tell if an Exit or ExitCode value is returned in `r`. So we use our own
+--  HasExit type class to provide the `hasExit` predicate that tells us if we
+--  should throw an exception as `cmd` would do in case of failure or not.
+
+
+-- | Wrapper for Shake's 'cmd'
+--
+-- See Note [cmd wrapper]
+cmd' :: (Partial, CmdWrap args) => args :-> Action r
+cmd' = cmdArgs mempty
+
+
+-- See Note [cmd wrapper]
+class HasExit a where
+  -- | Indicate if `a` is Exit or ExitCode
+  -- See Note [cmd wrapper]
+  hasExit :: a -> Bool
+
+instance HasExit ExitCode      where hasExit = const True
+instance HasExit Exit          where hasExit = const True
+instance HasExit ()            where hasExit = const False
+instance HasExit (Stdouterr a) where hasExit = const False
+instance HasExit (Stdout    a) where hasExit = const False
+
+instance (HasExit a, HasExit b) => HasExit (a,b) where
+  hasExit (a,b) = hasExit a || hasExit b
+instance (HasExit a, HasExit b, HasExit c) => HasExit (a,b,c) where
+  hasExit (a,b,c) = hasExit a || hasExit b || hasExit c
+
+class CmdWrap t where
+  cmdArgs :: Partial => CmdArgument -> t
+
+instance (IsCmdArgument a, CmdWrap r) => CmdWrap (a -> r) where
+  cmdArgs xs x = cmdArgs $ xs `mappend` toCmdArgument x
+
+instance CmdWrap CmdArgument where
+  cmdArgs = id
+
+instance (HasExit r, CmdResult r) => CmdWrap (Action r) where
+  cmdArgs (CmdArgument x) = do
+    verbosity <- getVerbosity
+
+    let real_args = mconcat
+          [ -- don't print stderr and stdout in command failure exception
+            toCmdArgument (WithStderr False)
+          , toCmdArgument (WithStdout False)
+            -- caller specified arguments come last to allow them to overload
+            -- the previous ones.
+          , CmdArgument x
+          ]
+    (Stdout out, Stderr err, cmdline :: CmdLine, Exit code, r :: r) <- cmd real_args
+
+    if hasExit r
+      -- if the caller queries the exit code of the command, we don't do
+      -- anything here. In particular we don't throw an exception.
+      -- (this is used e.g. to allow ghc-pkg to fail to unregister)
+      -- See Note [cmd wrapper]
+      then pure r
+      else do
+        -- In every case, we only print both command outputs (stdout/stderr)
+        -- onto Hadrian's stderr because Hadrian's stdout may be piped into
+        -- another process and we don't want random command output to break
+        -- this.
+        --
+        -- For example, the result of "hadrian tool:ghc/Main.hs --flavour=ghc-in-ghci"
+        -- is directly passed as arguments for ghc in "hadrian/ghci-cabal" script.
+        let dump x = liftIO (BSL.hPutStr stderr x)
+        case code of
+          ExitSuccess   -> do
+            -- Suppress stdout/stderr depending on Shake's verbosity setting
+            when (verbosity >  Silent)  (dump err)
+            when (verbosity >= Verbose) (dump out)
+            pure r
+          ExitFailure i -> do
+            putError ("Command line: " ++ fromCmdLine cmdline)
+            putError ("===> Command failed with error code: " ++ show i)
+            dump err
+            dump out
+            error "Command failed"
diff --git a/hadrian/src/Hadrian/Expression.hs b/hadrian/src/Hadrian/Expression.hs
index 6effc968d7..28a6c521b9 100644
--- a/hadrian/src/Hadrian/Expression.hs
+++ b/hadrian/src/Hadrian/Expression.hs
@@ -21,7 +21,6 @@ import Control.Monad.Extra
 import Control.Monad.Trans
 import Control.Monad.Trans.Reader
 import Development.Shake
-import Development.Shake.Classes
 
 import qualified Hadrian.Target as Target
 import Hadrian.Target (Target, target)
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 9f81ea5f41..2653a3eb97 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -12,7 +12,6 @@ import Oracles.Setting
 import Oracles.TestSettings
 import Packages
 import Settings
-import Settings.Default
 import Settings.Builders.RunTest
 import Settings.Program (programContext)
 import Target
diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs
index c3dad6d4d7..3d5a96efe4 100644
--- a/hadrian/src/Settings/Builders/Ghc.hs
+++ b/hadrian/src/Settings/Builders/Ghc.hs
@@ -196,6 +196,7 @@ commonGhcArgs = do
     way  <- getWay
     path <- getBuildPath
     stage <- getStage
+    useColor <- shakeColor <$> expr getShakeOptions
     ghcVersion <- expr $ ghcVersionH stage
     mconcat [ arg "-hisuf", arg $ hisuf way
             , arg "-osuf" , arg $  osuf way
@@ -211,7 +212,17 @@ commonGhcArgs = do
             , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs
             , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs
             , map ("-optP" ++) <$> getContextData cppOpts
-            , arg "-outputdir", arg path ]
+            , arg "-outputdir", arg path
+              -- we need to enable color explicitly because the output is
+              -- captured to be displayed after the failed command line in case
+              -- of error (#20490). GHC detects that it doesn't output to a
+              -- terminal and it disables colors if we don't do this.
+            , useColor ?
+              -- N.B. Target.trackArgument ignores this argument from the
+              -- input hash to avoid superfluous recompilation, avoiding
+              -- #18672.
+              arg "-fdiagnostics-color=always"
+            ]
 
 -- TODO: Do '-ticky' in all debug ways?
 wayGhcArgs :: Args