Commit f8386c7b authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot
Browse files

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`.
parent 780de9e1
......@@ -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
......
......@@ -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
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 }
......
......@@ -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 }
......@@ -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]
......
......@@ -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
......
......@@ -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)
-- ----------------------------------------------------------------------------
......
......@@ -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
}
......
......@@ -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.")
......
......@@ -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
......@@ -101,7 +101,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
NoReason
SevOutput
noSrcSpan
(defaultDumpStyle dflags)
defaultDumpStyle
sd
QuietBinIFaceReading -> \_ -> return ()
......
......@@ -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
......
......@@ -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 "
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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,
......
......@@ -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.")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment