From 4340ff9109fd3a6b7d0a81e4e82c0d8443e68c40 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Fri, 13 May 2022 11:12:02 +0100
Subject: Adjust flags for pprTrace

We were using defaultSDocContext for pprTrace, which suppresses
lots of useful infomation. This small MR adds

   GHC.Utils.Outputable.traceSDocContext

and uses it for pprTrace and pprTraceUserWarning.

traceSDocContext is a global, and hence not influenced by flags,
but that seems unavoidable.  But I made the sdocPprDebug bit
controlled by unsafeHasPprDebug, since we have the latter for
exactly this purpose.

Fixes #21569
---
 compiler/GHC/Utils/Outputable.hs | 16 +++++++++++++++-
 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
 
-- 
cgit v1.2.1