Allow colors to be customized
authorPhil Ruffwind <rf@rufflewind.com>
Fri, 24 Mar 2017 00:59:01 +0000 (20:59 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 24 Mar 2017 02:14:48 +0000 (22:14 -0400)
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

compiler/ghc.cabal.in
compiler/ghc.mk
compiler/main/DynFlags.hs
compiler/main/DynFlags.hs-boot
compiler/main/ErrUtils.hs
compiler/utils/Outputable.hs
compiler/utils/PprColour.hs [new file with mode: 0644]
compiler/utils/Util.hs
docs/users_guide/using.rst
ghc/GHCi/UI.hs

index fc8dcd9..6054d85 100644 (file)
@@ -501,6 +501,7 @@ Library
         Outputable
         Pair
         Panic
+        PprColour
         Pretty
         State
         Stream
index 3f6e77c..28b0001 100644 (file)
@@ -528,6 +528,7 @@ compiler_stage2_dll0_MODULES = \
        PipelineMonad \
        Platform \
        PlatformConstants \
+       PprColour \
        PprCore \
        PrelNames \
        PrelRules \
index 057c2c0..927d3c4 100644 (file)
@@ -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",
index 14c039a..5fd80fc 100644 (file)
@@ -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
index a9310c6..180d18d 100644 (file)
@@ -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) <>
index 8a2afbe..403c5ce 100644 (file)
@@ -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 (file)
index 0000000..1b97303
--- /dev/null
@@ -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)
+        _ -> []
index 30026c5..65445e4 100644 (file)
@@ -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
index 60007b0..fc19dfd 100644 (file)
@@ -638,7 +638,7 @@ messages and in GHCi:
         (>>) :: ∀ (m :: * → *) a b. Monad m ⇒ m a → m b → m b
 
 .. _pretty-printing-types:
-    
+
 .. ghc-flag:: -fprint-explicit-foralls
 
     Using :ghc-flag:`-fprint-explicit-foralls` makes
@@ -795,10 +795,23 @@ messages and in GHCi:
 
     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.)
+    appear.  The default value is ``auto``, which means GHC will make an
+    attempt to detect whether terminal supports colors and choose accordingly.
+
+    The precise color scheme is controlled by the environment variable
+    ``GHC_COLORS`` (or ``GHC_COLOURS``).  This can be set to colon-separated
+    list of ``key=value`` pairs.  These are the default settings:
+
+    .. code-block:: none
+
+        message=1:warning=1;35:error=1;31:fatal=1;31:margin=1;34
+
+    Each value is expected to be a `Select Graphic Rendition (SGR) substring
+    <https://en.wikipedia.org/wiki/ANSI_escape_code#graphics>`_.
+
+    The environment variable can also be set to the magical values ``never``
+    or ``always``, which is equivalent to setting the corresponding
+    ``-fdiagnostics-color`` flag but has lower precedence.
 
 .. ghc-flag:: -f[no-]diagnostics-show-caret
 
index 6310e3c..b2b54d3 100644 (file)
@@ -64,7 +64,7 @@ import SrcLoc
 import qualified Lexer
 
 import StringBuffer
-import Outputable hiding ( printForUser, printForUserPartWay, bold )
+import Outputable hiding ( printForUser, printForUserPartWay )
 
 -- Other random utilities
 import BasicTypes hiding ( isTopLevel )