Disentangle DynFlags and SDoc

Remove several uses of `sdocWithDynFlags`. The remaining ones are mostly
CodeGen related (e.g. depend on target platform constants) and will be
fixed separately.

Metric Decrease:
   T12425
   T9961
   WWRec
   T1969
   T14683

3 files changed, 63 insertions, 46 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index f5e2fd93aa..97bc2fece1 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -38,8 +38,6 @@ module DynFlags (
         xopt, xopt_set, xopt_unset,
         xopt_set_unlessExplSpec,
         lang_set,
-        useUnicodeSyntax,
-        useStarIsType,
         whenGeneratingDynamicToo, ifGeneratingDynamicToo,
         whenCannotGenerateDynamicToo,
         dynamicTooMkDynamicDynFlags,
@@ -62,8 +60,6 @@ module DynFlags (
         wWarningFlags,
         dynFlagDependencies,
         makeDynFlagsConsistent,
-        shouldUseColor,
-        shouldUseHexWordLiterals,
         positionIndependent,
         optimisationFlags,
         setFlagsFromEnvFile,
@@ -241,6 +237,8 @@ module DynFlags (
         -- * Include specifications
         IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,
 
+        -- * SDoc
+        initSDocContext,
 
         -- * Make use of the Cmm CFG
         CfgWeights(..), backendMaintainsCfg
@@ -1707,13 +1705,6 @@ data RtsOptsEnabled
   | RtsOptsAll
   deriving (Show)
 
-shouldUseColor :: DynFlags -> Bool
-shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags)
-
-shouldUseHexWordLiterals :: DynFlags -> Bool
-shouldUseHexWordLiterals dflags =
-  Opt_HexWordLiterals `EnumSet.member` generalFlags dflags
-
 -- | Are we building with @-fPIE@ or @-fPIC@ enabled?
 positionIndependent :: DynFlags -> Bool
 positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags
@@ -1920,10 +1911,8 @@ initDynFlags dflags = do
                           do str' <- peekCString enc cstr
                              return (str == str'))
                          `catchIOError` \_ -> return False
- maybeGhcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"
- let adjustNoUnicode (Just _) = False
-     adjustNoUnicode Nothing = True
- let useUnicode' = (adjustNoUnicode maybeGhcNoUnicodeEnv) && canUseUnicode
+ ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"
+ let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode
  canUseColor <- stderrSupportsAnsiColors
  maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"
  maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"
@@ -2498,16 +2487,6 @@ lang_set dflags lang =
             extensionFlags = flattenExtensionFlags lang (extensions dflags)
           }
 
--- | An internal helper to check whether to use unicode syntax for output.
---
--- Note: You should very likely be using 'Outputable.unicodeSyntax' instead
--- of this function.
-useUnicodeSyntax :: DynFlags -> Bool
-useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax
-
-useStarIsType :: DynFlags -> Bool
-useStarIsType = xopt LangExt.StarIsType
-
 -- | Set the Haskell language standard to use
 setLanguage :: Language -> DynP ()
 setLanguage l = upd (`lang_set` Just l)
@@ -5918,3 +5897,42 @@ data FilesToClean = FilesToClean {
 -- | An empty FilesToClean
 emptyFilesToClean :: FilesToClean
 emptyFilesToClean = FilesToClean Set.empty Set.empty
+
+
+
+initSDocContext :: DynFlags -> PprStyle -> SDocContext
+initSDocContext dflags style = SDC
+  { sdocStyle                       = style
+  , sdocColScheme                   = colScheme dflags
+  , sdocLastColour                  = Col.colReset
+  , sdocShouldUseColor              = overrideWith (canUseColor dflags) (useColor dflags)
+  , sdocLineLength                  = pprCols dflags
+  , sdocCanUseUnicode               = useUnicode dflags
+  , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags
+  , sdocDebugLevel                  = debugLevel dflags
+  , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags
+  , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags
+  , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags
+  , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags
+  , sdocPrintAxiomIncomps           = gopt Opt_PrintAxiomIncomps dflags
+  , sdocPrintExplicitKinds          = gopt Opt_PrintExplicitKinds dflags
+  , sdocPrintExplicitCoercions      = gopt Opt_PrintExplicitCoercions dflags
+  , sdocPrintExplicitRuntimeReps    = gopt Opt_PrintExplicitRuntimeReps dflags
+  , sdocPrintExplicitForalls        = gopt Opt_PrintExplicitForalls dflags
+  , sdocPrintPotentialInstances     = gopt Opt_PrintPotentialInstances dflags
+  , sdocPrintEqualityRelations      = gopt Opt_PrintEqualityRelations dflags
+  , sdocSuppressTicks               = gopt Opt_SuppressTicks dflags
+  , sdocSuppressTypeSignatures      = gopt Opt_SuppressTypeSignatures dflags
+  , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags
+  , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags
+  , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags
+  , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags
+  , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags
+  , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags
+  , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags
+  , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags
+  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags
+  , sdocStarIsType                  = xopt LangExt.StarIsType dflags
+  , sdocImpredicativeTypes          = xopt LangExt.ImpredicativeTypes dflags
+  , sdocDynFlags                    = dflags
+  }
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 6f9bdc5138..6d471f3970 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -2,6 +2,7 @@ module DynFlags where
 
 import GhcPrelude
 import GHC.Platform
+import {-# SOURCE #-} Outputable
 
 data DynFlags
 data DumpFlag
@@ -11,9 +12,6 @@ targetPlatform           :: DynFlags -> Platform
 pprUserLength            :: DynFlags -> Int
 pprCols                  :: DynFlags -> Int
 unsafeGlobalDynFlags     :: DynFlags
-useUnicode               :: DynFlags -> Bool
-useUnicodeSyntax         :: DynFlags -> Bool
-shouldUseColor           :: DynFlags -> Bool
-shouldUseHexWordLiterals :: DynFlags -> Bool
 hasPprDebug              :: DynFlags -> Bool
 hasNoDebugOutput         :: DynFlags -> Bool
+initSDocContext          :: DynFlags -> PprStyle -> SDocContext
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index b5dab7ea35..320912ba59 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
 
 module ErrUtils (
         -- * Basic types
@@ -209,12 +210,12 @@ mkLocMessageAnn
   -- are supposed to be in a standard format, and one without a location
   -- would look strange.  Better to say explicitly "<no location info>".
 mkLocMessageAnn ann severity locn msg
-    = sdocWithDynFlags $ \dflags ->
-      let locn' = if gopt Opt_ErrorSpans dflags
-                  then ppr locn
-                  else ppr (srcSpanStart locn)
+    = sdocOption sdocColScheme $ \col_scheme ->
+      let locn' = sdocOption sdocErrorSpans $ \case
+                     True  -> ppr locn
+                     False -> ppr (srcSpanStart locn)
 
-          sevColour = getSeverityColour severity (colScheme dflags)
+          sevColour = getSeverityColour severity col_scheme
 
           -- Add optional information
           optAnn = case ann of
@@ -226,8 +227,8 @@ mkLocMessageAnn ann severity locn msg
           header = locn' <> colon <+>
                    coloured sevColour sevText <> optAnn
 
-      in coloured (Col.sMessage (colScheme dflags))
-                  (hang (coloured (Col.sHeader (colScheme dflags)) header) 4
+      in coloured (Col.sMessage col_scheme)
+                  (hang (coloured (Col.sHeader col_scheme) header) 4
                         msg)
 
   where
@@ -279,9 +280,9 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
 
     caretDiagnostic Nothing = empty
     caretDiagnostic (Just srcLineWithNewline) =
-      sdocWithDynFlags $ \ dflags ->
-      let sevColour = getSeverityColour severity (colScheme dflags)
-          marginColour = Col.sMargin (colScheme dflags)
+      sdocOption sdocColScheme$ \col_scheme ->
+      let sevColour = getSeverityColour severity col_scheme
+          marginColour = Col.sMargin col_scheme
       in
       coloured marginColour (text marginSpace) <>
       text ("\n") <>
@@ -377,7 +378,8 @@ warningsToMessages dflags =
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
 printBagOfErrors dflags bag_of_errors
   = sequence_ [ let style = mkErrStyle dflags unqual
-                in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)
+                    ctx   = initSDocContext dflags style
+                in putLogMsg dflags reason sev s style (formatErrDoc ctx doc)
               | ErrMsg { errMsgSpan      = s,
                          errMsgDoc       = doc,
                          errMsgSeverity  = sev,
@@ -385,13 +387,13 @@ printBagOfErrors dflags bag_of_errors
                          errMsgContext   = unqual } <- sortMsgBag (Just dflags)
                                                                   bag_of_errors ]
 
-formatErrDoc :: DynFlags -> ErrDoc -> SDoc
-formatErrDoc dflags (ErrDoc important context supplementary)
+formatErrDoc :: SDocContext -> ErrDoc -> SDoc
+formatErrDoc ctx (ErrDoc important context supplementary)
   = case msgs of
         [msg] -> vcat msg
         _ -> vcat $ map starred msgs
     where
-    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
+    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx))
         [important, context, supplementary]
     starred = (bullet<+>) . vcat
 
@@ -403,9 +405,8 @@ pprLocErrMsg (ErrMsg { errMsgSpan      = s
                      , errMsgDoc       = doc
                      , errMsgSeverity  = sev
                      , errMsgContext   = unqual })
-  = sdocWithDynFlags $ \dflags ->
-    withPprStyle (mkErrStyle dflags unqual) $
-    mkLocMessage sev s (formatErrDoc dflags doc)
+  = sdocWithContext $ \ctx ->
+    withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc)
 
 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
 sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList