Commit adf27d61 authored by Rufflewind's avatar Rufflewind Committed by Ben Gamari
Browse files

Allow colors to be customized

Allow customization of diagnostic colors through the GHC_COLORS
environment variable.  Some color-related code have been refactored to
PprColour to reduce the circular dependence between DynFlags,
Outputable, ErrUtils.  Some color functions that were part of Outputable
but were never used have been deleted.

Test Plan: validate

Reviewers: austin, hvr, bgamari, dfeuer

Reviewed By: bgamari, dfeuer

Subscribers: dfeuer, rwbarton, thomie, snowleopard

Differential Revision: https://phabricator.haskell.org/D3364
parent 90d9e977
......@@ -501,6 +501,7 @@ Library
Outputable
Pair
Panic
PprColour
Pretty
State
Stream
......
......@@ -528,6 +528,7 @@ compiler_stage2_dll0_MODULES = \
PipelineMonad \
Platform \
PlatformConstants \
PprColour \
PprCore \
PrelNames \
PrelRules \
......
......@@ -42,7 +42,6 @@ module DynFlags (
DynFlags(..),
FlagSpec(..),
HasDynFlags(..), ContainsDynFlags(..),
OverridingBool(..), overrideWith,
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
targetRetainsAllBindings,
......@@ -58,6 +57,7 @@ module DynFlags (
dynFlagDependencies,
tablesNextToCode, mkTablesNextToCode,
makeDynFlagsConsistent,
shouldUseColor,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags,
......@@ -170,6 +170,7 @@ import Config
import CmdLineParser
import Constants
import Panic
import qualified PprColour as Col
import Util
import Maybes
import MonadUtils
......@@ -207,7 +208,7 @@ import qualified Data.Set as Set
import Data.Word
import System.FilePath
import System.Directory
import System.Environment (getEnv)
import System.Environment (getEnv, lookupEnv)
import System.IO
import System.IO.Error
import Text.ParserCombinators.ReadP hiding (char)
......@@ -911,6 +912,7 @@ data DynFlags = DynFlags {
useUnicode :: Bool,
useColor :: OverridingBool,
canUseColor :: Bool,
colScheme :: Col.Scheme,
-- | what kind of {-# SCC #-} to add automatically
profAuto :: ProfAuto,
......@@ -1291,16 +1293,8 @@ data DynLibLoader
data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
deriving (Show)
data OverridingBool
= Auto
| Always
| Never
deriving Show
overrideWith :: Bool -> OverridingBool -> Bool
overrideWith b Auto = b
overrideWith _ Always = True
overrideWith _ Never = False
shouldUseColor :: DynFlags -> Bool
shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags)
-----------------------------------------------------------------------------
-- Ways
......@@ -1505,6 +1499,13 @@ initDynFlags dflags = do
return (str == str'))
`catchIOError` \_ -> return False
canUseColor <- stderrSupportsAnsiColors
maybeGhcColorsEnv <- lookupEnv "GHC_COLORS"
maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"
let adjustCols (Just env) = Col.parseScheme env
adjustCols Nothing = id
let (useColor', colScheme') =
(adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)
(useColor dflags, colScheme dflags)
return dflags{
canGenerateDynamicToo = refCanGenerateDynamicToo,
nextTempSuffix = refNextTempSuffix,
......@@ -1514,7 +1515,9 @@ initDynFlags dflags = do
generatedDumps = refGeneratedDumps,
nextWrapperNum = wrapperNum,
useUnicode = canUseUnicode,
useColor = useColor',
canUseColor = canUseColor,
colScheme = colScheme',
rtldInfo = refRtldInfo,
rtccInfo = refRtccInfo
}
......@@ -1680,6 +1683,7 @@ defaultDynFlags mySettings =
useUnicode = False,
useColor = Auto,
canUseColor = False,
colScheme = Col.defaultScheme,
profAuto = NoProfAuto,
interactivePrint = Nothing,
nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",
......
......@@ -4,7 +4,6 @@ module DynFlags where
import Platform
data DynFlags
data OverridingBool
data DumpFlag
targetPlatform :: DynFlags -> Platform
......@@ -13,8 +12,6 @@ pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
useUnicode :: DynFlags -> Bool
useUnicodeSyntax :: DynFlags -> Bool
useColor :: DynFlags -> OverridingBool
canUseColor :: DynFlags -> Bool
overrideWith :: Bool -> OverridingBool -> Bool
shouldUseColor :: DynFlags -> Bool
hasPprDebug :: DynFlags -> Bool
hasNoDebugOutput :: DynFlags -> Bool
......@@ -60,6 +60,7 @@ import Bag
import Exception
import Outputable
import Panic
import qualified PprColour as Col
import SrcLoc
import DynFlags
import FastString (unpackFS)
......@@ -73,7 +74,6 @@ import Data.List
import qualified Data.Set as Set
import Data.IORef
import Data.Maybe ( fromMaybe )
import Data.Monoid ( mappend )
import Data.Ord
import Data.Time
import Control.Monad
......@@ -199,14 +199,22 @@ mkLocMessageAnn ann severity locn msg
let locn' = if gopt Opt_ErrorSpans dflags
then ppr locn
else ppr (srcSpanStart locn)
sevColour = getSeverityColour severity (colScheme dflags)
-- Add optional information
optAnn = case ann of
Nothing -> text ""
Just i -> text " [" <> coloured sevColour (text i) <> text "]"
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
prefix = locn' <> colon <+>
coloured sevColour sevText <> optAnn
in bold (hang prefix 4 msg)
where
sevColour = colBold `mappend` getSeverityColour severity
in coloured (Col.sMessage (colScheme dflags)) (hang prefix 4 msg)
where
sevText =
case severity of
SevWarning -> text "warning:"
......@@ -214,16 +222,11 @@ mkLocMessageAnn ann severity locn msg
SevFatal -> text "fatal:"
_ -> empty
-- Add optional information
optAnn = case ann of
Nothing -> text ""
Just i -> text " [" <> coloured sevColour (text i) <> text "]"
getSeverityColour :: Severity -> PprColour
getSeverityColour SevWarning = colMagentaFg
getSeverityColour SevError = colRedFg
getSeverityColour SevFatal = colRedFg
getSeverityColour _ = mempty
getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour SevWarning = Col.sWarning
getSeverityColour SevError = Col.sError
getSeverityColour SevFatal = Col.sFatal
getSeverityColour _ = const mempty
getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
......@@ -255,10 +258,6 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
fix '\0' = '\xfffd'
fix c = c
sevColour = colBold `mappend` getSeverityColour severity
marginColour = colBold `mappend` colBlueFg
row = srcSpanStartLine span
rowStr = show row
multiline = row /= srcSpanEndLine span
......@@ -267,6 +266,10 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
caretDiagnostic Nothing = empty
caretDiagnostic (Just srcLineWithNewline) =
sdocWithDynFlags $ \ dflags ->
let sevColour = getSeverityColour severity (colScheme dflags)
marginColour = Col.sMargin (colScheme dflags)
in
coloured marginColour (text marginSpace) <>
text ("\n") <>
coloured marginColour (text marginRow) <>
......
......@@ -38,9 +38,7 @@ module Outputable (
speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
unicodeSyntax,
coloured, bold, keyword, PprColour, colReset, colBold, colBlackFg,
colRedFg, colGreenFg, colYellowFg, colBlueFg, colMagentaFg, colCyanFg,
colWhiteFg, colBinder, colCoerc, colDataCon, colType,
coloured, keyword,
-- * Converting 'SDoc' into strings and outputing it
printSDoc, printSDocLn, printForUser, printForUserPartWay,
......@@ -89,8 +87,7 @@ module Outputable (
import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
targetPlatform, pprUserLength, pprCols,
useUnicode, useUnicodeSyntax,
useColor, canUseColor, overrideWith,
unsafeGlobalDynFlags )
shouldUseColor, unsafeGlobalDynFlags )
import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
......@@ -99,6 +96,7 @@ import FastString
import qualified Pretty
import Util
import Platform
import qualified PprColour as Col
import Pretty ( Doc, Mode(..) )
import Panic
import GHC.Serialized
......@@ -113,7 +111,6 @@ import Data.Int
import qualified Data.IntMap as IM
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Monoid (Monoid, mappend, mempty)
import Data.String
import Data.Word
import System.IO ( Handle )
......@@ -318,7 +315,7 @@ newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
data SDocContext = SDC
{ sdocStyle :: !PprStyle
, sdocLastColour :: !PprColour
, sdocLastColour :: !Col.PprColour
-- ^ The most recently used colour. This allows nesting colours.
, sdocDynFlags :: !DynFlags
}
......@@ -329,7 +326,7 @@ instance IsString SDoc where
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
{ sdocStyle = sty
, sdocLastColour = colReset
, sdocLastColour = Col.colReset
, sdocDynFlags = dflags
}
......@@ -438,7 +435,8 @@ printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
printSDoc mode dflags handle sty doc =
Pretty.printDoc_ mode cols handle (runSDoc doc ctx)
`finally`
Pretty.printDoc_ mode cols handle (runSDoc (coloured colReset empty) ctx)
Pretty.printDoc_ mode cols handle
(runSDoc (coloured Col.colReset empty) ctx)
where
cols = pprCols dflags
ctx = initSDocContext dflags sty
......@@ -721,81 +719,26 @@ ppWhen False _ = empty
ppUnless True _ = empty
ppUnless False doc = doc
-- | A colour\/style for use with 'coloured'.
newtype PprColour = PprColour String
-- | Allow colours to be combined (e.g. bold + red);
-- In case of conflict, right side takes precedence.
instance Monoid PprColour where
mempty = PprColour mempty
PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)
-- Colours
colReset :: PprColour
colReset = PprColour "\27[0m"
colBold :: PprColour
colBold = PprColour "\27[;1m"
colBlackFg :: PprColour
colBlackFg = PprColour "\27[30m"
colRedFg :: PprColour
colRedFg = PprColour "\27[31m"
colGreenFg :: PprColour
colGreenFg = PprColour "\27[32m"
colYellowFg :: PprColour
colYellowFg = PprColour "\27[33m"
colBlueFg :: PprColour
colBlueFg = PprColour "\27[34m"
colMagentaFg :: PprColour
colMagentaFg = PprColour "\27[35m"
colCyanFg :: PprColour
colCyanFg = PprColour "\27[36m"
colWhiteFg :: PprColour
colWhiteFg = PprColour "\27[37m"
colBinder :: PprColour
colBinder = colGreenFg
colCoerc :: PprColour
colCoerc = colBlueFg
colDataCon :: PprColour
colDataCon = colRedFg
colType :: PprColour
colType = colBlueFg
-- | Apply the given colour\/style for the argument.
--
-- Only takes effect if colours are enabled.
coloured :: PprColour -> SDoc -> SDoc
coloured col@(PprColour c) sdoc =
coloured :: Col.PprColour -> SDoc -> SDoc
coloured col@(Col.PprColour c) sdoc =
sdocWithDynFlags $ \dflags ->
if overrideWith (canUseColor dflags) (useColor dflags)
then SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
if shouldUseColor dflags
then SDoc $ \ctx@SDC{ sdocLastColour = Col.PprColour lc } ->
case ctx of
SDC{ sdocStyle = PprUser _ _ Coloured } ->
let ctx' = ctx{ sdocLastColour = col } in
Pretty.zeroWidthText c
Pretty.zeroWidthText (cReset ++ c)
Pretty.<> runSDoc sdoc ctx'
Pretty.<> Pretty.zeroWidthText lc
Pretty.<> Pretty.zeroWidthText (cReset ++ lc)
_ -> runSDoc sdoc ctx
else sdoc
bold :: SDoc -> SDoc
bold = coloured colBold
where Col.PprColour cReset = Col.colReset
keyword :: SDoc -> SDoc
keyword = bold
keyword = coloured Col.colBold
{-
************************************************************************
......
module PprColour where
import Data.Maybe (fromMaybe)
import Util (OverridingBool(..), split)
-- | A colour\/style for use with 'coloured'.
newtype PprColour = PprColour String
-- | Allow colours to be combined (e.g. bold + red);
-- In case of conflict, right side takes precedence.
instance Monoid PprColour where
mempty = PprColour mempty
PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)
colCustom :: String -> PprColour
colCustom s = PprColour ("\27[" ++ s ++ "m")
colReset :: PprColour
colReset = colCustom "0"
colBold :: PprColour
colBold = colCustom ";1"
colBlackFg :: PprColour
colBlackFg = colCustom "30"
colRedFg :: PprColour
colRedFg = colCustom "31"
colGreenFg :: PprColour
colGreenFg = colCustom "32"
colYellowFg :: PprColour
colYellowFg = colCustom "33"
colBlueFg :: PprColour
colBlueFg = colCustom "34"
colMagentaFg :: PprColour
colMagentaFg = colCustom "35"
colCyanFg :: PprColour
colCyanFg = colCustom "36"
colWhiteFg :: PprColour
colWhiteFg = colCustom "37"
data Scheme =
Scheme
{ sMessage :: PprColour
, sWarning :: PprColour
, sError :: PprColour
, sFatal :: PprColour
, sMargin :: PprColour
}
defaultScheme :: Scheme
defaultScheme =
Scheme
{ sMessage = colBold
, sWarning = colBold `mappend` colMagentaFg
, sError = colBold `mappend` colRedFg
, sFatal = colBold `mappend` colRedFg
, sMargin = colBold `mappend` colBlueFg
}
-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@
-- environment variable).
parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
parseScheme "always" (_, cs) = (Always, cs)
parseScheme "auto" (_, cs) = (Auto, cs)
parseScheme "never" (_, cs) = (Never, cs)
parseScheme input (b, cs) =
( b
, Scheme
{ sMessage = fromMaybe (sMessage cs) (lookup "message" table)
, sWarning = fromMaybe (sWarning cs) (lookup "warning" table)
, sError = fromMaybe (sError cs) (lookup "error" table)
, sFatal = fromMaybe (sFatal cs) (lookup "fatal" table)
, sMargin = fromMaybe (sMargin cs) (lookup "margin" table)
}
)
where
table = do
w <- split ':' input
let (k, v') = break (== '=') w
case v' of
'=' : v -> return (k, colCustom v)
_ -> []
......@@ -129,6 +129,10 @@ module Util (
HasCallStack,
HasDebugCallStack,
prettyCurrentCallStack,
-- * Utils for flags
OverridingBool(..),
overrideWith,
) where
#include "HsVersions.h"
......@@ -1358,3 +1362,14 @@ prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack
prettyCurrentCallStack :: HasCallStack => String
prettyCurrentCallStack = "Call stack unavailable"
#endif
data OverridingBool
= Auto
| Always
| Never
deriving Show
overrideWith :: Bool -> OverridingBool -> Bool
overrideWith b Auto = b
overrideWith _ Always = True
overrideWith _ Never = False
......@@ -638,7 +638,7 @@ messages and in GHCi:
(>>) :: ∀ (m :: * → *) a b. Monad m ⇒ m a → m b → m b
.. _pretty-printing-types:
.. ghc-flag:: -fprint-explicit-foralls
Using :ghc-flag:`-fprint-explicit-foralls` makes
......@@ -795,10 +795,23 @@ messages and in GHCi:
Causes GHC to display error messages with colors. To do this, the
terminal must have support for ANSI color codes, or else garbled text will
appear. The default value is `auto`, which means GHC will make an attempt
to detect whether terminal supports colors and choose accordingly. (Note:
the detection mechanism is not yet implemented, so colors are off by
default on all platforms.)
appear. The default value is ``auto``, which means GHC will make an
attempt to detect whether terminal supports colors and choose accordingly.
The precise color scheme is controlled by the environment variable
``GHC_COLORS`` (or ``GHC_COLOURS``). This can be set to colon-separated
list of ``key=value`` pairs. These are the default settings:
.. code-block:: none
message=1:warning=1;35:error=1;31:fatal=1;31:margin=1;34
Each value is expected to be a `Select Graphic Rendition (SGR) substring
<https://en.wikipedia.org/wiki/ANSI_escape_code#graphics>`_.
The environment variable can also be set to the magical values ``never``
or ``always``, which is equivalent to setting the corresponding
``-fdiagnostics-color`` flag but has lower precedence.
.. ghc-flag:: -f[no-]diagnostics-show-caret
......
......@@ -64,7 +64,7 @@ import SrcLoc
import qualified Lexer
import StringBuffer
import Outputable hiding ( printForUser, printForUserPartWay, bold )
import Outputable hiding ( printForUser, printForUserPartWay )
-- Other random utilities
import BasicTypes hiding ( isTopLevel )
......
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