diff options
author | Phil Ruffwind <rf@rufflewind.com> | 2016-11-29 13:31:01 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2016-11-29 14:39:55 -0500 |
commit | f1fc8cbf511c88cb88bf9f46724ee2711f54891a (patch) | |
tree | 9f12ae546af62f79b59a85dd172b911dd12e20ee /compiler/main | |
parent | 30cecaec4701b32ab9fd6399193c5d2740b63b11 (diff) | |
download | haskell-f1fc8cbf511c88cb88bf9f46724ee2711f54891a.tar.gz |
Make diagnostics slightly more colorful
This is a preliminary commit to add colors to diagnostics (warning and
error messages). The aesthetic changes are:
- 'warning', 'error', and 'fatal' are all colored magenta, red, and
red respectively.
- The warning annotation [-Wsomething] shares the same color.
- Warnings and errors are also bolded (this is consistent with what
other compilers do).
A new flag has been added to control the behavior:
-fdiagnostics-color=(always|auto|never)
This flag is 'auto' by default. However, auto-detection is not
implemented yet, so it effectively it defaults to off.
Test Plan: validate
Reviewers: austin, bgamari
Reviewed By: bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2716
GHC Trac Issues: #8809
Diffstat (limited to 'compiler/main')
-rw-r--r-- | compiler/main/DynFlags.hs | 27 | ||||
-rw-r--r-- | compiler/main/DynFlags.hs-boot | 6 | ||||
-rw-r--r-- | compiler/main/ErrUtils.hs | 22 |
3 files changed, 46 insertions, 9 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 |