diff options
Diffstat (limited to 'compiler/GHC/Utils')
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Trace.hs | 6 |
2 files changed, 18 insertions, 4 deletions
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index f424076e04..032c8502f8 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -90,7 +90,8 @@ module GHC.Utils.Outputable ( QualifyName(..), queryQual, sdocOption, updSDocContext, - SDocContext (..), sdocWithContext, defaultSDocContext, + SDocContext (..), sdocWithContext, + defaultSDocContext, traceSDocContext, getPprStyle, withPprStyle, setStyleColoured, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, dumpStyle, asmStyle, @@ -116,6 +117,7 @@ import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Ppr ( Doc, Mode(..) ) import GHC.Serialized import GHC.LanguageExtensions (Extension) +import GHC.Utils.GlobalVars( unsafeHasPprDebug ) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -450,6 +452,18 @@ defaultSDocContext = SDC , sdocUnitIdForUser = ftext } +traceSDocContext :: SDocContext +-- Used for pprTrace, when we want to see lots of info +traceSDocContext = defaultSDocContext + { sdocPprDebug = unsafeHasPprDebug + , sdocPrintTypecheckerElaboration = True + , sdocPrintExplicitKinds = True + , sdocPrintExplicitCoercions = True + , sdocPrintExplicitRuntimeReps = True + , sdocPrintExplicitForalls = True + , sdocPrintEqualityRelations = True + } + withPprStyle :: PprStyle -> SDoc -> SDoc {-# INLINE CONLIKE withPprStyle #-} withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs index cc5c69abb7..c5f07df248 100644 --- a/compiler/GHC/Utils/Trace.hs +++ b/compiler/GHC/Utils/Trace.hs @@ -28,7 +28,7 @@ import Control.Monad.IO.Class pprTrace :: String -> SDoc -> a -> a pprTrace str doc x | unsafeHasNoDebugOutput = x - | otherwise = pprDebugAndThen defaultSDocContext trace (text str) doc x + | otherwise = pprDebugAndThen traceSDocContext trace (text str) doc x pprTraceM :: Applicative f => String -> SDoc -> f () pprTraceM str doc = pprTrace str doc (pure ()) @@ -69,7 +69,7 @@ warnPprTrace _ _s _ x | not debugIsOn = x warnPprTrace _ _s _msg x | unsafeHasNoDebugOutput = x warnPprTrace False _s _msg x = x warnPprTrace True s msg x - = pprDebugAndThen defaultSDocContext trace (text "WARNING:") + = pprDebugAndThen traceSDocContext trace (text "WARNING:") (text s $$ msg $$ withFrozenCallStack traceCallStackDoc ) x @@ -78,7 +78,7 @@ warnPprTrace True s msg x pprTraceUserWarning :: HasCallStack => SDoc -> a -> a pprTraceUserWarning msg x | unsafeHasNoDebugOutput = x - | otherwise = pprDebugAndThen defaultSDocContext trace (text "WARNING:") + | otherwise = pprDebugAndThen traceSDocContext trace (text "WARNING:") (msg $$ withFrozenCallStack traceCallStackDoc ) x |