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

1 files changed, 19 insertions, 14 deletions

diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 989834634d..0f478ef28b 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -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