diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | compiler/ghc.mk | 1 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 28 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs-boot | 5 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.hs | 39 | ||||
| -rw-r--r-- | compiler/utils/Outputable.hs | 87 | ||||
| -rw-r--r-- | compiler/utils/PprColour.hs | 88 | ||||
| -rw-r--r-- | compiler/utils/Util.hs | 15 |
8 files changed, 158 insertions, 106 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index fc8dcd98bf..6054d8579a 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -501,6 +501,7 @@ Library Outputable Pair Panic + PprColour Pretty State Stream diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 3f6e77ca4b..28b0001805 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -528,6 +528,7 @@ compiler_stage2_dll0_MODULES = \ PipelineMonad \ Platform \ PlatformConstants \ + PprColour \ PprCore \ PrelNames \ PrelRules \ diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 057c2c0071..927d3c46a0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -42,7 +42,6 @@ module DynFlags ( DynFlags(..), FlagSpec(..), HasDynFlags(..), ContainsDynFlags(..), - OverridingBool(..), overrideWith, RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, targetRetainsAllBindings, @@ -58,6 +57,7 @@ module DynFlags ( dynFlagDependencies, tablesNextToCode, mkTablesNextToCode, makeDynFlagsConsistent, + shouldUseColor, Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, @@ -170,6 +170,7 @@ import Config import CmdLineParser import Constants import Panic +import qualified PprColour as Col import Util import Maybes import MonadUtils @@ -207,7 +208,7 @@ import qualified Data.Set as Set import Data.Word import System.FilePath import System.Directory -import System.Environment (getEnv) +import System.Environment (getEnv, lookupEnv) import System.IO import System.IO.Error import Text.ParserCombinators.ReadP hiding (char) @@ -911,6 +912,7 @@ data DynFlags = DynFlags { useUnicode :: Bool, useColor :: OverridingBool, canUseColor :: Bool, + colScheme :: Col.Scheme, -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, @@ -1291,16 +1293,8 @@ data DynLibLoader data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll deriving (Show) -data OverridingBool - = Auto - | Always - | Never - deriving Show - -overrideWith :: Bool -> OverridingBool -> Bool -overrideWith b Auto = b -overrideWith _ Always = True -overrideWith _ Never = False +shouldUseColor :: DynFlags -> Bool +shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags) ----------------------------------------------------------------------------- -- Ways @@ -1505,6 +1499,13 @@ initDynFlags dflags = do return (str == str')) `catchIOError` \_ -> return False canUseColor <- stderrSupportsAnsiColors + maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" + maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" + let adjustCols (Just env) = Col.parseScheme env + adjustCols Nothing = id + let (useColor', colScheme') = + (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) + (useColor dflags, colScheme dflags) return dflags{ canGenerateDynamicToo = refCanGenerateDynamicToo, nextTempSuffix = refNextTempSuffix, @@ -1514,7 +1515,9 @@ initDynFlags dflags = do generatedDumps = refGeneratedDumps, nextWrapperNum = wrapperNum, useUnicode = canUseUnicode, + useColor = useColor', canUseColor = canUseColor, + colScheme = colScheme', rtldInfo = refRtldInfo, rtccInfo = refRtccInfo } @@ -1680,6 +1683,7 @@ defaultDynFlags mySettings = useUnicode = False, useColor = Auto, canUseColor = False, + colScheme = Col.defaultScheme, profAuto = NoProfAuto, interactivePrint = Nothing, nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index 14c039aca3..5fd80fcd82 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -4,7 +4,6 @@ module DynFlags where import Platform data DynFlags -data OverridingBool data DumpFlag targetPlatform :: DynFlags -> Platform @@ -13,8 +12,6 @@ pprCols :: DynFlags -> Int unsafeGlobalDynFlags :: DynFlags useUnicode :: DynFlags -> Bool useUnicodeSyntax :: DynFlags -> Bool -useColor :: DynFlags -> OverridingBool -canUseColor :: DynFlags -> Bool -overrideWith :: Bool -> OverridingBool -> Bool +shouldUseColor :: DynFlags -> Bool hasPprDebug :: DynFlags -> Bool hasNoDebugOutput :: DynFlags -> Bool diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index a9310c607c..180d18d8c9 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -60,6 +60,7 @@ import Bag import Exception import Outputable import Panic +import qualified PprColour as Col import SrcLoc import DynFlags import FastString (unpackFS) @@ -73,7 +74,6 @@ import Data.List import qualified Data.Set as Set import Data.IORef import Data.Maybe ( fromMaybe ) -import Data.Monoid ( mappend ) import Data.Ord import Data.Time import Control.Monad @@ -199,14 +199,22 @@ mkLocMessageAnn ann severity locn msg let locn' = if gopt Opt_ErrorSpans dflags then ppr locn else ppr (srcSpanStart locn) + + sevColour = getSeverityColour severity (colScheme dflags) + + -- Add optional information + optAnn = case ann of + Nothing -> text "" + Just i -> text " [" <> coloured sevColour (text i) <> text "]" + -- Add prefixes, like Foo.hs:34: warning: -- <the warning message> prefix = locn' <> colon <+> coloured sevColour sevText <> optAnn - in bold (hang prefix 4 msg) - where - sevColour = colBold `mappend` getSeverityColour severity + in coloured (Col.sMessage (colScheme dflags)) (hang prefix 4 msg) + + where sevText = case severity of SevWarning -> text "warning:" @@ -214,16 +222,11 @@ mkLocMessageAnn ann severity locn msg SevFatal -> text "fatal:" _ -> empty - -- Add optional information - optAnn = case ann of - Nothing -> text "" - Just i -> text " [" <> coloured sevColour (text i) <> text "]" - -getSeverityColour :: Severity -> PprColour -getSeverityColour SevWarning = colMagentaFg -getSeverityColour SevError = colRedFg -getSeverityColour SevFatal = colRedFg -getSeverityColour _ = mempty +getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour +getSeverityColour SevWarning = Col.sWarning +getSeverityColour SevError = Col.sError +getSeverityColour SevFatal = Col.sFatal +getSeverityColour _ = const mempty getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty @@ -255,10 +258,6 @@ getCaretDiagnostic severity (RealSrcSpan span) = do fix '\0' = '\xfffd' fix c = c - sevColour = colBold `mappend` getSeverityColour severity - - marginColour = colBold `mappend` colBlueFg - row = srcSpanStartLine span rowStr = show row multiline = row /= srcSpanEndLine span @@ -267,6 +266,10 @@ getCaretDiagnostic severity (RealSrcSpan span) = do caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = + sdocWithDynFlags $ \ dflags -> + let sevColour = getSeverityColour severity (colScheme dflags) + marginColour = Col.sMargin (colScheme dflags) + in coloured marginColour (text marginSpace) <> text ("\n") <> coloured marginColour (text marginRow) <> diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 8a2afbec79..403c5cef73 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -38,9 +38,7 @@ module Outputable ( speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, unicodeSyntax, - coloured, bold, keyword, PprColour, colReset, colBold, colBlackFg, - colRedFg, colGreenFg, colYellowFg, colBlueFg, colMagentaFg, colCyanFg, - colWhiteFg, colBinder, colCoerc, colDataCon, colType, + coloured, keyword, -- * Converting 'SDoc' into strings and outputing it printSDoc, printSDocLn, printForUser, printForUserPartWay, @@ -89,8 +87,7 @@ module Outputable ( import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, targetPlatform, pprUserLength, pprCols, useUnicode, useUnicodeSyntax, - useColor, canUseColor, overrideWith, - unsafeGlobalDynFlags ) + shouldUseColor, unsafeGlobalDynFlags ) import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) @@ -99,6 +96,7 @@ import FastString import qualified Pretty import Util import Platform +import qualified PprColour as Col import Pretty ( Doc, Mode(..) ) import Panic import GHC.Serialized @@ -113,7 +111,6 @@ import Data.Int import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set -import Data.Monoid (Monoid, mappend, mempty) import Data.String import Data.Word import System.IO ( Handle ) @@ -318,7 +315,7 @@ newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } data SDocContext = SDC { sdocStyle :: !PprStyle - , sdocLastColour :: !PprColour + , sdocLastColour :: !Col.PprColour -- ^ The most recently used colour. This allows nesting colours. , sdocDynFlags :: !DynFlags } @@ -329,7 +326,7 @@ instance IsString SDoc where initSDocContext :: DynFlags -> PprStyle -> SDocContext initSDocContext dflags sty = SDC { sdocStyle = sty - , sdocLastColour = colReset + , sdocLastColour = Col.colReset , sdocDynFlags = dflags } @@ -438,7 +435,8 @@ printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () printSDoc mode dflags handle sty doc = Pretty.printDoc_ mode cols handle (runSDoc doc ctx) `finally` - Pretty.printDoc_ mode cols handle (runSDoc (coloured colReset empty) ctx) + Pretty.printDoc_ mode cols handle + (runSDoc (coloured Col.colReset empty) ctx) where cols = pprCols dflags ctx = initSDocContext dflags sty @@ -721,81 +719,26 @@ ppWhen False _ = empty ppUnless True _ = empty ppUnless False doc = doc --- | A colour\/style for use with 'coloured'. -newtype PprColour = PprColour String - --- | Allow colours to be combined (e.g. bold + red); --- In case of conflict, right side takes precedence. -instance Monoid PprColour where - mempty = PprColour mempty - PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2) - --- Colours - -colReset :: PprColour -colReset = PprColour "\27[0m" - -colBold :: PprColour -colBold = PprColour "\27[;1m" - -colBlackFg :: PprColour -colBlackFg = PprColour "\27[30m" - -colRedFg :: PprColour -colRedFg = PprColour "\27[31m" - -colGreenFg :: PprColour -colGreenFg = PprColour "\27[32m" - -colYellowFg :: PprColour -colYellowFg = PprColour "\27[33m" - -colBlueFg :: PprColour -colBlueFg = PprColour "\27[34m" - -colMagentaFg :: PprColour -colMagentaFg = PprColour "\27[35m" - -colCyanFg :: PprColour -colCyanFg = PprColour "\27[36m" - -colWhiteFg :: PprColour -colWhiteFg = PprColour "\27[37m" - -colBinder :: PprColour -colBinder = colGreenFg - -colCoerc :: PprColour -colCoerc = colBlueFg - -colDataCon :: PprColour -colDataCon = colRedFg - -colType :: PprColour -colType = colBlueFg - -- | Apply the given colour\/style for the argument. -- -- Only takes effect if colours are enabled. -coloured :: PprColour -> SDoc -> SDoc -coloured col@(PprColour c) sdoc = +coloured :: Col.PprColour -> SDoc -> SDoc +coloured col@(Col.PprColour c) sdoc = sdocWithDynFlags $ \dflags -> - if overrideWith (canUseColor dflags) (useColor dflags) - then SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } -> + if shouldUseColor dflags + then SDoc $ \ctx@SDC{ sdocLastColour = Col.PprColour lc } -> case ctx of SDC{ sdocStyle = PprUser _ _ Coloured } -> let ctx' = ctx{ sdocLastColour = col } in - Pretty.zeroWidthText c + Pretty.zeroWidthText (cReset ++ c) Pretty.<> runSDoc sdoc ctx' - Pretty.<> Pretty.zeroWidthText lc + Pretty.<> Pretty.zeroWidthText (cReset ++ lc) _ -> runSDoc sdoc ctx else sdoc - -bold :: SDoc -> SDoc -bold = coloured colBold + where Col.PprColour cReset = Col.colReset keyword :: SDoc -> SDoc -keyword = bold +keyword = coloured Col.colBold {- ************************************************************************ diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs new file mode 100644 index 0000000000..1b97303b93 --- /dev/null +++ b/compiler/utils/PprColour.hs @@ -0,0 +1,88 @@ +module PprColour where +import Data.Maybe (fromMaybe) +import Util (OverridingBool(..), split) + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour String + +-- | Allow colours to be combined (e.g. bold + red); +-- In case of conflict, right side takes precedence. +instance Monoid PprColour where + mempty = PprColour mempty + PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2) + +colCustom :: String -> PprColour +colCustom s = PprColour ("\27[" ++ s ++ "m") + +colReset :: PprColour +colReset = colCustom "0" + +colBold :: PprColour +colBold = colCustom ";1" + +colBlackFg :: PprColour +colBlackFg = colCustom "30" + +colRedFg :: PprColour +colRedFg = colCustom "31" + +colGreenFg :: PprColour +colGreenFg = colCustom "32" + +colYellowFg :: PprColour +colYellowFg = colCustom "33" + +colBlueFg :: PprColour +colBlueFg = colCustom "34" + +colMagentaFg :: PprColour +colMagentaFg = colCustom "35" + +colCyanFg :: PprColour +colCyanFg = colCustom "36" + +colWhiteFg :: PprColour +colWhiteFg = colCustom "37" + +data Scheme = + Scheme + { sMessage :: PprColour + , sWarning :: PprColour + , sError :: PprColour + , sFatal :: PprColour + , sMargin :: PprColour + } + +defaultScheme :: Scheme +defaultScheme = + Scheme + { sMessage = colBold + , sWarning = colBold `mappend` colMagentaFg + , sError = colBold `mappend` colRedFg + , sFatal = colBold `mappend` colRedFg + , sMargin = colBold `mappend` colBlueFg + } + +-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ +-- environment variable). +parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) +parseScheme "always" (_, cs) = (Always, cs) +parseScheme "auto" (_, cs) = (Auto, cs) +parseScheme "never" (_, cs) = (Never, cs) +parseScheme input (b, cs) = + ( b + , Scheme + { 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) + , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) + } + ) + where + table = do + w <- split ':' input + let (k, v') = break (== '=') w + case v' of + '=' : v -> return (k, colCustom v) + _ -> [] diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 30026c5016..65445e410c 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -129,6 +129,10 @@ module Util ( HasCallStack, HasDebugCallStack, prettyCurrentCallStack, + + -- * Utils for flags + OverridingBool(..), + overrideWith, ) where #include "HsVersions.h" @@ -1358,3 +1362,14 @@ prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack prettyCurrentCallStack :: HasCallStack => String prettyCurrentCallStack = "Call stack unavailable" #endif + +data OverridingBool + = Auto + | Always + | Never + deriving Show + +overrideWith :: Bool -> OverridingBool -> Bool +overrideWith b Auto = b +overrideWith _ Always = True +overrideWith _ Never = False |