Commit f1fc8cbf authored by Rufflewind's avatar Rufflewind Committed by Ben Gamari

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
parent 30cecaec
......@@ -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.
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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