diff options
Diffstat (limited to 'hadrian/src')
| -rw-r--r-- | hadrian/src/CommandLine.hs | 24 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 25 | ||||
| -rw-r--r-- | hadrian/src/Main.hs | 2 |
3 files changed, 17 insertions, 34 deletions
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 |