[commit: ghc] master: Add "header" to GHC_COLORS (139ef04)
git at git.haskell.org
git at git.haskell.org
Mon May 22 16:41:42 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/139ef04bdbd14b74dd6202295e11a37295442fc8/ghc
>---------------------------------------------------------------
commit 139ef04bdbd14b74dd6202295e11a37295442fc8
Author: Phil Ruffwind <rf at rufflewind.com>
Date: Mon May 22 12:00:34 2017 -0400
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
>---------------------------------------------------------------
139ef04bdbd14b74dd6202295e11a37295442fc8
compiler/main/ErrUtils.hs | 6 ++++--
compiler/utils/Outputable.hs | 11 +++++------
compiler/utils/PprColour.hs | 17 ++++++++++++-----
docs/users_guide/using.rst | 22 +++++++++++++++++++---
4 files changed, 40 insertions(+), 16 deletions(-)
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index b0bbe3c..40f6648 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 403c5ce..4107e5b 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 at SDC{ sdocLastColour = Col.PprColour lc } ->
+ then SDoc $ \ctx at 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 1b97303..ba7435d 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 fc19dfd..84dae9f 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
More information about the ghc-commits
mailing list