summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/DynFlags.hs27
-rw-r--r--compiler/main/DynFlags.hs-boot6
-rw-r--r--compiler/main/ErrUtils.hs22
-rw-r--r--compiler/utils/Outputable.hs66
-rw-r--r--docs/users_guide/using.rst9
-rw-r--r--utils/mkUserGuidePart/Options/Verbosity.hs4
6 files changed, 111 insertions, 23 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 98d27d2aa9..d1819a8f46 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -40,6 +40,7 @@ module DynFlags (
DynFlags(..),
FlagSpec(..),
HasDynFlags(..), ContainsDynFlags(..),
+ OverridingBool(..), overrideWith,
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
targetRetainsAllBindings,
@@ -861,7 +862,9 @@ data DynFlags = DynFlags {
pprUserLength :: Int,
pprCols :: Int,
- useUnicode :: Bool,
+ useUnicode :: Bool,
+ useColor :: OverridingBool,
+ canUseColor :: Bool,
-- | what kind of {-# SCC #-} to add automatically
profAuto :: ProfAuto,
@@ -1239,6 +1242,17 @@ 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
+
-----------------------------------------------------------------------------
-- Ways
@@ -1441,6 +1455,7 @@ initDynFlags dflags = do
do str' <- peekCString enc cstr
return (str == str'))
`catchIOError` \_ -> return False
+ canUseColor <- return False -- FIXME: Not implemented
return dflags{
canGenerateDynamicToo = refCanGenerateDynamicToo,
nextTempSuffix = refNextTempSuffix,
@@ -1450,6 +1465,7 @@ initDynFlags dflags = do
generatedDumps = refGeneratedDumps,
nextWrapperNum = wrapperNum,
useUnicode = canUseUnicode,
+ canUseColor = canUseColor,
rtldInfo = refRtldInfo,
rtccInfo = refRtccInfo
}
@@ -1606,6 +1622,8 @@ defaultDynFlags mySettings =
pprUserLength = 5,
pprCols = 100,
useUnicode = False,
+ useColor = Auto,
+ canUseColor = False,
profAuto = NoProfAuto,
interactivePrint = Nothing,
nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",
@@ -2661,6 +2679,13 @@ dynamic_flags_deps = [
d { pprUserLength = n }))
, make_ord_flag defFlag "dppr-cols" (intSuffix (\n d ->
d { pprCols = n }))
+ , make_ord_flag defFlag "fdiagnostics-color=auto"
+ (NoArg (upd (\d -> d { useColor = Auto })))
+ , make_ord_flag defFlag "fdiagnostics-color=always"
+ (NoArg (upd (\d -> d { useColor = Always })))
+ , make_ord_flag defFlag "fdiagnostics-color=never"
+ (NoArg (upd (\d -> d { useColor = Never })))
+
-- Suppress all that is suppressable in core dumps.
-- Except for uniques, as some simplifier phases introduce new variables that
-- have otherwise identical names.
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 5cf21669bd..7d1adc0ab9 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -4,10 +4,14 @@ module DynFlags where
import Platform
data DynFlags
+data OverridingBool
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
-useUnicode :: DynFlags -> Bool
+useUnicode :: DynFlags -> Bool
useUnicodeSyntax :: DynFlags -> Bool
+useColor :: DynFlags -> OverridingBool
+canUseColor :: DynFlags -> Bool
+overrideWith :: Bool -> OverridingBool -> Bool
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index db593509c9..989834634d 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -68,6 +68,7 @@ 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
@@ -179,18 +180,25 @@ mkLocMessageAnn ann severity locn msg
let locn' = if gopt Opt_ErrorSpans dflags
then ppr locn
else ppr (srcSpanStart locn)
- in hang (locn' <> colon <+> sev_info <> opt_ann) 4 msg
+ in bold (hang (locn' <> colon <+> sevInfo <> optAnn) 4 msg)
where
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
- sev_info = case severity of
- SevWarning -> text "warning:"
- SevError -> text "error:"
- SevFatal -> text "fatal:"
- _ -> empty
+ (sevInfo, sevColor) =
+ case severity of
+ SevWarning ->
+ (coloured sevColor (text "warning:"), colBold `mappend` colMagentaFg)
+ SevError ->
+ (coloured sevColor (text "error:"), colBold `mappend` colRedFg)
+ SevFatal ->
+ (coloured sevColor (text "fatal:"), colBold `mappend` colRedFg)
+ _ ->
+ (empty, mempty)
-- Add optional information
- opt_ann = text $ maybe "" (\i -> " ["++i++"]") ann
+ optAnn = case ann of
+ Nothing -> text ""
+ Just i -> text " [" <> coloured sevColor (text i) <> text "]"
makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason err = err
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 764d99f8c7..1231ab03e5 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -38,8 +38,9 @@ module Outputable (
speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
unicodeSyntax,
- coloured, PprColour, colType, colCoerc, colDataCon,
- colBinder, bold, keyword,
+ coloured, bold, keyword, PprColour, colReset, colBold, colBlackFg,
+ colRedFg, colGreenFg, colYellowFg, colBlueFg, colMagentaFg, colCyanFg,
+ colWhiteFg, colBinder, colCoerc, colDataCon, colType,
-- * Converting 'SDoc' into strings and outputing it
printForC, printForAsm, printForUser, printForUserPartWay,
@@ -85,6 +86,7 @@ module Outputable (
import {-# SOURCE #-} DynFlags( DynFlags,
targetPlatform, pprUserLength, pprCols,
useUnicode, useUnicodeSyntax,
+ useColor, canUseColor, overrideWith,
unsafeGlobalDynFlags )
import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
@@ -107,6 +109,7 @@ 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 )
@@ -653,25 +656,55 @@ 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
-colType :: PprColour
-colType = PprColour "\27[34m"
+colReset :: PprColour
+colReset = PprColour "\27[0m"
colBold :: PprColour
colBold = PprColour "\27[;1m"
-colCoerc :: PprColour
-colCoerc = PprColour "\27[34m"
+colBlackFg :: PprColour
+colBlackFg = PprColour "\27[30m"
-colDataCon :: PprColour
-colDataCon = PprColour "\27[31m"
+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 = PprColour "\27[32m"
+colBinder = colGreenFg
-colReset :: PprColour
-colReset = PprColour "\27[0m"
+colCoerc :: PprColour
+colCoerc = colBlueFg
+
+colDataCon :: PprColour
+colDataCon = colRedFg
+
+colType :: PprColour
+colType = colBlueFg
-- | Apply the given colour\/style for the argument.
--
@@ -679,9 +712,14 @@ colReset = PprColour "\27[0m"
coloured :: PprColour -> SDoc -> SDoc
-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
coloured col@(PprColour c) sdoc =
- SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
- let ctx' = ctx{ sdocLastColour = col } in
- Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
+ sdocWithDynFlags $ \dflags ->
+ if overrideWith (canUseColor dflags) (useColor dflags)
+ then SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
+ let ctx' = ctx{ sdocLastColour = col } in
+ Pretty.zeroWidthText c
+ Pretty.<> runSDoc sdoc ctx'
+ Pretty.<> Pretty.zeroWidthText lc
+ else sdoc
bold :: SDoc -> SDoc
bold = coloured colBold
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index 1d7f52c8e6..f5761a4434 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -786,6 +786,15 @@ messages and in GHCi:
in a’
or by using the flag -fno-warn-unused-do-bind
+.. ghc-flag:: -fdiagnostics-color=(always|auto|never)
+
+ 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.)
+
.. ghc-flag:: -ferror-spans
Causes GHC to emit the full source span of the syntactic entity
diff --git a/utils/mkUserGuidePart/Options/Verbosity.hs b/utils/mkUserGuidePart/Options/Verbosity.hs
index 8a29d71b75..c187781c06 100644
--- a/utils/mkUserGuidePart/Options/Verbosity.hs
+++ b/utils/mkUserGuidePart/Options/Verbosity.hs
@@ -64,6 +64,10 @@ verbosityOptions =
, flagType = DynamicFlag
, flagReverse = "-fno-print-typechecker-elaboration"
}
+ , flag { flagName = "-fdiagnostics-color=(always|auto|never)"
+ , flagDescription = "Use colors in error messages"
+ , flagType = DynamicFlag
+ }
, flag { flagName = "-ferror-spans"
, flagDescription = "Output full span in error messages"
, flagType = DynamicFlag
View Lorry Controller Status