module GHC.Utils.Error (
Validity(..), andValid, allValid, isValid, getInvalids, orValid,
Severity(..),
ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
WarnMsg, MsgDoc,
Messages, ErrorMessages, WarningMessages,
unionMessages,
errMsgSpan, errMsgContext,
errorsFound, isEmptyMessages,
isWarnMsgFatal,
warningsToMessages,
pprMessageBag, pprErrMsgBagWithLoc,
pprLocErrMsg, printBagOfErrors,
formatErrDoc,
emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
mkPlainWarnMsg,
mkLongWarnMsg,
doIfSet, doIfSet_dyn,
getCaretDiagnostic,
dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
dumpOptionsFromFlag, DumpOptions (..),
DumpFormat (..), DumpAction, dumpAction, defaultDumpAction,
TraceAction, traceAction, defaultTraceAction,
touchDumpFile,
putMsg, printInfoForUser, printOutputForUser,
logInfo, logOutput,
errorMsg, warningMsg,
fatalErrorMsg, fatalErrorMsg'',
compilationProgressMsg,
showPass,
withTiming, withTimingSilent, withTimingD, withTimingSilentD,
debugTraceMsg,
ghcExit,
prettyPrintGhcErrors,
traceCmd
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Data.Bag
import GHC.Utils.Exception
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json
import System.Directory
import System.Exit ( ExitCode(..), exitWith )
import System.FilePath ( takeDirectory, (</>) )
import Data.List
import qualified Data.Set as Set
import Data.IORef
import Data.Maybe ( fromMaybe )
import Data.Function
import Data.Time
import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch as MC (handle)
import System.IO
import System.IO.Error ( catchIOError )
import GHC.Conc ( getAllocationCounter )
import System.CPUTime
type MsgDoc = SDoc
data Validity
= IsValid
| NotValid MsgDoc
isValid :: Validity -> Bool
isValid IsValid = True
isValid (NotValid {}) = False
andValid :: Validity -> Validity -> Validity
andValid IsValid v = v
andValid v _ = v
allValid :: [Validity] -> Validity
allValid [] = IsValid
allValid (v : vs) = v `andValid` allValid vs
getInvalids :: [Validity] -> [MsgDoc]
getInvalids vs = [d | NotValid d <- vs]
orValid :: Validity -> Validity -> Validity
orValid IsValid _ = IsValid
orValid _ v = v
type Messages = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages = Bag ErrMsg
unionMessages :: Messages -> Messages -> Messages
unionMessages (warns1, errs1) (warns2, errs2) =
(warns1 `unionBags` warns2, errs1 `unionBags` errs2)
data ErrMsg = ErrMsg {
errMsgSpan :: SrcSpan,
errMsgContext :: PrintUnqualified,
errMsgDoc :: ErrDoc,
errMsgShortString :: String,
errMsgSeverity :: Severity,
errMsgReason :: WarnReason
}
data ErrDoc = ErrDoc {
errDocImportant :: [MsgDoc],
errDocContext :: [MsgDoc],
errDocSupplementary :: [MsgDoc]
}
errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
errDoc = ErrDoc
type WarnMsg = ErrMsg
data Severity
= SevOutput
| SevFatal
| SevInteractive
| SevDump
| SevInfo
| SevWarning
| SevError
deriving Show
instance ToJson Severity where
json s = JSString (show s)
instance Show ErrMsg where
show em = errMsgShortString em
pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage = mkLocMessageAnn Nothing
mkLocMessageAnn
:: Maybe String
-> Severity
-> SrcSpan
-> MsgDoc
-> MsgDoc
mkLocMessageAnn ann severity locn msg
= sdocOption sdocColScheme $ \col_scheme ->
let locn' = sdocOption sdocErrorSpans $ \case
True -> ppr locn
False -> ppr (srcSpanStart locn)
sevColour = getSeverityColour severity col_scheme
optAnn = case ann of
Nothing -> text ""
Just i -> text " [" <> coloured sevColour (text i) <> text "]"
header = locn' <> colon <+>
coloured sevColour sevText <> optAnn
in coloured (Col.sMessage col_scheme)
(hang (coloured (Col.sHeader col_scheme) header) 4
msg)
where
sevText =
case severity of
SevWarning -> text "warning:"
SevError -> text "error:"
SevFatal -> text "fatal:"
_ -> empty
getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour SevWarning = Col.sWarning
getSeverityColour SevError = Col.sError
getSeverityColour SevFatal = Col.sFatal
getSeverityColour _ = const mempty
getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
getCaretDiagnostic severity (RealSrcSpan span _) = do
caretDiagnostic <$> getSrcLine (srcSpanFile span) row
where
getSrcLine fn i =
getLine i (unpackFS fn)
`catchIOError` \_ ->
pure Nothing
getLine i fn = do
content <- hGetStringBuffer fn
case atLine i content of
Just at_line -> pure $
case lines (fix <$> lexemeToString at_line (len at_line)) of
srcLine : _ -> Just srcLine
_ -> Nothing
_ -> pure Nothing
fix '\0' = '\xfffd'
fix c = c
row = srcSpanStartLine span
rowStr = show row
multiline = row /= srcSpanEndLine span
caretDiagnostic Nothing = empty
caretDiagnostic (Just srcLineWithNewline) =
sdocOption sdocColScheme$ \col_scheme ->
let sevColour = getSeverityColour severity col_scheme
marginColour = Col.sMargin col_scheme
in
coloured marginColour (text marginSpace) <>
text ("\n") <>
coloured marginColour (text marginRow) <>
text (" " ++ srcLinePre) <>
coloured sevColour (text srcLineSpan) <>
text (srcLinePost ++ "\n") <>
coloured marginColour (text marginSpace) <>
coloured sevColour (text (" " ++ caretLine))
where
expandTabs tabWidth i s =
case s of
"" -> ""
'\t' : cs -> replicate effectiveWidth ' ' ++
expandTabs tabWidth (i + effectiveWidth) cs
c : cs -> c : expandTabs tabWidth (i + 1) cs
where effectiveWidth = tabWidth i `mod` tabWidth
srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)
start = srcSpanStartCol span 1
end | multiline = length srcLine
| otherwise = srcSpanEndCol span 1
width = max 1 (end start)
marginWidth = length rowStr
marginSpace = replicate marginWidth ' ' ++ " |"
marginRow = rowStr ++ " |"
(srcLinePre, srcLineRest) = splitAt start srcLine
(srcLineSpan, srcLinePost) = splitAt width srcLineRest
caretEllipsis | multiline = "..."
| otherwise = ""
caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason err = err
{ errMsgSeverity = SevWarning
, errMsgReason = reason }
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg dflags sev locn print_unqual doc
= ErrMsg { errMsgSpan = locn
, errMsgContext = print_unqual
, errMsgDoc = doc
, errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
, errMsgSeverity = sev
, errMsgReason = NoReason }
mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc dflags = mk_err_msg dflags SevError
mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)
isEmptyMessages :: Messages -> Bool
isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
errorsFound :: DynFlags -> Messages -> Bool
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
warningsToMessages :: DynFlags -> WarningMessages -> Messages
warningsToMessages dflags =
partitionBagWith $ \warn ->
case isWarnMsgFatal dflags warn of
Nothing -> Left warn
Just err_reason ->
Right warn{ errMsgSeverity = SevError
, errMsgReason = ErrReason err_reason }
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle unqual
ctx = initSDocContext dflags style
in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc)
| ErrMsg { errMsgSpan = s,
errMsgDoc = doc,
errMsgSeverity = sev,
errMsgReason = reason,
errMsgContext = unqual } <- sortMsgBag (Just dflags)
bag_of_errors ]
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 ctx))
[important, context, supplementary]
starred = (bullet<+>) . vcat
pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
pprLocErrMsg :: ErrMsg -> SDoc
pprLocErrMsg (ErrMsg { errMsgSpan = s
, errMsgDoc = doc
, errMsgSeverity = sev
, errMsgContext = unqual })
= sdocWithContext $ \ctx ->
withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc)
sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
where cmp
| fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest
| otherwise = SrcLoc.leftmost_smallest
maybeLimit = case join (fmap maxErrors dflags) of
Nothing -> id
Just err_limit -> take err_limit
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
| val == 0 = exitWith ExitSuccess
| otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
exitWith (ExitFailure val)
doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag = action
| otherwise = return ()
doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | gopt flag dflags = action
| otherwise = return ()
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
| not flag = return ()
| otherwise = doDump dflags hdr doc
doDump :: DynFlags -> String -> SDoc -> IO ()
doDump dflags hdr doc =
putLogMsg dflags
NoReason
SevDump
noSrcSpan
(withPprStyle defaultDumpStyle
(mkDumpDoc hdr doc))
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify
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 printer
dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc
mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc hdr doc
= vcat [blankLine,
line <+> text hdr <+> line,
doc,
blankLine]
where
line = text (replicate 20 '=')
touchDumpFile :: DynFlags -> DumpOptions -> IO ()
touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ()))
withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle dflags dumpOpt action = do
let mFile = chooseDumpFile dflags dumpOpt
case mFile of
Just fileName -> do
let gdref = generatedDumps dflags
gd <- readIORef gdref
let append = Set.member fileName gd
mode = if append then AppendMode else WriteMode
unless append $
writeIORef gdref (Set.insert fileName gd)
createDirectoryIfMissing True (takeDirectory fileName)
withFile fileName mode $ \handle -> do
hSetEncoding handle utf8
action (Just handle)
Nothing -> action Nothing
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags dumpOpt hdr doc =
withDumpFileHandle dflags dumpOpt writeDump
where
writeDump (Just handle) = do
doc' <- if null hdr
then return doc
else do t <- getCurrentTime
let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
then empty
else text (show t)
let d = timeStamp
$$ blankLine
$$ doc
return $ mkDumpDoc hdr d
defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc')
writeDump Nothing = do
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc')
chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath
chooseDumpFile dflags dumpOpt
| gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt
, Just prefix <- getPrefix
= Just $ setDir (prefix ++ dumpSuffix dumpOpt)
| otherwise
= Nothing
where getPrefix
| Just prefix <- dumpPrefixForce dflags
= Just prefix
| Just prefix <- dumpPrefix dflags
= Just prefix
| otherwise
= Nothing
setDir f = case dumpDir dflags of
Just d -> d </> f
Nothing -> f
data DumpOptions = DumpOptions
{ dumpForcedToFile :: Bool
, dumpSuffix :: String
}
dumpOptionsFromFlag :: DumpFlag -> DumpOptions
dumpOptionsFromFlag Opt_D_th_dec_file =
DumpOptions
{ dumpForcedToFile = True
, dumpSuffix = "th.hs"
}
dumpOptionsFromFlag flag =
DumpOptions
{ dumpForcedToFile = False
, dumpSuffix = suffix
}
where
str = show flag
suff = case stripPrefix "Opt_D_" str of
Just x -> x
Nothing -> panic ("Bad flag name: " ++ str)
suffix = map (\c -> if c == '_' then '-' else c) suff
ifVerbose :: DynFlags -> Int -> IO () -> IO ()
ifVerbose dflags val act
| verbosity dflags >= val = act
| otherwise = return ()
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg
= putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
= putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg =
putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg = do
traceEventIO $ "GHC progress: " ++ msg
ifVerbose dflags 1 $
logOutput dflags $ withPprStyle defaultUserStyle (text msg)
showPass :: DynFlags -> String -> IO ()
showPass dflags what
= ifVerbose dflags 2 $
logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)
data PrintTimings = PrintTimings | DontPrintTimings
deriving (Eq, Show)
withTiming :: MonadIO m
=> DynFlags
-> SDoc
-> (a -> ())
-> m a
-> m a
withTiming dflags what force action =
withTiming' dflags what force PrintTimings action
withTimingD :: (MonadIO m, HasDynFlags m)
=> SDoc
-> (a -> ())
-> m a
-> m a
withTimingD what force action = do
dflags <- getDynFlags
withTiming' dflags what force PrintTimings action
withTimingSilent
:: MonadIO m
=> DynFlags
-> SDoc
-> (a -> ())
-> m a
-> m a
withTimingSilent dflags what force action =
withTiming' dflags what force DontPrintTimings action
withTimingSilentD
:: (MonadIO m, HasDynFlags m)
=> SDoc
-> (a -> ())
-> m a
-> m a
withTimingSilentD what force action = do
dflags <- getDynFlags
withTiming' dflags what force DontPrintTimings action
withTiming' :: MonadIO m
=> DynFlags
-> SDoc
-> (a -> ())
-> PrintTimings
-> m a
-> m a
withTiming' dflags what force_result prtimings action
= do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
then do whenPrintTimings $
logInfo dflags $ withPprStyle defaultUserStyle $
text "***" <+> what <> colon
let ctx = initDefaultSDocContext dflags
eventBegins ctx what
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
!r <- action
() <- pure $ force_result r
eventEnds ctx what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
let alloc = alloc0 alloc1
time = realToFrac (end start) * 1e-9
when (verbosity dflags >= 2 && prtimings == PrintTimings)
$ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle
(text "!!!" <+> what <> colon <+> text "finished in"
<+> doublePrec 2 time
<+> text "milliseconds"
<> comma
<+> text "allocated"
<+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
<+> text "megabytes")
whenPrintTimings $
dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText
$ text $ showSDocOneLine ctx
$ hsep [ what <> colon
, text "alloc=" <> ppr alloc
, text "time=" <> doublePrec 3 time
]
pure r
else action
where whenPrintTimings = liftIO . when (prtimings == PrintTimings)
eventBegins ctx w = do
whenPrintTimings $ traceMarkerIO (eventBeginsDoc ctx w)
liftIO $ traceEventIO (eventBeginsDoc ctx w)
eventEnds ctx w = do
whenPrintTimings $ traceMarkerIO (eventEndsDoc ctx w)
liftIO $ traceEventIO (eventEndsDoc ctx w)
eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w
eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg =
ifVerbose dflags val $
logInfo dflags (withPprStyle defaultDumpStyle msg)
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg)
printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
= logInfo dflags (withUserStyle print_unqual AllTheWay msg)
printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
= logOutput dflags (withUserStyle print_unqual AllTheWay msg)
logInfo :: DynFlags -> MsgDoc -> IO ()
logInfo dflags msg
= putLogMsg dflags NoReason SevInfo noSrcSpan msg
logOutput :: DynFlags -> MsgDoc -> IO ()
logOutput dflags msg
= putLogMsg dflags NoReason SevOutput noSrcSpan msg
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
= MC.handle $ \e -> case e of
PprPanic str doc ->
pprDebugAndThen dflags panic (text str) doc
PprSorry str doc ->
pprDebugAndThen dflags sorry (text str) doc
PprProgramError str doc ->
pprDebugAndThen dflags pgmError (text str) doc
_ ->
liftIO $ throwIO e
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
= if wopt_fatal wflag dflags
then Just (Just wflag)
else Nothing
isWarnMsgFatal dflags _
= if gopt Opt_WarnIsError dflags
then Just Nothing
else Nothing
traceCmd :: DynFlags -> String -> String -> IO a -> IO a
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
; showPass dflags phase_name
; debugTraceMsg dflags 3 (text cmd_line)
; case flushErr dflags of
FlushErr io -> io
; action `catchIO` handle_exn verb
}
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2
(text "Failed:"
<+> text cmd_line
<+> text (show exn))
; throwGhcExceptionIO (ProgramError (show exn))}
data DumpFormat
= FormatHaskell
| FormatCore
| FormatSTG
| FormatByteCode
| FormatCMM
| FormatASM
| FormatC
| FormatLLVM
| FormatText
deriving (Show,Eq)
type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String
-> DumpFormat -> SDoc -> IO ()
type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a
defaultDumpAction :: DumpAction
defaultDumpAction dflags sty dumpOpt title _fmt doc = do
dumpSDocWithStyle sty dflags dumpOpt title doc
defaultTraceAction :: TraceAction
defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc
dumpAction :: DumpAction
dumpAction dflags = dump_action dflags dflags
traceAction :: TraceAction
traceAction dflags = trace_action dflags dflags