Commit fdc35b18 authored by patrickdoc's avatar patrickdoc Committed by Andrey Mokhov

Fix broken colours with `-j` (#484)

* Fix colours

* Simplify data types

* Fix doc typo
parent 7d2368d7
...@@ -43,7 +43,7 @@ on Cabal sandboxes (`build.cabal.*`), Stack (`build.stack.*`) or the global pack ...@@ -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]. (`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), * 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]. * If you have never built GHC before, start with the [preparation guide][ghc-preparation].
......
...@@ -9,7 +9,7 @@ dependencies: ...@@ -9,7 +9,7 @@ dependencies:
- brew update - brew update
- brew install ghc cabal-install python3 - brew install ghc cabal-install python3
- cabal update - cabal update
- cabal install alex happy ansi-terminal mtl shake quickcheck - cabal install alex happy mtl shake quickcheck
cache_directories: cache_directories:
- $HOME/.cabal - $HOME/.cabal
- $HOME/.ghc - $HOME/.ghc
......
...@@ -204,9 +204,20 @@ used by default by overriding `buildProgressColour` and `successColour`: ...@@ -204,9 +204,20 @@ used by default by overriding `buildProgressColour` and `successColour`:
```haskell ```haskell
-- | Set colour for build progress messages (e.g. executing a build command). -- | Set colour for build progress messages (e.g. executing a build command).
buildProgressColour :: BuildProgressColour buildProgressColour :: BuildProgressColour
buildProgressColour = BuildProgressColour (Dull, Magenta) buildProgressColour = mkBuildProgressColour (Dull Magenta)
-- | Set colour for success messages (e.g. a package is built successfully). -- | Set colour for success messages (e.g. a package is built successfully).
successColour :: SuccessColour 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"
``` ```
...@@ -117,7 +117,6 @@ executable hadrian ...@@ -117,7 +117,6 @@ executable hadrian
other-extensions: MultiParamTypeClasses other-extensions: MultiParamTypeClasses
, TypeFamilies , TypeFamilies
build-depends: base >= 4.8 && < 5 build-depends: base >= 4.8 && < 5
, ansi-terminal == 0.6.*
, Cabal >= 2.0.0.2 && < 2.2 , Cabal >= 2.0.0.2 && < 2.2
, containers == 0.5.* , containers == 0.5.*
, directory >= 1.2 && < 1.4 , directory >= 1.2 && < 1.4
......
...@@ -20,10 +20,12 @@ module Hadrian.Utilities ( ...@@ -20,10 +20,12 @@ module Hadrian.Utilities (
createDirectory, copyDirectory, moveDirectory, removeDirectory, createDirectory, copyDirectory, moveDirectory, removeDirectory,
-- * Diagnostic info -- * Diagnostic info
UseColour (..), putColoured, BuildProgressColour (..), putBuild, UseColour (..), Colour (..), ANSIColour (..), putColoured,
SuccessColour (..), putSuccess, ProgressInfo (..), BuildProgressColour, mkBuildProgressColour, putBuild,
putProgressInfo, renderAction, renderProgram, renderLibrary, renderBox, SuccessColour, mkSuccessColour, putSuccess,
renderUnicorn, ProgressInfo (..), putProgressInfo,
renderAction, renderProgram, renderLibrary, renderBox, renderUnicorn,
-- * Miscellaneous -- * Miscellaneous
(<&>), (%%>), cmdLineLengthLimit, (<&>), (%%>), cmdLineLengthLimit,
...@@ -42,7 +44,7 @@ import Data.Typeable (TypeRep, typeOf) ...@@ -42,7 +44,7 @@ import Data.Typeable (TypeRep, typeOf)
import Development.Shake hiding (Normal) import Development.Shake hiding (Normal)
import Development.Shake.Classes import Development.Shake.Classes
import Development.Shake.FilePath import Development.Shake.FilePath
import System.Console.ANSI import System.Environment (lookupEnv)
import System.Info.Extra import System.Info.Extra
import qualified Control.Exception.Base as IO import qualified Control.Exception.Base as IO
...@@ -264,43 +266,90 @@ removeDirectory dir = do ...@@ -264,43 +266,90 @@ removeDirectory dir = do
data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable) 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'. -- | A more colourful version of Shake's 'putNormal'.
putColoured :: ColorIntensity -> Color -> String -> Action () putColoured :: String -> String -> Action ()
putColoured intensity colour msg = do putColoured code msg = do
useColour <- userSetting Never useColour <- userSetting Never
supported <- liftIO $ hSupportsANSI IO.stdout supported <- liftIO $ (&&) <$> IO.hIsTerminalDevice IO.stdout
<*> (not <$> isDumb)
let c Never = False let c Never = False
c Auto = supported || IO.isWindows -- Colours do work on Windows c Auto = supported || IO.isWindows -- Colours do work on Windows
c Always = True c Always = True
when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour] if c useColour
putNormal msg then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m"
when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout else putNormal msg
where
isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"
newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color) newtype BuildProgressColour = BuildProgressColour String
deriving Typeable deriving Typeable
-- | Generate an encoded colour for progress output from names.
mkBuildProgressColour :: Colour -> BuildProgressColour
mkBuildProgressColour c = BuildProgressColour $ mkColour c
-- | Default 'BuildProgressColour'. -- | Default 'BuildProgressColour'.
magenta :: BuildProgressColour magenta :: BuildProgressColour
magenta = BuildProgressColour (Dull, Magenta) magenta = mkBuildProgressColour (Dull Magenta)
-- | Print a build progress message (e.g. executing a build command). -- | Print a build progress message (e.g. executing a build command).
putBuild :: String -> Action () putBuild :: String -> Action ()
putBuild msg = do putBuild msg = do
BuildProgressColour (intensity, colour) <- userSetting magenta BuildProgressColour code <- userSetting magenta
putColoured intensity colour msg putColoured code msg
newtype SuccessColour = SuccessColour (ColorIntensity, Color) newtype SuccessColour = SuccessColour String
deriving Typeable deriving Typeable
-- | Generate an encoded colour for successful output from names
mkSuccessColour :: Colour -> SuccessColour
mkSuccessColour c = SuccessColour $ mkColour c
-- | Default 'SuccessColour'. -- | Default 'SuccessColour'.
green :: SuccessColour green :: SuccessColour
green = SuccessColour (Dull, Green) green = mkSuccessColour (Dull Green)
-- | Print a success message (e.g. a package is built successfully). -- | Print a success message (e.g. a package is built successfully).
putSuccess :: String -> Action () putSuccess :: String -> Action ()
putSuccess msg = do putSuccess msg = do
SuccessColour (intensity, colour) <- userSetting green SuccessColour code <- userSetting green
putColoured intensity colour msg putColoured code msg
data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable) data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
......
...@@ -8,7 +8,6 @@ module UserSettings ( ...@@ -8,7 +8,6 @@ module UserSettings (
) where ) where
import Hadrian.Utilities import Hadrian.Utilities
import System.Console.ANSI
import Flavour import Flavour
import Expression import Expression
...@@ -46,11 +45,11 @@ verboseCommand = do ...@@ -46,11 +45,11 @@ verboseCommand = do
-- | Set colour for build progress messages (e.g. executing a build command). -- | Set colour for build progress messages (e.g. executing a build command).
buildProgressColour :: BuildProgressColour buildProgressColour :: BuildProgressColour
buildProgressColour = BuildProgressColour (Dull, Magenta) buildProgressColour = mkBuildProgressColour (Dull Magenta)
-- | Set colour for success messages (e.g. a package is built successfully). -- | Set colour for success messages (e.g. a package is built successfully).
successColour :: SuccessColour successColour :: SuccessColour
successColour = SuccessColour (Dull, Green) successColour = mkSuccessColour (Dull Green)
-- TODO: Set this flag from the command line. -- TODO: Set this flag from the command line.
-- | Set this flag to 'True' to disable building Stage2 GHC (i.e. the @ghc-stage2@ -- | Set this flag to 'True' to disable building Stage2 GHC (i.e. the @ghc-stage2@
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment