From fdc35b1859c5b0781f26bb8b1754f4087f2afdbd Mon Sep 17 00:00:00 2001 From: Patrick Dougherty Date: Sat, 16 Dec 2017 20:25:50 -0600 Subject: [PATCH] Fix broken colours with `-j` (#484) * Fix colours * Simplify data types * Fix doc typo --- README.md | 2 +- circle.yml | 2 +- doc/user-settings.md | 15 ++++++- hadrian.cabal | 1 - src/Hadrian/Utilities.hs | 87 +++++++++++++++++++++++++++++++--------- src/UserSettings.hs | 5 +-- 6 files changed, 85 insertions(+), 27 deletions(-) diff --git a/README.md b/README.md index 0684380c23..23e8586461 100644 --- a/README.md +++ b/README.md @@ -43,7 +43,7 @@ on Cabal sandboxes (`build.cabal.*`), Stack (`build.stack.*`) or the global pack (`build.global-db.*`). Also see [instructions for building GHC on Windows using Stack][windows-build]. * Hadrian is written in Haskell and depends on `shake` (plus a few packages that `shake` depends on), -`ansi-terminal`, `mtl`, `quickcheck`, and GHC core libraries. +`mtl`, `quickcheck`, and GHC core libraries. * If you have never built GHC before, start with the [preparation guide][ghc-preparation]. diff --git a/circle.yml b/circle.yml index f04f4c79b4..8ca33cfba7 100644 --- a/circle.yml +++ b/circle.yml @@ -9,7 +9,7 @@ dependencies: - brew update - brew install ghc cabal-install python3 - cabal update - - cabal install alex happy ansi-terminal mtl shake quickcheck + - cabal install alex happy mtl shake quickcheck cache_directories: - $HOME/.cabal - $HOME/.ghc diff --git a/doc/user-settings.md b/doc/user-settings.md index c7190455a4..e800d51e63 100644 --- a/doc/user-settings.md +++ b/doc/user-settings.md @@ -204,9 +204,20 @@ used by default by overriding `buildProgressColour` and `successColour`: ```haskell -- | Set colour for build progress messages (e.g. executing a build command). buildProgressColour :: BuildProgressColour -buildProgressColour = BuildProgressColour (Dull, Magenta) +buildProgressColour = mkBuildProgressColour (Dull Magenta) -- | Set colour for success messages (e.g. a package is built successfully). successColour :: SuccessColour -successColour = SuccessColour (Dull, Green) +successColour = mkSuccessColour (Dull Green) +``` + +Your options are `Dull Colour`, `Vivid Colour`, or `Extended Code`. `Dull` +colours are the ANSI 8-bit colours, `Vivid` correspond to the 16-bit codes that +end with ";1", and `Extended` let's you enter a manual code for the 256 colour +set. E.g. + +``` +Dull Blue +Vivid Cyan +Extended "203" ``` diff --git a/hadrian.cabal b/hadrian.cabal index 9c170bcd16..2b6b9f9fb9 100644 --- a/hadrian.cabal +++ b/hadrian.cabal @@ -117,7 +117,6 @@ executable hadrian other-extensions: MultiParamTypeClasses , TypeFamilies build-depends: base >= 4.8 && < 5 - , ansi-terminal == 0.6.* , Cabal >= 2.0.0.2 && < 2.2 , containers == 0.5.* , directory >= 1.2 && < 1.4 diff --git a/src/Hadrian/Utilities.hs b/src/Hadrian/Utilities.hs index 1cd22b1179..7c3510fb19 100644 --- a/src/Hadrian/Utilities.hs +++ b/src/Hadrian/Utilities.hs @@ -20,10 +20,12 @@ module Hadrian.Utilities ( createDirectory, copyDirectory, moveDirectory, removeDirectory, -- * Diagnostic info - UseColour (..), putColoured, BuildProgressColour (..), putBuild, - SuccessColour (..), putSuccess, ProgressInfo (..), - putProgressInfo, renderAction, renderProgram, renderLibrary, renderBox, - renderUnicorn, + UseColour (..), Colour (..), ANSIColour (..), putColoured, + BuildProgressColour, mkBuildProgressColour, putBuild, + SuccessColour, mkSuccessColour, putSuccess, + ProgressInfo (..), putProgressInfo, + renderAction, renderProgram, renderLibrary, renderBox, renderUnicorn, + -- * Miscellaneous (<&>), (%%>), cmdLineLengthLimit, @@ -42,7 +44,7 @@ import Data.Typeable (TypeRep, typeOf) import Development.Shake hiding (Normal) import Development.Shake.Classes import Development.Shake.FilePath -import System.Console.ANSI +import System.Environment (lookupEnv) import System.Info.Extra import qualified Control.Exception.Base as IO @@ -264,43 +266,90 @@ removeDirectory dir = do data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable) +-- | Terminal output colours +data Colour + = Dull ANSIColour -- ^ 8-bit ANSI colours + | Vivid ANSIColour -- ^ 16-bit vivid ANSI colours + | Extended String -- ^ Extended 256-bit colours, manual code stored + +-- | ANSI terminal colours +data ANSIColour + = Black -- ^ ANSI code: 30 + | Red -- ^ 31 + | Green -- ^ 32 + | Yellow -- ^ 33 + | Blue -- ^ 34 + | Magenta -- ^ 35 + | Cyan -- ^ 36 + | White -- ^ 37 + | Reset -- ^ 0 + +-- | Convert ANSI colour names into their associated codes +colourCode :: ANSIColour -> String +colourCode Black = "30" +colourCode Red = "31" +colourCode Green = "32" +colourCode Yellow = "33" +colourCode Blue = "34" +colourCode Magenta = "35" +colourCode Cyan = "36" +colourCode White = "37" +colourCode Reset = "0" + +-- | Create the final ANSI code. +mkColour :: Colour -> String +mkColour (Dull c) = colourCode c +mkColour (Vivid c) = colourCode c ++ ";1" +mkColour (Extended code) = "38;5;" ++ code + -- | A more colourful version of Shake's 'putNormal'. -putColoured :: ColorIntensity -> Color -> String -> Action () -putColoured intensity colour msg = do +putColoured :: String -> String -> Action () +putColoured code msg = do useColour <- userSetting Never - supported <- liftIO $ hSupportsANSI IO.stdout + 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 - when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour] - putNormal msg - when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout + if c useColour + then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m" + else putNormal msg + where + isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" -newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color) +newtype BuildProgressColour = BuildProgressColour String deriving Typeable +-- | Generate an encoded colour for progress output from names. +mkBuildProgressColour :: Colour -> BuildProgressColour +mkBuildProgressColour c = BuildProgressColour $ mkColour c + -- | Default 'BuildProgressColour'. magenta :: BuildProgressColour -magenta = BuildProgressColour (Dull, Magenta) +magenta = mkBuildProgressColour (Dull Magenta) -- | Print a build progress message (e.g. executing a build command). putBuild :: String -> Action () putBuild msg = do - BuildProgressColour (intensity, colour) <- userSetting magenta - putColoured intensity colour msg + BuildProgressColour code <- userSetting magenta + putColoured code msg -newtype SuccessColour = SuccessColour (ColorIntensity, Color) +newtype SuccessColour = SuccessColour String deriving Typeable +-- | Generate an encoded colour for successful output from names +mkSuccessColour :: Colour -> SuccessColour +mkSuccessColour c = SuccessColour $ mkColour c + -- | Default 'SuccessColour'. green :: SuccessColour -green = SuccessColour (Dull, Green) +green = mkSuccessColour (Dull Green) -- | Print a success message (e.g. a package is built successfully). putSuccess :: String -> Action () putSuccess msg = do - SuccessColour (intensity, colour) <- userSetting green - putColoured intensity colour msg + SuccessColour code <- userSetting green + putColoured code msg data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable) diff --git a/src/UserSettings.hs b/src/UserSettings.hs index 1b7c3f8bdd..a1a82dc598 100644 --- a/src/UserSettings.hs +++ b/src/UserSettings.hs @@ -8,7 +8,6 @@ module UserSettings ( ) where import Hadrian.Utilities -import System.Console.ANSI import Flavour import Expression @@ -46,11 +45,11 @@ verboseCommand = do -- | Set colour for build progress messages (e.g. executing a build command). buildProgressColour :: BuildProgressColour -buildProgressColour = BuildProgressColour (Dull, Magenta) +buildProgressColour = mkBuildProgressColour (Dull Magenta) -- | Set colour for success messages (e.g. a package is built successfully). successColour :: SuccessColour -successColour = SuccessColour (Dull, Green) +successColour = mkSuccessColour (Dull Green) -- TODO: Set this flag from the command line. -- | Set this flag to 'True' to disable building Stage2 GHC (i.e. the @ghc-stage2@ -- GitLab