diff options
| -rw-r--r-- | hadrian/src/Builder.hs | 2 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 2 | ||||
| -rw-r--r-- | hadrian/src/Main.hs | 27 |
3 files changed, 28 insertions, 3 deletions
diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs index 2661ba7df6..58a8dbc350 100644 --- a/hadrian/src/Builder.hs +++ b/hadrian/src/Builder.hs @@ -429,4 +429,4 @@ applyPatch dir patch = do -- | Wrapper for 'cmd' that makes sure we include both stdout and stderr in -- Shake's output when any of our builder commands fail. cmd' :: (Partial, CmdArguments args) => args :-> Action r -cmd' = cmd [WithStderr True, WithStdout True] +cmd' = cmd [WithStderr False, WithStdout False] diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs index 8bcfa6f974..3777b9ea05 100644 --- a/hadrian/src/Hadrian/Utilities.hs +++ b/hadrian/src/Hadrian/Utilities.hs @@ -24,7 +24,7 @@ module Hadrian.Utilities ( Colour (..), ANSIColour (..), putColoured, shouldUseColor, BuildProgressColour, mkBuildProgressColour, putBuild, SuccessColour, mkSuccessColour, putSuccess, - FailureColour, mkFailureColour, putFailure, + FailureColour(..), red, mkFailureColour, putFailure, ProgressInfo (..), putProgressInfo, renderAction, renderActionNoOutput, renderProgram, renderLibrary, renderBox, renderUnicorn, diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs index 25ea219404..78c5a385ca 100644 --- a/hadrian/src/Main.hs +++ b/hadrian/src/Main.hs @@ -5,6 +5,10 @@ import Hadrian.Expression import Hadrian.Utilities import Settings.Parser import System.Directory (getCurrentDirectory) +import System.IO +import System.Exit +import System.Environment +import Control.Exception import qualified Base import qualified CommandLine @@ -96,9 +100,30 @@ main = do Rules.topLevelTargets Rules.toolArgsTarget - shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do + handleShakeException options $ shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do let targets' = filter (not . null) $ removeKVs targets Environment.setupEnvironment return . Just $ if null targets' then rules else want targets' >> withoutActions rules + +handleShakeException :: ShakeOptions -> IO a -> IO a +handleShakeException opts shake_run = do + args <- getArgs + catch (withArgs ("--exception" : args) $ shake_run) $ \(_e :: ShakeException) -> do + 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" + +escNormal :: String +escNormal = "\ESC[0m" + +escape :: String -> String -> String +escape code x = escForeground code ++ x ++ escNormal + |