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

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