Commit cee72d5c authored by Rufflewind's avatar Rufflewind Committed by Ben Gamari

Disable colors unless printing to stderr

Only print colors when mkLocMessageAnn is called directly from
defaultLogAction.  This prevents ANSI error codes from cluttering up the
dump files.

Test Plan: validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

GHC Trac Issues: #12927
parent d3b546b1
......@@ -1791,7 +1791,7 @@ defaultLogAction dflags reason severity srcSpan style msg
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n'
printErrs message style
printErrs message (setStyleColoured True style)
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
-- hPutStr would just emit the low 8 bits of
......
......@@ -168,10 +168,17 @@ instance Show ErrMsg where
pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
-- | Make an unannotated error message with location info.
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage = mkLocMessageAnn Nothing
mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
:: Maybe String -- ^ optional annotation
-> Severity -- ^ severity
-> SrcSpan -- ^ location
-> MsgDoc -- ^ message
-> MsgDoc
-- Always print the location, even if it is unhelpful. Error messages
-- are supposed to be in a standard format, and one without a location
-- would look strange. Better to say explicitly "<no location info>".
......@@ -180,25 +187,23 @@ mkLocMessageAnn ann severity locn msg
let locn' = if gopt Opt_ErrorSpans dflags
then ppr locn
else ppr (srcSpanStart locn)
in bold (hang (locn' <> colon <+> sevInfo <> optAnn) 4 msg)
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
prefix = locn' <> colon <+>
coloured (colBold `mappend` sevColor) sevText <> optAnn
in bold (hang prefix 4 msg)
where
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
(sevInfo, sevColor) =
(sevText, sevColor) =
case severity of
SevWarning ->
(coloured sevColor (text "warning:"), colBold `mappend` colMagentaFg)
SevError ->
(coloured sevColor (text "error:"), colBold `mappend` colRedFg)
SevFatal ->
(coloured sevColor (text "fatal:"), colBold `mappend` colRedFg)
_ ->
(empty, mempty)
SevWarning -> (text "warning:", colMagentaFg)
SevError -> (text "error:", colRedFg)
SevFatal -> (text "fatal:", colRedFg)
_ -> (empty, mempty)
-- Add optional information
optAnn = case ann of
Nothing -> text ""
Just i -> text " [" <> coloured sevColor (text i) <> text "]"
Just i -> text " [" <> coloured sevColor (text i) <> text "]"
makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason err = err
......
......@@ -71,7 +71,7 @@ module Outputable (
alwaysQualifyPackages, neverQualifyPackages,
QualifyName(..), queryQual,
sdocWithDynFlags, sdocWithPlatform,
getPprStyle, withPprStyle, withPprStyleDoc,
getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured,
pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
ifPprDebug, qualName, qualModule, qualPackage,
......@@ -133,7 +133,7 @@ import GHC.Show ( showMultiLineString )
-}
data PprStyle
= PprUser PrintUnqualified Depth
= PprUser PrintUnqualified Depth Coloured
-- Pretty-print in a way that will make sense to the
-- ordinary user; must be very close to Haskell
-- syntax, etc.
......@@ -156,6 +156,9 @@ data CodeStyle = CStyle -- The format of labels differs for C and assemb
data Depth = AllTheWay
| PartWay Int -- 0 => stop
data Coloured
= Uncoloured
| Coloured
-- -----------------------------------------------------------------------------
-- Printing original names
......@@ -262,7 +265,16 @@ cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
mkUserStyle unqual depth
| opt_PprStyle_Debug = PprDebug
| otherwise = PprUser unqual depth
| otherwise = PprUser unqual depth Uncoloured
setStyleColoured :: Bool -> PprStyle -> PprStyle
setStyleColoured col style =
case style of
PprUser q d _ -> PprUser q d c
_ -> style
where
c | col = Coloured
| otherwise = Uncoloured
instance Outputable PprStyle where
ppr (PprUser {}) = text "user-style"
......@@ -313,9 +325,9 @@ withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
pprDeeper :: SDoc -> SDoc
pprDeeper d = SDoc $ \ctx -> case ctx of
SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
SDC{sdocStyle=PprUser q (PartWay n)} ->
runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..."
SDC{sdocStyle=PprUser q (PartWay n) c} ->
runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
_ -> runSDoc d ctx
-- | Truncate a list that is longer than the current depth.
......@@ -324,10 +336,10 @@ pprDeeperList f ds
| null ds = f []
| otherwise = SDoc work
where
work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
work ctx@SDC{sdocStyle=PprUser q (PartWay n) c}
| n==0 = Pretty.text "..."
| otherwise =
runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
where
go _ [] = []
go i (d:ds) | i >= n = [text "...."]
......@@ -337,8 +349,8 @@ pprDeeperList f ds
pprSetDepth :: Depth -> SDoc -> SDoc
pprSetDepth depth doc = SDoc $ \ctx ->
case ctx of
SDC{sdocStyle=PprUser q _} ->
runSDoc doc ctx{sdocStyle = PprUser q depth}
SDC{sdocStyle=PprUser q _ c} ->
runSDoc doc ctx{sdocStyle = PprUser q depth c}
_ ->
runSDoc doc ctx
......@@ -352,19 +364,19 @@ sdocWithPlatform :: (Platform -> SDoc) -> SDoc
sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
qualName :: PprStyle -> QueryQualifyName
qualName (PprUser q _) mod occ = queryQualifyName q mod occ
qualName (PprDump q) mod occ = queryQualifyName q mod occ
qualName _other mod _ = NameQual (moduleName mod)
qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ
qualName (PprDump q) mod occ = queryQualifyName q mod occ
qualName _other mod _ = NameQual (moduleName mod)
qualModule :: PprStyle -> QueryQualifyModule
qualModule (PprUser q _) m = queryQualifyModule q m
qualModule (PprDump q) m = queryQualifyModule q m
qualModule _other _m = True
qualModule (PprUser q _ _) m = queryQualifyModule q m
qualModule (PprDump q) m = queryQualifyModule q m
qualModule _other _m = True
qualPackage :: PprStyle -> QueryQualifyPackage
qualPackage (PprUser q _) m = queryQualifyPackage q m
qualPackage (PprDump q) m = queryQualifyPackage q m
qualPackage _other _m = True
qualPackage (PprUser q _ _) m = queryQualifyPackage q m
qualPackage (PprDump q) m = queryQualifyPackage q m
qualPackage _other _m = True
queryQual :: PprStyle -> PrintUnqualified
queryQual s = QueryQualify (qualName s)
......@@ -388,8 +400,8 @@ debugStyle PprDebug = True
debugStyle _other = False
userStyle :: PprStyle -> Bool
userStyle (PprUser _ _) = True
userStyle _other = False
userStyle (PprUser {}) = True
userStyle _other = False
ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
ifPprDebug d = SDoc $ \ctx ->
......@@ -712,15 +724,17 @@ colType = colBlueFg
--
-- Only takes effect if colours are enabled.
coloured :: PprColour -> SDoc -> SDoc
-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
coloured col@(PprColour c) sdoc =
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
case ctx of
SDC{ sdocStyle = PprUser _ _ Coloured } ->
let ctx' = ctx{ sdocLastColour = col } in
Pretty.zeroWidthText c
Pretty.<> runSDoc sdoc ctx'
Pretty.<> Pretty.zeroWidthText lc
_ -> runSDoc sdoc ctx
else sdoc
bold :: SDoc -> SDoc
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment