From bbb1f6dab34243af0a2841164e33eec451396b3f Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 7 Oct 2021 15:59:54 +0200 Subject: Hadrian: display command line above errors (#20490) --- hadrian/src/Builder.hs | 130 +++++++++++++++++++++++++++++++---- hadrian/src/Hadrian/Expression.hs | 1 - hadrian/src/Rules/Test.hs | 1 - hadrian/src/Settings/Builders/Ghc.hs | 13 +++- 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 -- cgit v1.2.1