diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-03-17 15:32:32 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-01 10:37:39 -0400 |
| commit | f8386c7b6a9d26bc5fd2c1d74d944c8df6337690 (patch) | |
| tree | 2160d6880a430f07f4a0ac7a58b0355afe139649 /compiler/GHC/Core/Lint.hs | |
| parent | 780de9e11014a88a4f676eb296c30fec2b07b5c2 (diff) | |
| download | haskell-f8386c7b6a9d26bc5fd2c1d74d944c8df6337690.tar.gz | |
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`.
Diffstat (limited to 'compiler/GHC/Core/Lint.hs')
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 10 |
1 files changed, 5 insertions, 5 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index bc74b7d393..b72bf0f1c5 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 |