Commit c8c18a10 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Some refactoring around endPass and debug dumping

I forget all the details, but I spent some time trying to
understand the current setup, and tried to simplify it a bit
parent 27ba070c
......@@ -21,7 +21,7 @@ import PrelNames
import CoreUtils
import CoreArity
import CoreFVs
import CoreMonad ( endPass, CoreToDo(..) )
import CoreMonad ( endPassIO, CoreToDo(..) )
import CoreSyn
import CoreSubst
import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
......@@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do
floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
endPass hsc_env CorePrep binds_out []
endPassIO hsc_env alwaysQualify CorePrep binds_out []
return binds_out
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
......
......@@ -39,7 +39,7 @@ import Rules
import TysPrim (eqReprPrimTyCon)
import TysWiredIn (coercibleTyCon )
import BasicTypes ( Activation(.. ) )
import CoreMonad ( endPass, CoreToDo(..) )
import CoreMonad ( endPassIO, CoreToDo(..) )
import MkCore
import FastString
import ErrUtils
......@@ -94,6 +94,7 @@ deSugar hsc_env
tcg_hpc = other_hpc_info })
= do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
; showPass dflags "Desugar"
-- Desugar the program
......@@ -147,14 +148,14 @@ deSugar hsc_env
#ifdef DEBUG
-- Debug only as pre-simple-optimisation program may be really big
; endPass hsc_env CoreDesugar final_pgm rules_for_imps
; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
#endif
; (ds_binds, ds_rules_for_imps, ds_vects)
<- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps
; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
; deps <- mkDependencies tcg_env
......
......@@ -29,6 +29,7 @@ import Kind
import GHC
import Outputable
import PprTyThing
import ErrUtils
import MonadUtils
import DynFlags
import Exception
......
......@@ -52,8 +52,6 @@ module DynFlags (
tablesNextToCode, mkTablesNextToCode,
SigOf(..), getSigOf,
printOutputForUser, printInfoForUser,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags,
......@@ -1557,16 +1555,6 @@ newtype FlushErr = FlushErr (IO ())
defaultFlushErr :: FlushErr
defaultFlushErr = FlushErr $ hFlush stderr
printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser = printSevForUser SevOutput
printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
printInfoForUser = printSevForUser SevInfo
printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printSevForUser sev dflags unqual doc
= log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
{-
Note [Verbosity levels]
~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -27,7 +27,8 @@ module ErrUtils (
mkDumpDoc, dumpSDoc,
-- * Messages during compilation
putMsg, putMsgWith,
putMsg, printInfoForUser, printOutputForUser,
logInfo, logOutput,
errorMsg,
fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
compilationProgressMsg,
......@@ -237,7 +238,7 @@ dumpIfSet dflags flag hdr doc
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags
= dumpSDoc dflags flag hdr doc
= dumpSDoc dflags alwaysQualify flag hdr doc
| otherwise
= return ()
......@@ -254,12 +255,13 @@ mkDumpDoc hdr doc
-- | Write out a dump.
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
--
--
-- When hdr is empty, we print in a more compact format (no separators and
-- blank lines)
dumpSDoc :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc dflags flag hdr doc
dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc dflags print_unqual flag hdr doc
= do let mFile = chooseDumpFile dflags flag
dump_style = mkDumpStyle print_unqual
case mFile of
Just fileName
-> do
......@@ -278,7 +280,7 @@ dumpSDoc dflags flag hdr doc
$$ blankLine
$$ doc
return $ mkDumpDoc hdr d
defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle
defaultLogActionHPrintDoc dflags handle doc' dump_style
hClose handle
-- write the dump to stdout
......@@ -286,7 +288,7 @@ dumpSDoc dflags flag hdr doc
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
log_action dflags dflags severity noSrcSpan dump_style doc'
-- | Choose where to put a dump file based on DynFlags
......@@ -340,18 +342,9 @@ ifVerbose dflags val act
| verbosity dflags >= val = act
| otherwise = return ()
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
putMsgWith dflags print_unqual msg
= log_action dflags dflags SevInfo noSrcSpan sty msg
where
sty = mkUserStyle print_unqual AllTheWay
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg =
log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
errorMsg dflags msg
= log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
......@@ -365,25 +358,45 @@ fatalErrorMsg'' fm msg = fm msg
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
= ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
= ifVerbose dflags 1 $
logOutput dflags defaultUserStyle (text msg)
showPass :: DynFlags -> String -> IO ()
showPass dflags what
= ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
= ifVerbose dflags 2 $
logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg
= ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
debugTraceMsg dflags val msg = ifVerbose dflags val $
logInfo dflags defaultDumpStyle msg
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = logInfo dflags defaultUserStyle msg
printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
= logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
= logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg
logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- Like logInfo but with SevOutput rather then SevInfo
logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
= ghandle $ \e -> case e of
PprPanic str doc ->
pprDebugAndThen dflags panic str doc
pprDebugAndThen dflags panic (text str) doc
PprSorry str doc ->
pprDebugAndThen dflags sorry str doc
pprDebugAndThen dflags sorry (text str) doc
PprProgramError str doc ->
pprDebugAndThen dflags pgmError str doc
pprDebugAndThen dflags pgmError (text str) doc
_ ->
liftIO $ throwIO e
\end{code}
......
......@@ -141,7 +141,7 @@ mkBootModDetailsTc hsc_env
tcg_fam_insts = fam_insts
}
= do { let dflags = hsc_dflags hsc_env
; showPass dflags CoreTidy
; showPassIO dflags CoreTidy
; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts
; type_env1 = mkBootTypeEnv (availsToNameSet exports)
......@@ -302,6 +302,7 @@ RHSs, so that they print nicely in interfaces.
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_exports = exports
, mg_rdr_env = rdr_env
, mg_tcs = tcs
, mg_insts = insts
, mg_fam_insts = fam_insts
......@@ -319,8 +320,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
= do { let { dflags = hsc_dflags hsc_env
; omit_prags = gopt Opt_OmitInterfacePragmas dflags
; expose_all = gopt Opt_ExposeAllUnfoldings dflags
; print_unqual = mkPrintUnqualified dflags rdr_env
}
; showPass dflags CoreTidy
; showPassIO dflags CoreTidy
; let { type_env = typeEnvFromEntities [] tcs fam_insts
......@@ -378,7 +380,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
; endPass hsc_env CoreTidy all_tidy_binds tidy_rules
; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
-- If the endPass didn't print the rules, but ddump-rules is
-- on, print now
......
......@@ -316,8 +316,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
$ [ Color.raGraph stat
| stat@Color.RegAllocStatsStart{} <- stats]
dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
$ Color.pprStats stats graphGlobal
dump_stats (Color.pprStats stats graphGlobal)
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
......@@ -332,13 +331,14 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
-- dump global NCG stats for linear allocator
(case concat $ catMaybes linearStats of
[] -> return ()
stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
$ Linear.pprStats (concat native) stats)
stats -> dump_stats (Linear.pprStats (concat native) stats))
-- write out the imports
Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports)
where
dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
......
......@@ -28,6 +28,7 @@ module CoreMonad (
-- ** Reading from the monad
getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache, getPackageFamInstEnv,
getPrintUnqualified,
-- ** Writing to the monad
addSimplCount,
......@@ -43,7 +44,7 @@ module CoreMonad (
getAnnotations, getFirstAnnotations,
-- ** Debug output
showPass, endPass, dumpPassResult, lintPassResult,
showPass, showPassIO, endPass, endPassIO, dumpPassResult, lintPassResult,
lintInteractiveExpr, dumpIfSet,
-- ** Screen output
......@@ -132,15 +133,28 @@ be, and it makes a conveneint place. place for them. They print out
stuff before and after core passes, and do Core Lint when necessary.
\begin{code}
showPass :: DynFlags -> CoreToDo -> IO ()
showPass dflags pass = Err.showPass dflags (showPpr dflags pass)
endPass :: HscEnv -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPass hsc_env pass binds rules
= do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules
showPass :: CoreToDo -> CoreM ()
showPass pass = do { dflags <- getDynFlags
; liftIO $ showPassIO dflags pass }
showPassIO :: DynFlags -> CoreToDo -> IO ()
showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass)
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass pass binds rules
= do { hsc_env <- getHscEnv
; print_unqual <- getPrintUnqualified
; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
endPassIO :: HscEnv -> PrintUnqualified
-> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
-- Used by the IO-is CorePrep too
endPassIO hsc_env print_unqual pass binds rules
= do { dumpPassResult dflags print_unqual mb_flag
(ppr pass) (pprPassDetails pass) binds rules
; lintPassResult hsc_env pass binds }
where
dflags = hsc_dflags hsc_env
dflags = hsc_dflags hsc_env
mb_flag = case coreDumpFlag pass of
Just flag | dopt flag dflags -> Just flag
| dopt Opt_D_verbose_core2core dflags -> Just flag
......@@ -151,15 +165,16 @@ dumpIfSet dflags dump_me pass extra_info doc
= Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
dumpPassResult :: DynFlags
-> Maybe DumpFlag -- Just df => show details in a file whose
-> PrintUnqualified
-> Maybe DumpFlag -- Just df => show details in a file whose
-- name is specified by df
-> SDoc -- Header
-> SDoc -- Extra info to appear after header
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult dflags mb_flag hdr extra_info binds rules
dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
| Just flag <- mb_flag
= Err.dumpSDoc dflags flag (showSDoc dflags hdr) dump_doc
= Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
| otherwise
= Err.debugTraceMsg dflags 2 size_doc
......@@ -781,6 +796,7 @@ data CoreReader = CoreReader {
cr_hsc_env :: HscEnv,
cr_rule_base :: RuleBase,
cr_module :: Module,
cr_print_unqual :: PrintUnqualified,
#ifdef GHCI
cr_globals :: (MVar PersistentLinkerState, Bool)
#else
......@@ -854,9 +870,10 @@ runCoreM :: HscEnv
-> RuleBase
-> UniqSupply
-> Module
-> PrintUnqualified
-> CoreM a
-> IO (a, SimplCount)
runCoreM hsc_env rule_base us mod m = do
runCoreM hsc_env rule_base us mod print_unqual m = do
glbls <- saveLinkerGlobals
liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
where
......@@ -864,7 +881,8 @@ runCoreM hsc_env rule_base us mod m = do
cr_hsc_env = hsc_env,
cr_rule_base = rule_base,
cr_module = mod,
cr_globals = glbls
cr_globals = glbls,
cr_print_unqual = print_unqual
}
state = CoreState {
cs_uniq_supply = us
......@@ -934,6 +952,9 @@ getHscEnv = read cr_hsc_env
getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base
getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified = read cr_print_unqual
addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count })
......
......@@ -76,9 +76,9 @@ core2core hsc_env guts
; let builtin_passes = getCoreToDo dflags
;
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
do { all_passes <- addPluginPasses dflags builtin_passes
; runCorePasses all_passes guts }
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
do { all_passes <- addPluginPasses dflags builtin_passes
; runCorePasses all_passes guts }
{--
; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline
......@@ -99,6 +99,7 @@ core2core hsc_env guts
-- consume the ModGuts to find the module) but somewhat ugly because mg_module may
-- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
-- would mean our cached value would go out of date.
print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
\end{code}
......@@ -384,11 +385,9 @@ runCorePasses passes guts
do_pass guts CoreDoNothing = return guts
do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
do_pass guts pass
= do { hsc_env <- getHscEnv
; let dflags = hsc_dflags hsc_env
; liftIO $ showPass dflags pass
= do { showPass pass
; guts' <- doCorePass pass guts
; liftIO $ endPass hsc_env pass (mg_binds guts') (mg_rules guts')
; endPass pass (mg_binds guts') (mg_rules guts')
; return guts' }
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
......@@ -596,6 +595,7 @@ simplifyPgmIO :: CoreToDo
simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
hsc_env us hpt_rule_base
guts@(ModGuts { mg_module = this_mod
, mg_rdr_env = rdr_env
, mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
= do { (termination_msg, it_count, counts_out, guts')
......@@ -610,10 +610,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
; return (counts_out, guts')
}
where
dflags = hsc_dflags hsc_env
dump_phase = dumpSimplPhase dflags mode
simpl_env = mkSimplEnv mode
active_rule = activeRule simpl_env
dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
dump_phase = dumpSimplPhase dflags mode
simpl_env = mkSimplEnv mode
active_rule = activeRule simpl_env
do_iteration :: UniqSupply
-> Int -- Counts iterations
......@@ -709,7 +710,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
-- Dump the result of this iteration
dump_end_iteration dflags iteration_no counts1 binds2 rules1 ;
dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
lintPassResult hsc_env pass binds2 ;
-- Loop
......@@ -727,10 +728,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
-------------------
dump_end_iteration :: DynFlags -> Int
-> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
dump_end_iteration dflags iteration_no counts binds rules
= dumpPassResult dflags mb_flag hdr pp_counts binds rules
dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
-> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
dump_end_iteration dflags print_unqual iteration_no counts binds rules
= dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules
where
mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases
| otherwise = Nothing
......
......@@ -29,6 +29,7 @@ import CoreMonad
import Outputable
import FastString
import MonadUtils
import ErrUtils
import Control.Monad ( when, liftM, ap )
\end{code}
......
......@@ -1615,8 +1615,9 @@ tryRules env rules fn args call_cont
| otherwise
= return ()
log_rule dflags flag hdr details = liftIO . dumpSDoc dflags flag "" $
sep [text hdr, nest 4 details]
log_rule dflags flag hdr details
= liftIO . dumpSDoc dflags alwaysQualify flag "" $
sep [text hdr, nest 4 details]
\end{code}
Note [Optimising tagToEnum#]
......
......@@ -390,8 +390,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
; dflags <- getDynFlags
; unless (isEmptyBag inst_info) $
liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds newTyCons famInsts))
liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds newTyCons famInsts))
; let all_tycons = map ATyCon (bagToList newTyCons)
; gbl_env <- tcExtendGlobalEnv all_tycons $
......
......@@ -41,7 +41,7 @@ module Outputable (
-- * Converting 'SDoc' into strings and outputing it
printForC, printForAsm, printForUser, printForUserPartWay,
pprCode, mkCodeStyle,
showSDoc, showSDocOneLine,
showSDoc, showSDocSimple, showSDocOneLine,
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
showSDocUnqual, showPpr,
renderWithStyle,
......@@ -64,7 +64,7 @@ module Outputable (
pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
ifPprDebug, qualName, qualModule, qualPackage,
mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
mkUserStyle, cmdlineParserStyle, Depth(..),
-- * Error handling and debugging utilities
......@@ -125,15 +125,16 @@ data PprStyle
-- Assumes printing tidied code: non-system names are
-- printed without uniques.
| PprCode CodeStyle
-- Print code; either C or assembler
| PprDump -- For -ddump-foo; less verbose than PprDebug.
| PprDump PrintUnqualified
-- For -ddump-foo; less verbose than PprDebug, but more than PprUser
-- Does not assume tidied code: non-external names
-- are printed with uniques.
| PprDebug -- Full debugging output
| PprCode CodeStyle
-- Print code; either C or assembler
data CodeStyle = CStyle -- The format of labels differs for C and assembler
| AsmStyle
......@@ -221,7 +222,11 @@ defaultUserStyle = mkUserStyle neverQualify AllTheWay
-- Print without qualifiers to reduce verbosity, unless -dppr-debug
defaultDumpStyle | opt_PprStyle_Debug = PprDebug
| otherwise = PprDump
| otherwise = PprDump neverQualify
mkDumpStyle :: PrintUnqualified -> PprStyle
mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug
| otherwise = PprDump print_unqual
defaultErrStyle :: DynFlags -> PprStyle
-- Default style for error messages, when we don't know PrintUnqualified
......@@ -324,15 +329,18 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
\begin{code}
qualName :: PprStyle -> QueryQualifyName
qualName (PprUser q _) mod occ = queryQualifyName q mod occ
qualName (PprDump q) mod occ = queryQualifyName q mod occ
qualName _other mod _ = NameQual (moduleName mod)
qualModule :: PprStyle -> QueryQualifyModule
qualModule (PprUser q _) m = queryQualifyModule q m
qualModule _other _m = True
qualModule (PprDump q) m = queryQualifyModule q m
qualModule _other _m = True
qualPackage :: PprStyle -> QueryQualifyPackage
qualPackage (PprUser q _) m = queryQualifyPackage q m
qualPackage _other _m = True
qualPackage (PprDump q) m = queryQualifyPackage q m
qualPackage _other _m = True
queryQual :: PprStyle -> PrintUnqualified
queryQual s = QueryQualify (qualName s)
......@@ -348,8 +356,8 @@ asmStyle (PprCode AsmStyle) = True
asmStyle _other = False
dumpStyle :: PprStyle -> Bool
dumpStyle PprDump = True
dumpStyle _other = False
dumpStyle (PprDump {}) = True
dumpStyle _other = False
debugStyle :: PprStyle -> Bool
debugStyle PprDebug = True
......@@ -402,6 +410,27 @@ mkCodeStyle = PprCode
showSDoc :: DynFlags -> SDoc -> String
showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
showSDocSimple :: SDoc -> String
showSDocSimple sdoc = showSDoc unsafeGlobalDynFlags sdoc
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags thing = showSDoc dflags (ppr thing)
showSDocUnqual :: DynFlags -> SDoc -> String
-- Only used by Haddock
showSDocUnqual dflags sdoc = showSDoc dflags sdoc
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-- Allows caller to specify the PrintUnqualified to use
showSDocForUser dflags unqual doc
= renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
showSDocDump :: DynFlags -> SDoc -> String
showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug dflags d = renderWithStyle dflags d PprDebug
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
renderWithStyle dflags sdoc sty
= Pretty.showDoc PageMode (pprCols dflags) $
......@@ -415,28 +444,10 @@ showSDocOneLine dflags d
= Pretty.showDoc OneLineMode (pprCols dflags) $
runSDoc d (initSDocContext dflags defaultUserStyle)
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
showSDocForUser dflags unqual doc
= renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
showSDocUnqual :: DynFlags -> SDoc -> String
-- Only used by Haddock
showSDocUnqual dflags doc
= renderWithStyle dflags doc (mkUserStyle neverQualify AllTheWay)
showSDocDump :: DynFlags -> SDoc -> String
showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug dflags d = renderWithStyle dflags d PprDebug
showSDocDumpOneLine :: DynFlags -> SDoc -> String
showSDocDumpOneLine dflags d
= Pretty.showDoc OneLineMode irrelevantNCols $
runSDoc d (initSDocContext dflags PprDump)
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags thing = showSDoc dflags (ppr thing)
runSDoc d (initSDocContext dflags defaultDumpStyle)
irrelevantNCols :: Int
-- Used for OneLineMode and LeftMode when number of cols isn't used
......@@ -1000,7 +1011,7 @@ pprTrace :: String -> SDoc -> a -> a
-- ^ If debug output is on, show some 'SDoc' on the screen
pprTrace str doc x
| opt_NoDebugOutput = x
| otherwise = pprDebugAndThen unsafeGlobalDynFlags trace str doc x
| otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
pprPanicFastInt :: String -> SDoc -> FastInt
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
......@@ -1013,9 +1024,9 @@ warnPprTrace _ _ _ _ x | not debugIsOn = x
warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True file line msg x
= pprDebugAndThen unsafeGlobalDynFlags trace str msg x
= pprDebugAndThen unsafeGlobalDynFlags trace heading msg x
where
str = showSDoc unsafeGlobalDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line])
heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
......@@ -1027,10 +1038,10 @@ assertPprPanic file line msg
, text "line", int line ]
, msg ]
pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a
pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen dflags cont heading pretty_msg
= cont (showSDocDump dflags doc)
where
doc = sep [text heading, nest 4 pretty_msg]
doc = sep [heading, nest 2 pretty_msg]
\end{code}
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