From f8386c7b6a9d26bc5fd2c1d74d944c8df6337690 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 17 Mar 2020 15:32:32 +0100
Subject: [PATCH] Refactor PprDebug handling
If `-dppr-debug` is set, then PprUser and PprDump styles are silently
replaced with PprDebug style. This was done in `mkUserStyle` and
`mkDumpStyle` smart constructors. As a consequence they needed a
DynFlags parameter.
Now we keep the original PprUser and PprDump styles until they are used
to create an `SDocContext`. I.e. the substitution is only performed in
`initSDocContext`.
---
compiler/GHC.hs | 2 +-
compiler/GHC/Cmm/Pipeline.hs | 2 +-
compiler/GHC/CmmToAsm.hs | 2 +-
compiler/GHC/CmmToLlvm/Base.hs | 4 +--
compiler/GHC/Core/Lint.hs | 10 ++++----
compiler/GHC/Core/Opt/Driver.hs | 2 +-
compiler/GHC/Core/Opt/Monad.hs | 6 ++---
compiler/GHC/Core/Opt/Simplify.hs | 4 +--
compiler/GHC/Core/Rules.hs | 6 ++---
compiler/GHC/Driver/Backpack.hs | 10 ++++----
compiler/GHC/Driver/CodeOutput.hs | 2 +-
compiler/GHC/Driver/Pipeline.hs | 2 +-
compiler/GHC/Driver/Session.hs | 2 +-
compiler/GHC/Iface/Binary.hs | 2 +-
compiler/GHC/Iface/Ext/Utils.hs | 3 +--
compiler/GHC/Iface/Load.hs | 11 ++++----
compiler/GHC/Iface/Tidy.hs | 2 +-
compiler/GHC/Runtime/Linker.hs | 8 +++---
compiler/GHC/Stg/Lint.hs | 2 +-
compiler/GHC/SysTools/ExtraObj.hs | 2 +-
compiler/GHC/SysTools/Process.hs | 4 +--
compiler/GHC/Tc/Utils/Monad.hs | 4 +--
compiler/GHC/Utils/Error.hs | 20 +++++++--------
compiler/GHC/Utils/Outputable.hs | 42 +++++++++++++------------------
24 files changed, 73 insertions(+), 81 deletions(-)
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 088e12169039..ce14dee79533 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -611,7 +611,7 @@ setSessionDynFlags dflags = do
| otherwise = ""
msg = text "Starting " <> text prog
tr <- if verbosity dflags >= 3
- then return (logInfo dflags (defaultDumpStyle dflags) msg)
+ then return (logInfo dflags defaultDumpStyle msg)
else return (pure ())
let
conf = IServConfig
diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs
index 8d8deac91dcc..2dc4ecb80e56 100644
--- a/compiler/GHC/Cmm/Pipeline.hs
+++ b/compiler/GHC/Cmm/Pipeline.hs
@@ -368,6 +368,6 @@ dumpWith dflags flag txt fmt sdoc = do
-- If `-ddump-cmm-verbose -ddump-to-file` is specified,
-- dump each Cmm pipeline stage output to a separate file. #16930
when (dopt Opt_D_dump_cmm_verbose dflags)
- $ dumpAction dflags (mkDumpStyle dflags alwaysQualify)
+ $ dumpAction dflags (mkDumpStyle alwaysQualify)
(dumpOptionsFromFlag flag) txt fmt sdoc
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 34b877d696d3..544edc801ee8 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -390,7 +390,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
$ makeImportsDoc dflags (concat (ngs_imports ngs))
return us'
where
- dump_stats = dumpAction dflags (mkDumpStyle dflags alwaysQualify)
+ dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify)
(dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"
FormatText
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 99f5bd53a4b0..dc9e830751ba 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -519,7 +519,7 @@ strDisplayName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
- style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
+ style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle (initSDocContext dflags style) sdoc
return (fsLit (dropInfoSuffix str))
@@ -536,7 +536,7 @@ strProcedureName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
- style = Outp.mkUserStyle dflags Outp.neverQualify depth
+ style = Outp.mkUserStyle Outp.neverQualify depth
str = Outp.renderWithStyle (initSDocContext dflags style) sdoc
return (fsLit str)
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index bc74b7d393de..b72bf0f1c593 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -299,7 +299,7 @@ dumpPassResult :: DynFlags
-> IO ()
dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
= do { forM_ mb_flag $ \flag -> do
- let sty = mkDumpStyle dflags unqual
+ let sty = mkDumpStyle unqual
dumpAction dflags sty (dumpOptionsFromFlag flag)
(showSDoc dflags hdr) FormatCore dump_doc
@@ -372,7 +372,7 @@ displayLintResults :: DynFlags -> CoreToDo
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
(vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
, text "*** Offending Program ***"
, pprCoreBindings binds
@@ -385,7 +385,7 @@ displayLintResults dflags pass warns errs binds
-- If the Core linter encounters an error, output to stderr instead of
-- stdout (#13342)
= putLogMsg dflags NoReason Err.SevInfo noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
(lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
| otherwise = return ()
@@ -416,7 +416,7 @@ lintInteractiveExpr what hsc_env expr
display_lint_err err
= do { putLogMsg dflags NoReason Err.SevDump
- noSrcSpan (defaultDumpStyle dflags)
+ noSrcSpan defaultDumpStyle
(vcat [ lint_banner "errors" (text what)
, err
, text "*** Offending Program ***"
@@ -2845,7 +2845,7 @@ lintAnnots pname pass guts = do
when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat
[ lint_banner "warning" pname
, text "Core changes with annotations:"
- , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
+ , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
]
-- Return actual new guts
return nguts
diff --git a/compiler/GHC/Core/Opt/Driver.hs b/compiler/GHC/Core/Opt/Driver.hs
index 2d75a22a5ce4..982f13be3589 100644
--- a/compiler/GHC/Core/Opt/Driver.hs
+++ b/compiler/GHC/Core/Opt/Driver.hs
@@ -495,7 +495,7 @@ ruleCheckPass current_phase pat guts =
; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
++ (mg_rules guts)
; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
(ruleCheckProgram current_phase pat
rule_fn (mg_binds guts))
; return guts }
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 44023a1b5796..0db18b579083 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -779,8 +779,8 @@ msg sev reason doc
SevDump -> dump_sty
_ -> user_sty
err_sty = mkErrStyle dflags unqual
- user_sty = mkUserStyle dflags unqual AllTheWay
- dump_sty = mkDumpStyle dflags unqual
+ user_sty = mkUserStyle unqual AllTheWay
+ dump_sty = mkDumpStyle unqual
; liftIO $ putLogMsg dflags reason sev loc sty doc }
-- | Output a String message to the screen
@@ -824,5 +824,5 @@ dumpIfSet_dyn flag str fmt doc
= do { dflags <- getDynFlags
; unqual <- getPrintUnqualified
; when (dopt flag dflags) $ liftIO $ do
- let sty = mkDumpStyle dflags unqual
+ let sty = mkDumpStyle unqual
dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc }
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 483bd5f38c69..340efd2c9c0b 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -1804,7 +1804,7 @@ completeCall env var cont
log_inlining doc
= liftIO $ dumpAction dflags
- (mkUserStyle dflags alwaysQualify AllTheWay)
+ (mkUserStyle alwaysQualify AllTheWay)
(dumpOptionsFromFlag Opt_D_dump_inlinings)
"" FormatText doc
@@ -2092,7 +2092,7 @@ tryRules env rules fn args call_cont
log_rule dflags flag hdr details
= liftIO $ do
- let sty = mkDumpStyle dflags alwaysQualify
+ let sty = mkDumpStyle alwaysQualify
dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $
sep [text hdr, nest 4 details]
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 4989b22ff038..668f273a1ffa 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -260,14 +260,14 @@ functions (lambdas) except by name, so in this case it seems like
a good idea to treat 'M.k' as a roughTopName of the call.
-}
-pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc
+pprRulesForUser :: [CoreRule] -> SDoc
-- (a) tidy the rules
-- (b) sort them into order based on the rule name
-- (c) suppress uniques (unless -dppr-debug is on)
-- This combination makes the output stable so we can use in testing
-- It's here rather than in GHC.Core.Ppr because it calls tidyRules
-pprRulesForUser dflags rules
- = withPprStyle (defaultUserStyle dflags) $
+pprRulesForUser rules
+ = withPprStyle defaultUserStyle $
pprRules $
sortBy (comparing ruleName) $
tidyRules emptyTidyEnv rules
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 041c63c60d9b..7bae489f2235 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -515,9 +515,9 @@ mkBackpackMsg = do
-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
-- to qualify packages so we can use simple names for them.
-backpackStyle :: DynFlags -> PprStyle
-backpackStyle dflags =
- mkUserStyle dflags
+backpackStyle :: PprStyle
+backpackStyle =
+ mkUserStyle
(QueryQualify neverQualifyNames
alwaysQualifyModules
neverQualifyPackages) AllTheWay
@@ -537,7 +537,7 @@ msgUnitId pk = do
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ "Instantiating " ++ renderWithStyle
- (initSDocContext dflags (backpackStyle dflags))
+ (initSDocContext dflags backpackStyle)
(ppr pk)
-- | Message when we include a Backpack unit.
@@ -547,7 +547,7 @@ msgInclude (i,n) uid = do
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ showModuleIndex (i, n) ++ "Including " ++
- renderWithStyle (initSDocContext dflags (backpackStyle dflags))
+ renderWithStyle (initSDocContext dflags backpackStyle)
(ppr uid)
-- ----------------------------------------------------------------------------
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index bc29a4a654ea..a733638934ea 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -86,7 +86,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
NoReason
SevDump
noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
err
; ghcExit dflags 1
}
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index afcf1bd0bbb4..563af47e1f2d 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -1913,7 +1913,7 @@ linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
putLogMsg dflags NoReason SevInfo noSrcSpan
- (defaultUserStyle dflags)
+ defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index ef6de96340d9..474c61b563f8 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -5217,4 +5217,4 @@ initSDocContext dflags style = SDC
-- | Initialize the pretty-printing options using the default user style
initDefaultSDocContext :: DynFlags -> SDocContext
-initDefaultSDocContext dflags = initSDocContext dflags (defaultUserStyle dflags)
+initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index ef5b615f58ae..49e3b00e50ab 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -101,7 +101,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
NoReason
SevOutput
noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
sd
QuietBinIFaceReading -> \_ -> return ()
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index 3b9bb2b4aaee..9684a493b241 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -44,8 +44,7 @@ generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
renderHieType :: DynFlags -> HieTypeFix -> String
-renderHieType df ht = renderWithStyle (initSDocContext df sty) (ppr $ hieTypeToIface ht)
- where sty = defaultUserStyle df
+renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht)
resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
resolveVisibility kind ty_args
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index d208eb743371..b66bab1853d4 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -991,7 +991,6 @@ readIface :: Module -> FilePath
readIface wanted_mod file_path
= do { res <- tryMostM $
readBinIface CheckHiWay QuietBinIFaceReading file_path
- ; dflags <- getDynFlags
; case res of
Right iface
-- NB: This check is NOT just a sanity check, it is
@@ -1002,7 +1001,7 @@ readIface wanted_mod file_path
| otherwise -> return (Failed err)
where
actual_mod = mi_module iface
- err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod
+ err = hiModuleNameMismatchWarn wanted_mod actual_mod
Left exn -> return (Failed (text (showException exn)))
}
@@ -1118,7 +1117,7 @@ showIface hsc_env filename = do
neverQualifyModules
neverQualifyPackages
putLogMsg dflags NoReason SevDump noSrcSpan
- (mkDumpStyle dflags print_unqual) (pprModIface iface)
+ (mkDumpStyle print_unqual) (pprModIface iface)
-- Show a ModIface but don't display details; suitable for ModIfaces stored in
-- the EPT.
@@ -1270,8 +1269,8 @@ badIfaceFile file err
= vcat [text "Bad interface file:" <+> text file,
nest 4 err]
-hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc
-hiModuleNameMismatchWarn dflags requested_mod read_mod
+hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
+hiModuleNameMismatchWarn requested_mod read_mod
| moduleUnit requested_mod == moduleUnit read_mod =
sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,
text "but we were expecting module" <+> quotes (ppr requested_mod),
@@ -1282,7 +1281,7 @@ hiModuleNameMismatchWarn dflags requested_mod read_mod
| otherwise =
-- ToDo: This will fail to have enough qualification when the package IDs
-- are the same
- withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $
+ withPprStyle (mkUserStyle alwaysQualify AllTheWay) $
-- we want the Modules below to be qualified with package names,
-- so reset the PrintUnqualified setting.
hsep [ text "Something is amiss; requested module "
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 2a6fce5f5c34..430ef5ac7c27 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -437,7 +437,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
Err.dumpIfSet_dyn dflags Opt_D_dump_rules
(showSDoc dflags (ppr CoreTidy <+> text "rules"))
Err.FormatText
- (pprRulesForUser dflags tidy_rules)
+ (pprRulesForUser tidy_rules)
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs
index 18a8ad735d9a..a5ba2e6ef026 100644
--- a/compiler/GHC/Runtime/Linker.hs
+++ b/compiler/GHC/Runtime/Linker.hs
@@ -237,7 +237,7 @@ showLinkerState :: DynLinker -> DynFlags -> IO ()
showLinkerState dl dflags
= do pls <- readPLS dl
putLogMsg dflags NoReason SevDump noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
(vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
@@ -420,7 +420,7 @@ classifyLdInput dflags f
| isDynLibFilename platform f = return (Just (DLLPath f))
| otherwise = do
putLogMsg dflags NoReason SevInfo noSrcSpan
- (defaultUserStyle dflags)
+ defaultUserStyle
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing
where platform = targetPlatform dflags
@@ -1414,7 +1414,7 @@ load_dyn hsc_env crash_early dll = do
when (wopt Opt_WarnMissedExtraSharedLib dflags)
$ putLogMsg dflags
(Reason Opt_WarnMissedExtraSharedLib) SevWarning
- noSrcSpan (defaultUserStyle dflags)(note err)
+ noSrcSpan defaultUserStyle (note err)
where
note err = vcat $ map text
[ err
@@ -1715,7 +1715,7 @@ maybePutStr dflags s
NoReason
SevInteractive
noSrcSpan
- (defaultUserStyle dflags)
+ defaultUserStyle
(text s)
maybePutStrLn :: DynFlags -> String -> IO ()
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 0d57be272214..80ca8768f3fd 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -75,7 +75,7 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds
return ()
Just msg -> do
putLogMsg dflags NoReason Err.SevDump noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
(vcat [ text "*** Stg Lint ErrMsgs: in" <+>
text whodunnit <+> text "***",
msg,
diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs
index 7901a318b84a..3d12158b5ceb 100644
--- a/compiler/GHC/SysTools/ExtraObj.hs
+++ b/compiler/GHC/SysTools/ExtraObj.hs
@@ -77,7 +77,7 @@ mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary dflags = do
when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
putLogMsg dflags NoReason SevInfo noSrcSpan
- (defaultUserStyle dflags)
+ defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
text " Call hs_init_ghc() from your main() function to set these options.")
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index 83547ab06cbd..5482a4ef2563 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ b/compiler/GHC/SysTools/Process.hs
@@ -282,11 +282,11 @@ builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
case msg of
BuildMsg msg -> do
putLogMsg dflags NoReason SevInfo noSrcSpan
- (defaultUserStyle dflags) msg
+ defaultUserStyle msg
log_loop chan t
BuildError loc msg -> do
putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
- (defaultUserStyle dflags) msg
+ defaultUserStyle msg
log_loop chan t
EOF ->
log_loop chan (t-1)
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index b256be47f21c..6e21326f62aa 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -712,8 +712,8 @@ dumpTcRn useUserStyle dumpOpt title fmt doc = do
printer <- getPrintUnqualified dflags
real_doc <- wrapDocLoc doc
let sty = if useUserStyle
- then mkUserStyle dflags printer AllTheWay
- else mkDumpStyle dflags printer
+ then mkUserStyle printer AllTheWay
+ else mkDumpStyle printer
liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc
-- | Add current location if -dppr-debug
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 4b3683465a8c..ed12d0104e9a 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -441,7 +441,7 @@ dumpIfSet dflags flag hdr doc
NoReason
SevDump
noSrcSpan
- (defaultDumpStyle dflags)
+ defaultDumpStyle
(mkDumpDoc hdr doc)
-- | a wrapper around 'dumpAction'.
@@ -459,7 +459,7 @@ dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String
-> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn_printer printer dflags flag hdr fmt doc
= when (dopt flag dflags) $ do
- let sty = mkDumpStyle dflags printer
+ let sty = mkDumpStyle printer
dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc
mkDumpDoc :: String -> SDoc -> SDoc
@@ -627,12 +627,12 @@ compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg = do
traceEventIO $ "GHC progress: " ++ msg
ifVerbose dflags 1 $
- logOutput dflags (defaultUserStyle dflags) (text msg)
+ logOutput dflags defaultUserStyle (text msg)
showPass :: DynFlags -> String -> IO ()
showPass dflags what
= ifVerbose dflags 2 $
- logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
+ logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
data PrintTimings = PrintTimings | DontPrintTimings
deriving (Eq, Show)
@@ -727,7 +727,7 @@ withTiming' :: MonadIO m
withTiming' dflags what force_result prtimings action
= do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
then do whenPrintTimings $
- logInfo dflags (defaultUserStyle dflags) $
+ logInfo dflags defaultUserStyle $
text "***" <+> what <> colon
let ctx = initDefaultSDocContext dflags
eventBegins ctx what
@@ -743,7 +743,7 @@ withTiming' dflags what force_result prtimings action
time = realToFrac (end - start) * 1e-9
when (verbosity dflags >= 2 && prtimings == PrintTimings)
- $ liftIO $ logInfo dflags (defaultUserStyle dflags)
+ $ liftIO $ logInfo dflags defaultUserStyle
(text "!!!" <+> what <> colon <+> text "finished in"
<+> doublePrec 2 time
<+> text "milliseconds"
@@ -775,17 +775,17 @@ withTiming' dflags what force_result prtimings action
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg = ifVerbose dflags val $
- logInfo dflags (defaultDumpStyle dflags) msg
+ logInfo dflags defaultDumpStyle msg
putMsg :: DynFlags -> MsgDoc -> IO ()
-putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
+putMsg dflags msg = logInfo dflags defaultUserStyle msg
printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
- = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
+ = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
- = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
+ = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo dflags sty msg
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 1f046d235449..b103d3494ba1 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -64,7 +64,7 @@ module GHC.Utils.Outputable (
-- * Controlling the style in which output is printed
BindingSite(..),
- PprStyle, CodeStyle(..), PrintUnqualified(..),
+ PprStyle(..), CodeStyle(..), PrintUnqualified(..),
QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
reallyAlwaysQualify, reallyAlwaysQualifyNames,
alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
@@ -252,19 +252,15 @@ neverQualify = QueryQualify neverQualifyNames
neverQualifyModules
neverQualifyPackages
-defaultUserStyle :: DynFlags -> PprStyle
-defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay
+defaultUserStyle :: PprStyle
+defaultUserStyle = mkUserStyle neverQualify AllTheWay
-defaultDumpStyle :: DynFlags -> PprStyle
+defaultDumpStyle :: PprStyle
-- Print without qualifiers to reduce verbosity, unless -dppr-debug
-defaultDumpStyle dflags
- | hasPprDebug dflags = PprDebug
- | otherwise = PprDump neverQualify
+defaultDumpStyle = PprDump neverQualify
-mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle
-mkDumpStyle dflags print_unqual
- | hasPprDebug dflags = PprDebug
- | otherwise = PprDump print_unqual
+mkDumpStyle :: PrintUnqualified -> PprStyle
+mkDumpStyle print_unqual = PprDump print_unqual
defaultErrStyle :: DynFlags -> PprStyle
-- Default style for error messages, when we don't know PrintUnqualified
@@ -276,15 +272,13 @@ defaultErrStyle dflags = mkErrStyle dflags neverQualify
-- | Style for printing error messages
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle dflags qual =
- mkUserStyle dflags qual (PartWay (pprUserLength dflags))
+ mkUserStyle qual (PartWay (pprUserLength dflags))
-cmdlineParserStyle :: DynFlags -> PprStyle
-cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay
+cmdlineParserStyle :: PprStyle
+cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
-mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle
-mkUserStyle dflags unqual depth
- | hasPprDebug dflags = PprDebug
- | otherwise = PprUser unqual depth Uncoloured
+mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
+mkUserStyle unqual depth = PprUser unqual depth Uncoloured
withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc
withUserStyle unqual depth doc = sdocOption sdocPprDebug $ \case
@@ -502,13 +496,13 @@ printSDocLn ctx mode handle doc =
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser dflags handle unqual doc
= printSDocLn ctx PageMode handle doc
- where ctx = initSDocContext dflags (mkUserStyle dflags unqual AllTheWay)
+ where ctx = initSDocContext dflags (mkUserStyle unqual AllTheWay)
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
-> IO ()
printForUserPartWay dflags handle d unqual doc
= printSDocLn ctx PageMode handle doc
- where ctx = initSDocContext dflags (mkUserStyle dflags unqual (PartWay d))
+ where ctx = initSDocContext dflags (mkUserStyle unqual (PartWay d))
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@. This is typically used to output C-- code.
@@ -533,7 +527,7 @@ mkCodeStyle = PprCode
-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: DynFlags -> SDoc -> String
-showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags (defaultUserStyle dflags)) sdoc
+showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags defaultUserStyle) sdoc
-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
-- initialised yet.
@@ -550,10 +544,10 @@ showSDocUnqual dflags sdoc = showSDoc dflags sdoc
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-- Allows caller to specify the PrintUnqualified to use
showSDocForUser dflags unqual doc
- = renderWithStyle (initSDocContext dflags (mkUserStyle dflags unqual AllTheWay)) doc
+ = renderWithStyle (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc
showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d = renderWithStyle (initSDocContext dflags (defaultDumpStyle dflags)) d
+showSDocDump dflags d = renderWithStyle (initSDocContext dflags defaultDumpStyle) d
showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug dflags d = renderWithStyle (initSDocContext dflags PprDebug) d
@@ -579,7 +573,7 @@ showSDocDumpOneLine dflags d
= let s = Pretty.style{ Pretty.mode = OneLineMode,
Pretty.lineLength = irrelevantNCols } in
Pretty.renderStyle s $
- runSDoc d (initSDocContext dflags (defaultDumpStyle dflags))
+ runSDoc d (initSDocContext dflags defaultDumpStyle)
irrelevantNCols :: Int
-- Used for OneLineMode and LeftMode when number of cols isn't used
--
GitLab