Add "header" to GHC_COLORS

Add "header" to GHC_COLORS and allow colors to be inherited from the
surroundings.

Test Plan: validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #13718

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

4 files changed, 40 insertions, 16 deletions

diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index b0bbe3c9e4..40f6648cd0 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -209,10 +209,12 @@ mkLocMessageAnn ann severity locn msg
 
           -- Add prefixes, like    Foo.hs:34: warning:
           --                           <the warning message>
-          prefix = locn' <> colon <+>
+          header = locn' <> colon <+>
                    coloured sevColour sevText <> optAnn
 
-      in coloured (Col.sMessage (colScheme dflags)) (hang prefix 4 msg)
+      in coloured (Col.sMessage (colScheme dflags))
+                  (hang (coloured (Col.sHeader (colScheme dflags)) header) 4
+                        msg)
 
   where
     sevText =
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 403c5cef73..4107e5beef 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -723,19 +723,18 @@ ppUnless False doc = doc
 --
 -- Only takes effect if colours are enabled.
 coloured :: Col.PprColour -> SDoc -> SDoc
-coloured col@(Col.PprColour c) sdoc =
+coloured col sdoc =
   sdocWithDynFlags $ \dflags ->
     if shouldUseColor dflags
-    then SDoc $ \ctx@SDC{ sdocLastColour = Col.PprColour lc } ->
+    then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } ->
          case ctx of
            SDC{ sdocStyle = PprUser _ _ Coloured } ->
-             let ctx' = ctx{ sdocLastColour = col } in
-             Pretty.zeroWidthText (cReset ++ c)
+             let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in
+             Pretty.zeroWidthText (Col.renderColour col)
                Pretty.<> runSDoc sdoc ctx'
-               Pretty.<> Pretty.zeroWidthText (cReset ++ lc)
+               Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol)
            _ -> runSDoc sdoc ctx
     else sdoc
-  where Col.PprColour cReset = Col.colReset
 
 keyword :: SDoc -> SDoc
 keyword = coloured Col.colBold
diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs
index 1b97303b93..ba7435d5c2 100644
--- a/compiler/utils/PprColour.hs
+++ b/compiler/utils/PprColour.hs
@@ -3,7 +3,7 @@ import Data.Maybe (fromMaybe)
 import Util (OverridingBool(..), split)
 
 -- | A colour\/style for use with 'coloured'.
-newtype PprColour = PprColour String
+newtype PprColour = PprColour { renderColour :: String }
 
 -- | Allow colours to be combined (e.g. bold + red);
 --   In case of conflict, right side takes precedence.
@@ -11,8 +11,12 @@ instance Monoid PprColour where
   mempty = PprColour mempty
   PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)
 
+renderColourAfresh :: PprColour -> String
+renderColourAfresh c = renderColour (colReset `mappend` c)
+
 colCustom :: String -> PprColour
-colCustom s = PprColour ("\27[" ++ s ++ "m")
+colCustom "" = mempty
+colCustom s  = PprColour ("\27[" ++ s ++ "m")
 
 colReset :: PprColour
 colReset = colCustom "0"
@@ -46,7 +50,8 @@ colWhiteFg = colCustom "37"
 
 data Scheme =
   Scheme
-  { sMessage :: PprColour
+  { sHeader  :: PprColour
+  , sMessage :: PprColour
   , sWarning :: PprColour
   , sError   :: PprColour
   , sFatal   :: PprColour
@@ -56,7 +61,8 @@ data Scheme =
 defaultScheme :: Scheme
 defaultScheme =
   Scheme
-  { sMessage = colBold
+  { sHeader  = mempty
+  , sMessage = colBold
   , sWarning = colBold `mappend` colMagentaFg
   , sError   = colBold `mappend` colRedFg
   , sFatal   = colBold `mappend` colRedFg
@@ -72,7 +78,8 @@ parseScheme "never"  (_, cs) = (Never,  cs)
 parseScheme input    (b, cs) =
   ( b
   , Scheme
-    { sMessage = fromMaybe (sMessage cs) (lookup "message" table)
+    { sHeader  = fromMaybe (sHeader cs)  (lookup "header" table)
+    , 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)
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index fc19dfd566..84dae9fd0b 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -804,14 +804,30 @@ messages and in GHCi:
 
     .. code-block:: none
 
-        message=1:warning=1;35:error=1;31:fatal=1;31:margin=1;34
+        header=: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>`_.
+    <https://en.wikipedia.org/wiki/ANSI_escape_code#graphics>`_.  The
+    formatting of each element can inherit from parent elements.  For example,
+    if ``header`` is left empty, it will inherit the formatting of
+    ``message``.  Alternatively if ``header`` is set to ``1`` (bold), it will
+    be bolded but still inherits the color of ``message``.
+
+    Currently, in the primary message, the following inheritance tree is in
+    place:
+
+    - ``message``
+      - ``header``
+        - ``warning``
+        - ``error``
+        - ``fatal``
+
+    In the caret diagnostics, there is currently no inheritance at all between
+    ``margin``, ``warning``, ``error``, and ``fatal``.
 
     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.
+    ``-fdiagnostics-color`` flag but with lower precedence.
 
 .. ghc-flag:: -f[no-]diagnostics-show-caret