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

@@ -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

hadrian/src/CommandLine.hs

 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
 

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

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