Disable colors unless printing to stderr
authorPhil Ruffwind <rf@rufflewind.com>
Fri, 9 Dec 2016 15:28:25 +0000 (10:28 -0500)
committerBen Gamari <ben@smart-cactus.org>
Fri, 9 Dec 2016 15:28:39 +0000 (10:28 -0500)
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

compiler/main/DynFlags.hs
compiler/main/ErrUtils.hs
compiler/utils/Outputable.hs

index d7cde29..d9ffa82 100644 (file)
@@ -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
index 9898346..0f478ef 100644 (file)
@@ -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
index 16f257e..32d1b5d 100644 (file)
@@ -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