summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghc.mk1
-rw-r--r--compiler/main/DynFlags.hs28
-rw-r--r--compiler/main/DynFlags.hs-boot5
-rw-r--r--compiler/main/ErrUtils.hs39
-rw-r--r--compiler/utils/Outputable.hs87
-rw-r--r--compiler/utils/PprColour.hs88
-rw-r--r--compiler/utils/Util.hs15
8 files changed, 158 insertions, 106 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index fc8dcd98bf..6054d8579a 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -501,6 +501,7 @@ Library
Outputable
Pair
Panic
+ PprColour
Pretty
State
Stream
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 3f6e77ca4b..28b0001805 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -528,6 +528,7 @@ compiler_stage2_dll0_MODULES = \
PipelineMonad \
Platform \
PlatformConstants \
+ PprColour \
PprCore \
PrelNames \
PrelRules \
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 057c2c0071..927d3c46a0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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",
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 14c039aca3..5fd80fcd82 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -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
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index a9310c607c..180d18d8c9 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -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) <>
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 8a2afbec79..403c5cef73 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -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
{-
************************************************************************
diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs
new file mode 100644
index 0000000000..1b97303b93
--- /dev/null
+++ b/compiler/utils/PprColour.hs
@@ -0,0 +1,88 @@
+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)
+ _ -> []
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 30026c5016..65445e410c 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -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
View Lorry Controller Status