{-
(c) The AQUA Project, Glasgow University, 1994-1998
\section[ErrsUtils]{Utilities for error reporting}
-}{-# LANGUAGE CPP #-}{-# LANGUAGE BangPatterns #-}{-# LANGUAGE RecordWildCards #-}moduleErrUtils(-- * Basic typesValidity (..),andValid ,allValid ,isValid ,getInvalids ,orValid ,Severity (..),-- * MessagesErrMsg ,errMsgDoc ,errMsgSeverity ,errMsgReason ,ErrDoc ,errDoc ,errDocImportant ,errDocContext ,errDocSupplementary ,WarnMsg ,MsgDoc ,Messages ,ErrorMessages ,WarningMessages ,unionMessages ,errMsgSpan ,errMsgContext ,errorsFound ,isEmptyMessages ,isWarnMsgFatal ,-- ** FormattingpprMessageBag ,pprErrMsgBagWithLoc ,pprLocErrMsg ,printBagOfErrors ,formatErrDoc ,-- ** ConstructionemptyMessages ,mkLocMessage ,mkLocMessageAnn ,makeIntoWarning ,mkErrMsg ,mkPlainErrMsg ,mkErrDoc ,mkLongErrMsg ,mkWarnMsg ,mkPlainWarnMsg ,mkLongWarnMsg ,-- * UtilitiesdoIfSet ,doIfSet_dyn ,getCaretDiagnostic ,-- * Dump filesdumpIfSet ,dumpIfSet_dyn ,dumpIfSet_dyn_printer ,mkDumpDoc ,dumpSDoc ,dumpSDocForUser ,dumpSDocWithStyle ,-- * Issuing messages during compilationputMsg ,printInfoForUser ,printOutputForUser ,logInfo ,logOutput ,errorMsg ,warningMsg ,fatalErrorMsg ,fatalErrorMsg'' ,compilationProgressMsg ,showPass ,withTiming ,debugTraceMsg ,ghcExit ,prettyPrintGhcErrors ,traceCmd )where#include "HsVersions.h"
importGhcPrelude importBag importException importOutputable importPanic importqualifiedPprColour asColimportSrcLoc importDynFlags importFastString (unpackFS )importStringBuffer (atLine ,hGetStringBuffer ,len ,lexemeToString )importJson importSystem.DirectoryimportSystem.Exit(ExitCode(..),exitWith)importSystem.FilePath(takeDirectory,(</>))importData.ListimportqualifiedData.SetasSetimportData.IORefimportData.Maybe(fromMaybe)importData.OrdimportData.TimeimportControl.MonadimportControl.Monad.IO.ClassimportSystem.IOimportSystem.IO.Error(catchIOError)importGHC.Conc(getAllocationCounter)importSystem.CPUTime-------------------------typeMsgDoc =SDoc -------------------------dataValidity =IsValid -- ^ Everything is fine|NotValid MsgDoc -- ^ A problem, and some indication of whyisValid::Validity ->BoolisValid IsValid =TrueisValid(NotValid {})=FalseandValid::Validity ->Validity ->Validity andValid IsValid v =v andValidv _=v -- | If they aren't all valid, return the firstallValid::[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 -- ------------------------------------------------------------------------------- Basic error messages: just render a message with a source location.typeMessages =(WarningMessages ,ErrorMessages )typeWarningMessages =Bag WarnMsg typeErrorMessages =Bag ErrMsg unionMessages::Messages ->Messages ->Messages unionMessages (warns1 ,errs1 )(warns2 ,errs2 )=(warns1 `unionBags `warns2 ,errs1 `unionBags `errs2 )dataErrMsg =ErrMsg {errMsgSpan ::SrcSpan ,errMsgContext ::PrintUnqualified ,errMsgDoc ::ErrDoc ,-- | This has the same text as errDocImportant . errMsgDoc.errMsgShortString ::String,errMsgSeverity ::Severity ,errMsgReason ::WarnReason }-- The SrcSpan is used for sorting errors into line-number order-- | Categorise error msgs by their importance. This is so each section can-- be rendered visually distinct. See Note [Error report] for where these come-- from.dataErrDoc =ErrDoc {-- | Primary error msg.errDocImportant ::[MsgDoc ],-- | Context e.g. \"In the second argument of ...\".errDocContext ::[MsgDoc ],-- | Supplementary information, e.g. \"Relevant bindings include ...\".errDocSupplementary ::[MsgDoc ]}errDoc::[MsgDoc ]->[MsgDoc ]->[MsgDoc ]->ErrDoc errDoc =ErrDoc typeWarnMsg =ErrMsg dataSeverity =SevOutput |SevFatal |SevInteractive |SevDump -- ^ Log message intended for compiler developers-- No file/line/column stuff|SevInfo -- ^ Log messages intended for end users.-- No file/line/column stuff.|SevWarning |SevError -- ^ SevWarning and SevError are used for warnings and errors-- o The message has a file/line/column heading,-- plus "warning:" or "error:",-- added by mkLocMessags-- o Output is intended for end usersderivingShowinstanceToJson Severity wherejson s =JSString (shows )instanceShowErrMsg whereshow em =errMsgShortStringem pprMessageBag::Bag MsgDoc ->SDoc pprMessageBag msgs =vcat (punctuate blankLine (bagToList msgs ))-- | Make an unannotated error message with location info.mkLocMessage::Severity ->SrcSpan ->MsgDoc ->MsgDoc mkLocMessage =mkLocMessageAnn Nothing-- | Make a possibly annotated error message with location info.mkLocMessageAnn::MaybeString-- ^ optional annotation->Severity -- ^ severity->SrcSpan -- ^ location->MsgDoc -- ^ message->MsgDoc -- Always print the location, even if it is unhelpful. Error messages-- are supposed to be in a standard format, and one without a location-- would look strange. Better to say explicitly "<no location info>".mkLocMessageAnn ann severity locn msg =sdocWithDynFlags $\dflags ->letlocn' =ifgopt Opt_ErrorSpans dflags thenppr locn elseppr (srcSpanStart locn )sevColour =getSeverityColour severity (colSchemedflags )-- Add optional informationoptAnn =caseann ofNothing->text ""Justi ->text " ["<> coloured sevColour (text i )<> text "]"-- Add prefixes, like Foo.hs:34: warning:-- <the warning message>header =locn' <> colon <+> coloured sevColour sevText <> optAnn incoloured (Col.sMessage(colSchemedflags ))(hang (coloured (Col.sHeader(colSchemedflags ))header )4msg )wheresevText =caseseverity ofSevWarning ->text "warning:"SevError ->text "error:"SevFatal ->text "fatal:"_->empty getSeverityColour::Severity ->Col.Scheme ->Col.PprColour getSeverityColour SevWarning =Col.sWarninggetSeverityColourSevError =Col.sErrorgetSeverityColourSevFatal =Col.sFatalgetSeverityColour_=constmemptygetCaretDiagnostic::Severity ->SrcSpan ->IOMsgDoc getCaretDiagnostic _(UnhelpfulSpan _)=pureempty getCaretDiagnosticseverity (RealSrcSpan span )=docaretDiagnostic <$>getSrcLine (srcSpanFilespan )row wheregetSrcLine fn i =getLine i (unpackFS fn )`catchIOError`\_->pureNothinggetLine i fn =do-- StringBuffer has advantages over readFile:-- (a) no lazy IO, otherwise IO exceptions may occur in pure code-- (b) always UTF-8, rather than some system-dependent encoding-- (Haskell source code must be UTF-8 anyway)content <-hGetStringBuffer fn caseatLine i content ofJustat_line ->pure$caselines(fix <$>lexemeToString at_line (lenat_line ))ofsrcLine :_->JustsrcLine _->Nothing_->pureNothing-- allow user to visibly see that their code is incorrectly encoded-- (StringBuffer.nextChar uses 0円 to represent undecodable characters)fix '0円'='\xfffd'fixc =c row =srcSpanStartLine span rowStr =showrow multiline =row /=srcSpanEndLine span caretDiagnostic Nothing=empty caretDiagnostic(JustsrcLineWithNewline )=sdocWithDynFlags $\dflags ->letsevColour =getSeverityColour severity (colSchemedflags )marginColour =Col.sMargin(colSchemedflags )incoloured 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-- expand tabs in a device-independent manner #13664expandTabs tabWidth i s =cases of""->""'\t':cs ->replicateeffectiveWidth ' '++expandTabs tabWidth (i +effectiveWidth )cs c :cs ->c :expandTabs tabWidth (i +1)cs whereeffectiveWidth =tabWidth -i `mod`tabWidth srcLine =filter(/='\n')(expandTabs 80srcLineWithNewline )start =srcSpanStartCol span -1end |multiline =lengthsrcLine |otherwise=srcSpanEndCol span -1width =max1(end -start )marginWidth =lengthrowStr marginSpace =replicatemarginWidth ' '++" |"marginRow =rowStr ++" |"(srcLinePre ,srcLineRest )=splitAtstart srcLine (srcLineSpan ,srcLinePost )=splitAtwidth srcLineRest caretEllipsis |multiline ="..."|otherwise=""caretLine =replicatestart ' '++replicatewidth '^'++caretEllipsis makeIntoWarning::WarnReason ->ErrMsg ->ErrMsg makeIntoWarning reason err =err {errMsgSeverity=SevWarning ,errMsgReason=reason }-- ------------------------------------------------------------------------------- Collecting up messages for later ordering and printing.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 (errDocImportantdoc )),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 -- ^ A long (multi-line) error messagemkErrMsg,mkWarnMsg::DynFlags ->SrcSpan ->PrintUnqualified ->MsgDoc ->ErrMsg -- ^ A short (one-line) error messagemkPlainErrMsg,mkPlainWarnMsg::DynFlags ->SrcSpan ->MsgDoc ->ErrMsg -- ^ Variant that doesn't care about qualified/unqualified namesmkLongErrMsg 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 ->BoolisEmptyMessages (warns ,errs )=isEmptyBag warns &&isEmptyBag errs errorsFound::DynFlags ->Messages ->BoolerrorsFound _dflags (_warns ,errs )=not(isEmptyBag errs )printBagOfErrors::DynFlags ->Bag ErrMsg ->IO()printBagOfErrors dflags bag_of_errors =sequence_[letstyle =mkErrStyle dflags unqual inputLogMsg dflags reason sev s style (formatErrDoc dflags doc )|ErrMsg {errMsgSpan=s ,errMsgDoc=doc ,errMsgSeverity=sev ,errMsgReason=reason ,errMsgContext=unqual }<-sortMsgBag (Justdflags )bag_of_errors ]formatErrDoc::DynFlags ->ErrDoc ->SDoc formatErrDoc dflags (ErrDoc important context supplementary )=casemsgs of[msg ]->vcat msg _->vcat $mapstarred msgs wheremsgs =filter(not.null)$map(filter(not.Outputable.isEmpty dflags ))[important ,context ,supplementary ]starred =(bullet <+> ).vcat pprErrMsgBagWithLoc::Bag ErrMsg ->[SDoc ]pprErrMsgBagWithLoc bag =[pprLocErrMsg item |item <-sortMsgBag Nothingbag ]pprLocErrMsg::ErrMsg ->SDoc pprLocErrMsg (ErrMsg {errMsgSpan=s ,errMsgDoc=doc ,errMsgSeverity=sev ,errMsgContext=unqual })=sdocWithDynFlags $\dflags ->withPprStyle (mkErrStyle dflags unqual )$mkLocMessage sev s (formatErrDoc dflags doc )sortMsgBag::MaybeDynFlags ->Bag ErrMsg ->[ErrMsg ]sortMsgBag dflags =maybeLimit .sortBy(maybeFlip cmp ).bagToList wheremaybeFlip::(a ->a ->b )->(a ->a ->b )maybeFlip |fromMaybeFalse(fmapreverseErrorsdflags )=flip|otherwise=idcmp =comparingerrMsgSpanmaybeLimit =casejoin(fmapmaxErrorsdflags )ofNothing->idJusterr_limit ->takeerr_limit ghcExit::DynFlags ->Int->IO()ghcExit dflags val |val ==0=exitWithExitSuccess|otherwise=doerrorMsg dflags (text "\nCompilation had errors\n\n")exitWith(ExitFailureval )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()-- ------------------------------------------------------------------------------- DumpingdumpIfSet::DynFlags ->Bool->String->SDoc ->IO()dumpIfSet dflags flag hdr doc |notflag =return()|otherwise=putLogMsg dflags NoReason SevDump noSrcSpan (defaultDumpStyle dflags )(mkDumpDoc hdr doc )-- | a wrapper around 'dumpSDoc'.-- First check whether the dump flag is set-- Do nothing if it is unsetdumpIfSet_dyn::DynFlags ->DumpFlag ->String->SDoc ->IO()dumpIfSet_dyn dflags flag hdr doc =when(dopt flag dflags )$dumpSDoc dflags alwaysQualify flag hdr doc -- | a wrapper around 'dumpSDoc'.-- First check whether the dump flag is set-- Do nothing if it is unset---- Unlike 'dumpIfSet_dyn',-- has a printer argument but no header argumentdumpIfSet_dyn_printer::PrintUnqualified ->DynFlags ->DumpFlag ->SDoc ->IO()dumpIfSet_dyn_printer printer dflags flag doc =when(dopt flag dflags )$dumpSDoc dflags printer flag ""doc mkDumpDoc::String->SDoc ->SDoc mkDumpDoc hdr doc =vcat [blankLine ,line <+> text hdr <+> line ,doc ,blankLine ]whereline =text (replicate20'=')-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a-- file, otherwise 'Nothing'.withDumpFileHandle::DynFlags ->DumpFlag ->(MaybeHandle->IO())->IO()withDumpFileHandle dflags flag action =doletmFile =chooseDumpFile dflags flag casemFile ofJustfileName ->doletgdref =generatedDumpsdflags gd <-readIORefgdref letappend =Set.memberfileName gd mode =ifappend thenAppendModeelseWriteModeunlessappend $writeIORefgdref (Set.insertfileName gd )createDirectoryIfMissingTrue(takeDirectoryfileName )withFilefileName mode $\handle ->do-- We do not want the dump file to be affected by-- environment variables, but instead to always use-- UTF8. See:-- https://ghc.haskell.org/trac/ghc/ticket/10762hSetEncodinghandle utf8action (Justhandle )Nothing->action NothingdumpSDoc,dumpSDocForUser::DynFlags ->PrintUnqualified ->DumpFlag ->String->SDoc ->IO()-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.dumpSDoc dflags print_unqual =dumpSDocWithStyle dump_style dflags wheredump_style =mkDumpStyle dflags print_unqual -- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.dumpSDocForUser dflags print_unqual =dumpSDocWithStyle user_style dflags whereuser_style =mkUserStyle dflags print_unqual AllTheWay -- | 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)---- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@-- is used; it is not used to decide whether to dump the outputdumpSDocWithStyle::PprStyle ->DynFlags ->DumpFlag ->String->SDoc ->IO()dumpSDocWithStyle sty dflags flag hdr doc =withDumpFileHandle dflags flag writeDump where-- write dump to filewriteDump (Justhandle )=dodoc' <-ifnullhdr thenreturndoc elsedot <-getCurrentTimelettimeStamp =if(gopt Opt_SuppressTimestamps dflags )thenempty elsetext (showt )letd =timeStamp $$ blankLine $$ doc return$mkDumpDoc hdr d defaultLogActionHPrintDoc dflags handle doc' sty -- write the dump to stdoutwriteDumpNothing=dolet(doc' ,severity )|nullhdr =(doc ,SevOutput )|otherwise=(mkDumpDoc hdr doc ,SevDump )putLogMsg dflags NoReason severity noSrcSpan sty doc' -- | Choose where to put a dump file based on DynFlags--chooseDumpFile::DynFlags ->DumpFlag ->MaybeFilePathchooseDumpFile dflags flag |gopt Opt_DumpToFile dflags ||flag ==Opt_D_th_dec_file ,Justprefix <-getPrefix =Just$setDir (prefix ++(beautifyDumpName flag ))|otherwise=NothingwheregetPrefix -- dump file location is being forced-- by the --ddump-file-prefix flag.|Justprefix <-dumpPrefixForcedflags =Justprefix -- dump file location chosen by DriverPipeline.runPipeline|Justprefix <-dumpPrefixdflags =Justprefix -- we haven't got a place to put a dump file.|otherwise=NothingsetDir f =casedumpDirdflags ofJustd ->d </>f Nothing->f -- | Build a nice file name from name of a 'DumpFlag' constructorbeautifyDumpName::DumpFlag ->StringbeautifyDumpName Opt_D_th_dec_file ="th.hs"beautifyDumpNameflag =letstr =showflag suff =casestripPrefix"Opt_D_"str ofJustx ->x Nothing->panic ("Bad flag name: "++str )dash =map(\c ->ifc =='_'then'-'elsec )suff indash -- ------------------------------------------------------------------------------- Outputting messages from the compiler-- We want all messages to go through one place, so that we can-- redirect them if necessary. For example, when GHC is used as a-- library we might want to catch all messages that GHC tries to-- output and do something else with them.ifVerbose::DynFlags ->Int->IO()->IO()ifVerbose dflags val act |verbositydflags >=val =act |otherwise=return()errorMsg::DynFlags ->MsgDoc ->IO()errorMsg dflags msg =putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags )msg warningMsg::DynFlags ->MsgDoc ->IO()warningMsg dflags msg =putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags )msg fatalErrorMsg::DynFlags ->MsgDoc ->IO()fatalErrorMsg dflags msg =putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags )msg fatalErrorMsg''::FatalMessager ->String->IO()fatalErrorMsg'' fm msg =fm msg compilationProgressMsg::DynFlags ->String->IO()compilationProgressMsg dflags msg =ifVerbose dflags 1$logOutput dflags (defaultUserStyle dflags )(text msg )showPass::DynFlags ->String->IO()showPass dflags what =ifVerbose dflags 2$logInfo dflags (defaultUserStyle dflags )(text "***"<+> text what <> colon )-- | Time a compilation phase.---- When timings are enabled (e.g. with the @-v2@ flag), the allocations-- and CPU time used by the phase will be reported to stderr. Consider-- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.-- When timings are enabled the following costs are included in the-- produced accounting,---- - The cost of executing @pass@ to a result @r@ in WHNF-- - The cost of evaluating @force r@ to WHNF (e.g. @()@)---- The choice of the @force@ function depends upon the amount of forcing-- desired; the goal here is to ensure that the cost of evaluating the result-- is, to the greatest extent possible, included in the accounting provided by-- 'withTiming'. Often the pass already sufficiently forces its result during-- construction; in this case @const ()@ is a reasonable choice.-- In other cases, it is necessary to evaluate the result to normal form, in-- which case something like @Control.DeepSeq.rnf@ is appropriate.---- To avoid adversely affecting compiler performance when timings are not-- requested, the result is only forced when timings are enabled.withTiming::MonadIOm =>m DynFlags -- ^ A means of getting a 'DynFlags' (often-- 'getDynFlags' will work here)->SDoc -- ^ The name of the phase->(a ->())-- ^ A function to force the result-- (often either @const ()@ or 'rnf')->m a -- ^ The body of the phase to be timed->m a withTiming getDFlags what force_result action =dodflags <-getDFlags ifverbositydflags >=2||dopt Opt_D_dump_timings dflags thendoliftIO$logInfo dflags (defaultUserStyle dflags )$text "***"<+> what <> colon alloc0 <-liftIOgetAllocationCounterstart <-liftIOgetCPUTime!r <-action ()<-pure$force_result r end <-liftIOgetCPUTimealloc1 <-liftIOgetAllocationCounter-- recall that allocation counter counts downletalloc =alloc0 -alloc1 time =realToFrac(end -start )*1e-9when(verbositydflags >=2)$liftIO$logInfo dflags (defaultUserStyle dflags )(text "!!!"<+> what <> colon <+> text "finished in"<+> doublePrec 2time <+> text "milliseconds"<> comma <+> text "allocated"<+> doublePrec 3(realToFracalloc /1024/1024)<+> text "megabytes")liftIO$dumpIfSet_dyn dflags Opt_D_dump_timings ""$text $showSDocOneLine dflags $hsep [what <> colon ,text "alloc="<> ppr alloc ,text "time="<> doublePrec 3time ]purer elseaction debugTraceMsg::DynFlags ->Int->MsgDoc ->IO()debugTraceMsg dflags val msg =ifVerbose dflags val $logInfo dflags (defaultDumpStyle dflags )msg putMsg::DynFlags ->MsgDoc ->IO()putMsg dflags msg =logInfo dflags (defaultUserStyle dflags )msg printInfoForUser::DynFlags ->PrintUnqualified ->MsgDoc ->IO()printInfoForUser dflags print_unqual msg =logInfo dflags (mkUserStyle dflags print_unqual AllTheWay )msg printOutputForUser::DynFlags ->PrintUnqualified ->MsgDoc ->IO()printOutputForUser dflags print_unqual msg =logOutput dflags (mkUserStyle dflags print_unqual AllTheWay )msg logInfo::DynFlags ->PprStyle ->MsgDoc ->IO()logInfo dflags sty msg =putLogMsg dflags NoReason SevInfo noSrcSpan sty msg logOutput::DynFlags ->PprStyle ->MsgDoc ->IO()-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'logOutput dflags sty msg =putLogMsg dflags NoReason SevOutput noSrcSpan sty msg prettyPrintGhcErrors::ExceptionMonad m =>DynFlags ->m a ->m a prettyPrintGhcErrors dflags =ghandle $\e ->casee ofPprPanic 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$throwIOe -- | Checks if given 'WarnMsg' is a fatal warning.isWarnMsgFatal::DynFlags ->WarnMsg ->Maybe(MaybeWarningFlag )isWarnMsgFatal dflags ErrMsg {errMsgReason=Reason wflag }=ifwopt_fatal wflag dflags thenJust(Justwflag )elseNothingisWarnMsgFataldflags _=ifgopt Opt_WarnIsError dflags thenJustNothingelseNothingtraceCmd::DynFlags ->String->String->IOa ->IOa -- trace the command (at two levels of verbosity)traceCmd dflags phase_name cmd_line action =do{letverb =verbositydflags ;showPass dflags phase_name ;debugTraceMsg dflags 3(text cmd_line );caseflushErrdflags ofFlushErr io ->io -- And run it!;action `catchIO `handle_exn verb }wherehandle_exn _verb exn =do{debugTraceMsg dflags 2(char '\n');debugTraceMsg dflags 2(text "Failed:"<+> text cmd_line <+> text (showexn ));throwGhcExceptionIO (ProgramError (showexn ))}