Allow colors to be customized

Allow customization of diagnostic colors through the GHC_COLORS
environment variable.  Some color-related code have been refactored to
PprColour to reduce the circular dependence between DynFlags,
Outputable, ErrUtils.  Some color functions that were part of Outputable
but were never used have been deleted.

Test Plan: validate

Reviewers: austin, hvr, bgamari, dfeuer

Reviewed By: bgamari, dfeuer

Subscribers: dfeuer, rwbarton, thomie, snowleopard

Differential Revision: https://phabricator.haskell.org/D3364

8 files changed, 158 insertions, 106 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index fc8dcd98bf..6054d8579a 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -501,6 +501,7 @@ Library
         Outputable
         Pair
         Panic
+        PprColour
         Pretty
         State
         Stream
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 3f6e77ca4b..28b0001805 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -528,6 +528,7 @@ compiler_stage2_dll0_MODULES = \
 	PipelineMonad \
 	Platform \
 	PlatformConstants \
+	PprColour \
 	PprCore \
 	PrelNames \
 	PrelRules \
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 057c2c0071..927d3c46a0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -42,7 +42,6 @@ module DynFlags (
         DynFlags(..),
         FlagSpec(..),
         HasDynFlags(..), ContainsDynFlags(..),
-        OverridingBool(..), overrideWith,
         RtsOptsEnabled(..),
         HscTarget(..), isObjectTarget, defaultObjectTarget,
         targetRetainsAllBindings,
@@ -58,6 +57,7 @@ module DynFlags (
         dynFlagDependencies,
         tablesNextToCode, mkTablesNextToCode,
         makeDynFlagsConsistent,
+        shouldUseColor,
 
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
@@ -170,6 +170,7 @@ import Config
 import CmdLineParser
 import Constants
 import Panic
+import qualified PprColour as Col
 import Util
 import Maybes
 import MonadUtils
@@ -207,7 +208,7 @@ import qualified Data.Set as Set
 import Data.Word
 import System.FilePath
 import System.Directory
-import System.Environment (getEnv)
+import System.Environment (getEnv, lookupEnv)
 import System.IO
 import System.IO.Error
 import Text.ParserCombinators.ReadP hiding (char)
@@ -911,6 +912,7 @@ data DynFlags = DynFlags {
   useUnicode            :: Bool,
   useColor              :: OverridingBool,
   canUseColor           :: Bool,
+  colScheme             :: Col.Scheme,
 
   -- | what kind of {-# SCC #-} to add automatically
   profAuto              :: ProfAuto,
@@ -1291,16 +1293,8 @@ 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
+shouldUseColor :: DynFlags -> Bool
+shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags)
 
 -----------------------------------------------------------------------------
 -- Ways
@@ -1505,6 +1499,13 @@ initDynFlags dflags = do
                              return (str == str'))
                          `catchIOError` \_ -> return False
  canUseColor <- stderrSupportsAnsiColors
+ maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"
+ maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"
+ let adjustCols (Just env) = Col.parseScheme env
+     adjustCols Nothing    = id
+ let (useColor', colScheme') =
+       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)
+       (useColor dflags, colScheme dflags)
  return dflags{
         canGenerateDynamicToo = refCanGenerateDynamicToo,
         nextTempSuffix = refNextTempSuffix,
@@ -1514,7 +1515,9 @@ initDynFlags dflags = do
         generatedDumps = refGeneratedDumps,
         nextWrapperNum = wrapperNum,
         useUnicode    = canUseUnicode,
+        useColor      = useColor',
         canUseColor   = canUseColor,
+        colScheme     = colScheme',
         rtldInfo      = refRtldInfo,
         rtccInfo      = refRtccInfo
         }
@@ -1680,6 +1683,7 @@ defaultDynFlags mySettings =
         useUnicode = False,
         useColor = Auto,
         canUseColor = False,
+        colScheme = Col.defaultScheme,
         profAuto = NoProfAuto,
         interactivePrint = Nothing,
         nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 14c039aca3..5fd80fcd82 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -4,7 +4,6 @@ module DynFlags where
 import Platform
 
 data DynFlags
-data OverridingBool
 data DumpFlag
 
 targetPlatform       :: DynFlags -> Platform
@@ -13,8 +12,6 @@ pprCols              :: DynFlags -> Int
 unsafeGlobalDynFlags :: DynFlags
 useUnicode           :: DynFlags -> Bool
 useUnicodeSyntax     :: DynFlags -> Bool
-useColor             :: DynFlags -> OverridingBool
-canUseColor          :: DynFlags -> Bool
-overrideWith         :: Bool -> OverridingBool -> Bool
+shouldUseColor       :: DynFlags -> Bool
 hasPprDebug          :: DynFlags -> Bool
 hasNoDebugOutput     :: DynFlags -> Bool
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index a9310c607c..180d18d8c9 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -60,6 +60,7 @@ import Bag
 import Exception
 import Outputable
 import Panic
+import qualified PprColour as Col
 import SrcLoc
 import DynFlags
 import FastString (unpackFS)
@@ -73,7 +74,6 @@ 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
@@ -199,14 +199,22 @@ mkLocMessageAnn ann severity locn msg
       let locn' = if gopt Opt_ErrorSpans dflags
                   then ppr locn
                   else ppr (srcSpanStart locn)
+
+          sevColour = getSeverityColour severity (colScheme dflags)
+
+          -- Add optional information
+          optAnn = case ann of
+            Nothing -> text ""
+            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"
+
           -- Add prefixes, like    Foo.hs:34: warning:
           --                           <the warning message>
           prefix = locn' <> colon <+>
                    coloured sevColour sevText <> optAnn
-      in bold (hang prefix 4 msg)
-  where
-    sevColour = colBold `mappend` getSeverityColour severity
 
+      in coloured (Col.sMessage (colScheme dflags)) (hang prefix 4 msg)
+
+  where
     sevText =
       case severity of
         SevWarning -> text "warning:"
@@ -214,16 +222,11 @@ mkLocMessageAnn ann severity locn msg
         SevFatal   -> text "fatal:"
         _          -> empty
 
-    -- Add optional information
-    optAnn = case ann of
-      Nothing -> text ""
-      Just i  -> text " [" <> coloured sevColour (text i) <> text "]"
-
-getSeverityColour :: Severity -> PprColour
-getSeverityColour SevWarning = colMagentaFg
-getSeverityColour SevError   = colRedFg
-getSeverityColour SevFatal   = colRedFg
-getSeverityColour _          = mempty
+getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
+getSeverityColour SevWarning = Col.sWarning
+getSeverityColour SevError   = Col.sError
+getSeverityColour SevFatal   = Col.sFatal
+getSeverityColour _          = const mempty
 
 getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
@@ -255,10 +258,6 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
     fix '\0' = '\xfffd'
     fix c    = c
 
-    sevColour = colBold `mappend` getSeverityColour severity
-
-    marginColour = colBold `mappend` colBlueFg
-
     row = srcSpanStartLine span
     rowStr = show row
     multiline = row /= srcSpanEndLine span
@@ -267,6 +266,10 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
 
     caretDiagnostic Nothing = empty
     caretDiagnostic (Just srcLineWithNewline) =
+      sdocWithDynFlags $ \ dflags ->
+      let sevColour = getSeverityColour severity (colScheme dflags)
+          marginColour = Col.sMargin (colScheme dflags)
+      in
       coloured marginColour (text marginSpace) <>
       text ("\n") <>
       coloured marginColour (text marginRow) <>
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 8a2afbec79..403c5cef73 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -38,9 +38,7 @@ module Outputable (
         speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
         unicodeSyntax,
 
-        coloured, bold, keyword, PprColour, colReset, colBold, colBlackFg,
-        colRedFg, colGreenFg, colYellowFg, colBlueFg, colMagentaFg, colCyanFg,
-        colWhiteFg, colBinder, colCoerc, colDataCon, colType,
+        coloured, keyword,
 
         -- * Converting 'SDoc' into strings and outputing it
         printSDoc, printSDocLn, printForUser, printForUserPartWay,
@@ -89,8 +87,7 @@ module Outputable (
 import {-# SOURCE #-}   DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
                                   targetPlatform, pprUserLength, pprCols,
                                   useUnicode, useUnicodeSyntax,
-                                  useColor, canUseColor, overrideWith,
-                                  unsafeGlobalDynFlags )
+                                  shouldUseColor, unsafeGlobalDynFlags )
 import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )
 import {-# SOURCE #-}   OccName( OccName )
 
@@ -99,6 +96,7 @@ import FastString
 import qualified Pretty
 import Util
 import Platform
+import qualified PprColour as Col
 import Pretty           ( Doc, Mode(..) )
 import Panic
 import GHC.Serialized
@@ -113,7 +111,6 @@ 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 )
@@ -318,7 +315,7 @@ newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
 
 data SDocContext = SDC
   { sdocStyle      :: !PprStyle
-  , sdocLastColour :: !PprColour
+  , sdocLastColour :: !Col.PprColour
     -- ^ The most recently used colour.  This allows nesting colours.
   , sdocDynFlags   :: !DynFlags
   }
@@ -329,7 +326,7 @@ instance IsString SDoc where
 initSDocContext :: DynFlags -> PprStyle -> SDocContext
 initSDocContext dflags sty = SDC
   { sdocStyle = sty
-  , sdocLastColour = colReset
+  , sdocLastColour = Col.colReset
   , sdocDynFlags = dflags
   }
 
@@ -438,7 +435,8 @@ printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
 printSDoc mode dflags handle sty doc =
   Pretty.printDoc_ mode cols handle (runSDoc doc ctx)
     `finally`
-      Pretty.printDoc_ mode cols handle (runSDoc (coloured colReset empty) ctx)
+      Pretty.printDoc_ mode cols handle
+        (runSDoc (coloured Col.colReset empty) ctx)
   where
     cols = pprCols dflags
     ctx = initSDocContext dflags sty
@@ -721,81 +719,26 @@ ppWhen False _   = empty
 ppUnless True  _   = empty
 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
-
-colReset :: PprColour
-colReset = PprColour "\27[0m"
-
-colBold :: PprColour
-colBold = PprColour "\27[;1m"
-
-colBlackFg :: PprColour
-colBlackFg = PprColour "\27[30m"
-
-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 = colGreenFg
-
-colCoerc :: PprColour
-colCoerc = colBlueFg
-
-colDataCon :: PprColour
-colDataCon = colRedFg
-
-colType :: PprColour
-colType = colBlueFg
-
 -- | Apply the given colour\/style for the argument.
 --
 -- Only takes effect if colours are enabled.
-coloured :: PprColour -> SDoc -> SDoc
-coloured col@(PprColour c) sdoc =
+coloured :: Col.PprColour -> SDoc -> SDoc
+coloured col@(Col.PprColour c) sdoc =
   sdocWithDynFlags $ \dflags ->
-    if overrideWith (canUseColor dflags) (useColor dflags)
-    then SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
+    if shouldUseColor dflags
+    then SDoc $ \ctx@SDC{ sdocLastColour = Col.PprColour lc } ->
          case ctx of
            SDC{ sdocStyle = PprUser _ _ Coloured } ->
              let ctx' = ctx{ sdocLastColour = col } in
-             Pretty.zeroWidthText c
+             Pretty.zeroWidthText (cReset ++ c)
                Pretty.<> runSDoc sdoc ctx'
-               Pretty.<> Pretty.zeroWidthText lc
+               Pretty.<> Pretty.zeroWidthText (cReset ++ lc)
            _ -> runSDoc sdoc ctx
     else sdoc
-
-bold :: SDoc -> SDoc
-bold = coloured colBold
+  where Col.PprColour cReset = Col.colReset
 
 keyword :: SDoc -> SDoc
-keyword = bold
+keyword = coloured Col.colBold
 
 {-
 ************************************************************************
diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs
new file mode 100644
index 0000000000..1b97303b93
--- /dev/null
+++ b/compiler/utils/PprColour.hs
@@ -0,0 +1,88 @@
+module PprColour where
+import Data.Maybe (fromMaybe)
+import Util (OverridingBool(..), split)
+
+-- | 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)
+
+colCustom :: String -> PprColour
+colCustom s = PprColour ("\27[" ++ s ++ "m")
+
+colReset :: PprColour
+colReset = colCustom "0"
+
+colBold :: PprColour
+colBold = colCustom ";1"
+
+colBlackFg :: PprColour
+colBlackFg = colCustom "30"
+
+colRedFg :: PprColour
+colRedFg = colCustom "31"
+
+colGreenFg :: PprColour
+colGreenFg = colCustom "32"
+
+colYellowFg :: PprColour
+colYellowFg = colCustom "33"
+
+colBlueFg :: PprColour
+colBlueFg = colCustom "34"
+
+colMagentaFg :: PprColour
+colMagentaFg = colCustom "35"
+
+colCyanFg :: PprColour
+colCyanFg = colCustom "36"
+
+colWhiteFg :: PprColour
+colWhiteFg = colCustom "37"
+
+data Scheme =
+  Scheme
+  { sMessage :: PprColour
+  , sWarning :: PprColour
+  , sError   :: PprColour
+  , sFatal   :: PprColour
+  , sMargin  :: PprColour
+  }
+
+defaultScheme :: Scheme
+defaultScheme =
+  Scheme
+  { sMessage = colBold
+  , sWarning = colBold `mappend` colMagentaFg
+  , sError   = colBold `mappend` colRedFg
+  , sFatal   = colBold `mappend` colRedFg
+  , sMargin  = colBold `mappend` colBlueFg
+  }
+
+-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@
+-- environment variable).
+parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
+parseScheme "always" (_, cs) = (Always, cs)
+parseScheme "auto"   (_, cs) = (Auto,   cs)
+parseScheme "never"  (_, cs) = (Never,  cs)
+parseScheme input    (b, cs) =
+  ( b
+  , Scheme
+    { sMessage = fromMaybe (sMessage cs) (lookup "message" table)
+    , sWarning = fromMaybe (sWarning cs) (lookup "warning" table)
+    , sError   = fromMaybe (sError cs)   (lookup "error"   table)
+    , sFatal   = fromMaybe (sFatal cs)   (lookup "fatal"   table)
+    , sMargin  = fromMaybe (sMargin cs)  (lookup "margin"  table)
+    }
+  )
+  where
+    table = do
+      w <- split ':' input
+      let (k, v') = break (== '=') w
+      case v' of
+        '=' : v -> return (k, colCustom v)
+        _ -> []
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 30026c5016..65445e410c 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -129,6 +129,10 @@ module Util (
         HasCallStack,
         HasDebugCallStack,
         prettyCurrentCallStack,
+
+        -- * Utils for flags
+        OverridingBool(..),
+        overrideWith,
     ) where
 
 #include "HsVersions.h"
@@ -1358,3 +1362,14 @@ prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack
 prettyCurrentCallStack :: HasCallStack => String
 prettyCurrentCallStack = "Call stack unavailable"
 #endif
+
+data OverridingBool
+  = Auto
+  | Always
+  | Never
+  deriving Show
+
+overrideWith :: Bool -> OverridingBool -> Bool
+overrideWith b Auto   = b
+overrideWith _ Always = True
+overrideWith _ Never  = False