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

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