From 5728d9faafe410d1e0c3a070bb8882721470b798 Mon Sep 17 00:00:00 2001
From: Artem Pelenitsyn <a.pelenitsyn@gmail.com>
Date: Fri, 12 Jul 2019 20:41:34 +0000
Subject: [PATCH] Sort out Hadrian colored output flags (fix #16397)
Hadrian used to have a separate flag --progress-colour to control
colored output during the build. After introduction of a Shake flag
with similar purpose Hadrian's flag became redundant. The commit removes
--progress-colour and switches to Shake's flag. The only difference
between the two is that Hadrian has special default mode when it tries
to determine if the terminal support colored output. The user can
override it using (Shake's) `--[no-]color`.
---
hadrian/README.md | 7 +++----
hadrian/src/CommandLine.hs | 24 ++----------------------
hadrian/src/Hadrian/Utilities.hs | 25 +++++++++++++------------
hadrian/src/Main.hs | 2 ++
4 files changed, 20 insertions(+), 38 deletions(-)
diff --git a/hadrian/README.md b/hadrian/README.md
index f3dcdfde0e16..113aa9ebe1ec 100644
--- a/hadrian/README.md
+++ b/hadrian/README.md
@@ -104,10 +104,9 @@ simply drop the `--freeze1` flag and Hadrian will rebuild all out-of-date files.
* `--integer-simple`: build GHC using the `integer-simple` integer library
(instead of `integer-gmp`).
-* `--progress-colour=MODE`: choose whether to use colours when printing build
-progress info. There are three settings: `never` (do not use colours), `auto`
-(attempt to detect whether the console supports colours; this is the default
-setting), and `always` (use colours).
+* `--color` and `--no-color`: choose whether to use colors when printing build
+progress info. By default, Hadrian tries to determine if the terminal supports
+colored ouput, and proceeds accordingly.
* `--progress-info=STYLE`: choose how build progress info is printed. There are
four settings: `none`, `brief` (one line per build command; this is the default
diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs
index aad616f40a9b..a62062130b3f 100644
--- a/hadrian/src/CommandLine.hs
+++ b/hadrian/src/CommandLine.hs
@@ -1,6 +1,6 @@
module CommandLine (
optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
- cmdProgressColour, cmdProgressInfo, cmdConfigure, cmdCompleteSetting,
+ cmdProgressInfo, cmdConfigure, cmdCompleteSetting,
cmdDocsArgs, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs
) where
@@ -25,7 +25,6 @@ data CommandLineArgs = CommandLineArgs
, flavour :: Maybe String
, freeze1 :: Bool
, integerSimple :: Bool
- , progressColour :: UseColour
, progressInfo :: ProgressInfo
, buildRoot :: BuildRoot
, testArgs :: TestArgs
@@ -40,7 +39,6 @@ defaultCommandLineArgs = CommandLineArgs
, flavour = Nothing
, freeze1 = False
, integerSimple = False
- , progressColour = Auto
, progressInfo = Brief
, buildRoot = BuildRoot "_build"
, testArgs = defaultTestArgs
@@ -104,18 +102,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
-readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readProgressColour ms =
- maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
- where
- go :: String -> Maybe UseColour
- go "never" = Just Never
- go "auto" = Just Auto
- go "always" = Just Always
- go _ = Nothing
- set :: UseColour -> CommandLineArgs -> CommandLineArgs
- set flag flags = flags { progressColour = flag }
-
readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readProgressInfo ms =
maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
@@ -238,8 +224,6 @@ optDescrs =
"Freeze Stage1 GHC."
, Option [] ["integer-simple"] (NoArg readIntegerSimple)
"Build GHC with integer-simple library."
- , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
- "Use colours in progress info (Never, Auto or Always)."
, Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (OptArg readDocsArg "TARGET")
@@ -307,8 +291,7 @@ cmdLineArgsMap = do
else return []
let allSettings = cliSettings ++ fileSettings
- return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
- $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
+ return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
$ insertExtra allSettings -- Accessed by Settings
@@ -335,9 +318,6 @@ lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs
cmdIntegerSimple :: Action Bool
cmdIntegerSimple = integerSimple <$> cmdLineArgs
-cmdProgressColour :: Action UseColour
-cmdProgressColour = progressColour <$> cmdLineArgs
-
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs
index 4a4061157b5f..521d2bc94656 100644
--- a/hadrian/src/Hadrian/Utilities.hs
+++ b/hadrian/src/Hadrian/Utilities.hs
@@ -21,7 +21,7 @@ module Hadrian.Utilities (
moveDirectory, removeDirectory,
-- * Diagnostic info
- UseColour (..), Colour (..), ANSIColour (..), putColoured,
+ Colour (..), ANSIColour (..), putColoured, shouldUseColor,
BuildProgressColour, mkBuildProgressColour, putBuild,
SuccessColour, mkSuccessColour, putSuccess,
ProgressInfo (..), putProgressInfo,
@@ -390,8 +390,6 @@ removeDirectory dir = do
putProgressInfo $ "| Remove directory " ++ dir
liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
-data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
-
-- | Terminal output colours
data Colour
= Dull ANSIColour -- ^ 8-bit ANSI colours
@@ -431,21 +429,24 @@ mkColour (Extended code) = "38;5;" ++ code
-- | A more colourful version of Shake's 'putNormal'.
putColoured :: String -> String -> Action ()
putColoured code msg = do
- useColour <- userSetting Never
- supported <- liftIO $ (&&) <$> IO.hIsTerminalDevice IO.stdout
- <*> (not <$> isDumb)
- let c Never = False
- c Auto = supported || IO.isWindows -- Colours do work on Windows
- c Always = True
- if c useColour
+ useColour <- shakeColor <$> getShakeOptions
+ if useColour
then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m"
else putNormal msg
- where
- isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"
newtype BuildProgressColour = BuildProgressColour String
deriving Typeable
+-- | By default, Hadrian tries to figure out if the current terminal
+-- supports colors using this function. The default can be overriden
+-- by suppling @--[no-]color@.
+shouldUseColor :: IO Bool
+shouldUseColor =
+ (&&) <$> IO.hIsTerminalDevice IO.stdout
+ <*> (not <$> isDumb)
+ where
+ isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"
+
-- | Generate an encoded colour for progress output from names.
mkBuildProgressColour :: Colour -> BuildProgressColour
mkBuildProgressColour c = BuildProgressColour $ mkColour c
diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs
index 804144aeb1ef..36920473177b 100644
--- a/hadrian/src/Main.hs
+++ b/hadrian/src/Main.hs
@@ -33,6 +33,7 @@ main = do
| CommandLine.lookupFreeze1 argsMap ]
cwd <- getCurrentDirectory
+ shakeColor <- shouldUseColor
let options :: ShakeOptions
options = shakeOptions
{ shakeChange = ChangeModtimeAndDigest
@@ -40,6 +41,7 @@ main = do
, shakeProgress = progressSimple
, shakeRebuild = rebuild
, shakeTimings = True
+ , shakeColor = shakeColor
, shakeExtra = extra
-- Setting shakeSymlink to False ensures files are copied out of
--
GitLab