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

1 files changed, 52 insertions, 14 deletions

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