summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArtem Pelenitsyn <a.pelenitsyn@gmail.com>2019-07-12 20:41:34 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-07-16 02:40:08 -0400
commit5728d9faafe410d1e0c3a070bb8882721470b798 (patch)
tree76a820ac448f620f78f7f5ed766aa33a7b78731e
parent1befd2c00f8a8fc1ca62ef18ca3028c58e35dabd (diff)
downloadhaskell-5728d9faafe410d1e0c3a070bb8882721470b798.tar.gz
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`.
-rw-r--r--hadrian/README.md7
-rw-r--r--hadrian/src/CommandLine.hs24
-rw-r--r--hadrian/src/Hadrian/Utilities.hs25
-rw-r--r--hadrian/src/Main.hs2
4 files changed, 20 insertions, 38 deletions
diff --git a/hadrian/README.md b/hadrian/README.md
index f3dcdfde0e..113aa9ebe1 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 aad616f40a..a62062130b 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 4a4061157b..521d2bc946 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 804144aeb1..3692047317 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