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
(`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].
......
......@@ -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
......
......@@ -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"
```
......@@ -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
......
......@@ -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)
......
......@@ -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@
......
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