diff options
Diffstat (limited to 'hadrian/src/Hadrian/Utilities.hs')
| -rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 25 |
1 files changed, 13 insertions, 12 deletions
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 |