module GHC.Utils.Error (
Validity'(..), Validity, andValid, allValid, getInvalids,
Severity(..),
Diagnostic(..),
MsgEnvelope(..),
MessageClass(..),
SDoc,
DecoratedSDoc(unDecorated),
Messages,
mkMessages, unionMessages,
errorsFound, isEmptyMessages,
pprMessageBag, pprMsgEnvelopeBagWithLoc,
pprMessages,
pprLocMsgEnvelope,
formatBulleted,
DiagOpts (..), diag_wopt, diag_fatal_wopt,
emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,
mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
mkErrorMsgEnvelope,
mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,
mkPlainError,
mkPlainDiagnostic,
mkDecoratedError,
mkDecoratedDiagnostic,
noHints,
getCaretDiagnostic,
putMsg, printInfoForUser, printOutputForUser,
logInfo, logOutput,
errorMsg,
fatalErrorMsg,
compilationProgressMsg,
showPass,
withTiming, withTimingSilent,
debugTraceMsg,
ghcExit,
prettyPrintGhcErrors,
traceCmd,
sortMsgBag
) where
import GHC.Prelude
import GHC.Driver.Flags
import GHC.Data.Bag
import qualified GHC.Data.EnumSet as EnumSet
import GHC.Data.EnumSet (EnumSet)
import GHC.Utils.Exception
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Types.Error
import GHC.Types.SrcLoc as SrcLoc
import System.Exit ( ExitCode(..), exitWith )
import Data.List ( sortBy )
import Data.Function
import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch as MC (handle)
import GHC.Conc ( getAllocationCounter )
import System.CPUTime
data DiagOpts = DiagOpts
{ diag_warning_flags :: !(EnumSet WarningFlag)
, diag_fatal_warning_flags :: !(EnumSet WarningFlag)
, diag_warn_is_error :: !Bool
, diag_reverse_errors :: !Bool
, diag_max_errors :: !(Maybe Int)
, diag_ppr_ctx :: !SDocContext
}
diag_wopt :: WarningFlag -> DiagOpts -> Bool
diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts
diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts
diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity opts reason = case reason of
WarningWithFlag wflag
| not (diag_wopt wflag opts) -> SevIgnore
| diag_fatal_wopt wflag opts -> SevError
| otherwise -> SevWarning
WarningWithoutFlag
| diag_warn_is_error opts -> SevError
| otherwise -> SevWarning
ErrorWithoutFlag
-> SevError
mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass
mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason
errorDiagnostic :: MessageClass
errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag
mk_msg_envelope
:: Diagnostic e
=> Severity
-> SrcSpan
-> PrintUnqualified
-> e
-> MsgEnvelope e
mk_msg_envelope severity locn print_unqual err
= MsgEnvelope { errMsgSpan = locn
, errMsgContext = print_unqual
, errMsgDiagnostic = err
, errMsgSeverity = severity
}
mkMsgEnvelope
:: Diagnostic e
=> DiagOpts
-> SrcSpan
-> PrintUnqualified
-> e
-> MsgEnvelope e
mkMsgEnvelope opts locn print_unqual err
= mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn print_unqual err
mkErrorMsgEnvelope :: Diagnostic e
=> SrcSpan
-> PrintUnqualified
-> e
-> MsgEnvelope e
mkErrorMsgEnvelope locn unqual msg =
assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg
mkPlainMsgEnvelope :: Diagnostic e
=> DiagOpts
-> SrcSpan
-> e
-> MsgEnvelope e
mkPlainMsgEnvelope opts locn msg =
mkMsgEnvelope opts locn alwaysQualify msg
mkPlainErrorMsgEnvelope :: Diagnostic e
=> SrcSpan
-> e
-> MsgEnvelope e
mkPlainErrorMsgEnvelope locn msg =
mk_msg_envelope SevError locn alwaysQualify msg
data Validity' a
= IsValid
| NotValid a
deriving Functor
type Validity = Validity' SDoc
andValid :: Validity' a -> Validity' a -> Validity' a
andValid IsValid v = v
andValid v _ = v
allValid :: [Validity' a] -> Validity' a
allValid [] = IsValid
allValid (v : vs) = v `andValid` allValid vs
getInvalids :: [Validity' a] -> [a]
getInvalids vs = [d | NotValid d <- vs]
formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc
formatBulleted ctx (unDecorated -> docs)
= case msgs of
[] -> Outputable.empty
[msg] -> msg
_ -> vcat $ map starred msgs
where
msgs = filter (not . Outputable.isEmpty ctx) docs
starred = (bullet<+>)
pprMessages :: Diagnostic e => Messages e -> SDoc
pprMessages = vcat . pprMsgEnvelopeBagWithLoc . getMessages
pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ]
pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s
, errMsgDiagnostic = e
, errMsgSeverity = sev
, errMsgContext = unqual })
= sdocWithContext $ \ctx ->
withErrStyle unqual $
mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e)
sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
where
cmp
| Just opts <- mopts
, diag_reverse_errors opts
= SrcLoc.rightmost_smallest
| otherwise
= SrcLoc.leftmost_smallest
maybeLimit
| Just opts <- mopts
, Just err_limit <- diag_max_errors opts
= take err_limit
| otherwise
= id
ghcExit :: Logger -> Int -> IO ()
ghcExit logger val
| val == 0 = exitWith ExitSuccess
| otherwise = do errorMsg logger (text "\nCompilation had errors\n\n")
exitWith (ExitFailure val)
errorMsg :: Logger -> SDoc -> IO ()
errorMsg logger msg
= logMsg logger errorDiagnostic noSrcSpan $
withPprStyle defaultErrStyle msg
fatalErrorMsg :: Logger -> SDoc -> IO ()
fatalErrorMsg logger msg =
logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg
compilationProgressMsg :: Logger -> SDoc -> IO ()
compilationProgressMsg logger msg = do
let logflags = logFlags logger
let str = renderWithContext (log_default_user_context logflags) (text "GHC progress: " <> msg)
traceEventIO str
when (logVerbAtLeast logger 1) $
logOutput logger $ withPprStyle defaultUserStyle msg
showPass :: Logger -> String -> IO ()
showPass logger what =
when (logVerbAtLeast logger 2) $
logInfo logger $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)
data PrintTimings = PrintTimings | DontPrintTimings
deriving (Eq, Show)
withTiming :: MonadIO m
=> Logger
-> SDoc
-> (a -> ())
-> m a
-> m a
withTiming logger what force action =
withTiming' logger what force PrintTimings action
withTimingSilent
:: MonadIO m
=> Logger
-> SDoc
-> (a -> ())
-> m a
-> m a
withTimingSilent logger what force action =
withTiming' logger what force DontPrintTimings action
withTiming' :: MonadIO m
=> Logger
-> SDoc
-> (a -> ())
-> PrintTimings
-> m a
-> m a
withTiming' logger what force_result prtimings action
= if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings
then do whenPrintTimings $
logInfo logger $ withPprStyle defaultUserStyle $
text "***" <+> what <> colon
let ctx = log_default_user_context (logFlags logger)
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
eventBegins ctx what
recordAllocs alloc0
!r <- action
() <- pure $ force_result r
eventEnds ctx what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
recordAllocs alloc1
let alloc = alloc0 alloc1
time = realToFrac (end start) * 1e-9
when (logVerbAtLeast logger 2 && prtimings == PrintTimings)
$ liftIO $ logInfo logger $ 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 $
putDumpFileMaybe logger 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)
recordAllocs alloc =
liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc
eventBegins ctx w = do
let doc = eventBeginsDoc ctx w
whenPrintTimings $ traceMarkerIO doc
liftIO $ traceEventIO doc
eventEnds ctx w = do
let doc = eventEndsDoc ctx w
whenPrintTimings $ traceMarkerIO doc
liftIO $ traceEventIO doc
eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w
eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w
debugTraceMsg :: Logger -> Int -> SDoc -> IO ()
debugTraceMsg logger val msg =
when (log_verbosity (logFlags logger) >= val) $
logInfo logger (withPprStyle defaultDumpStyle msg)
putMsg :: Logger -> SDoc -> IO ()
putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg)
printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()
printInfoForUser logger print_unqual msg
= logInfo logger (withUserStyle print_unqual AllTheWay msg)
printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser logger print_unqual msg
= logOutput logger (withUserStyle print_unqual AllTheWay msg)
logInfo :: Logger -> SDoc -> IO ()
logInfo logger msg = logMsg logger MCInfo noSrcSpan msg
logOutput :: Logger -> SDoc -> IO ()
logOutput logger msg = logMsg logger MCOutput noSrcSpan msg
prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors logger = do
let ctx = log_default_user_context (logFlags logger)
MC.handle $ \e -> case e of
PprPanic str doc ->
pprDebugAndThen ctx panic (text str) doc
PprSorry str doc ->
pprDebugAndThen ctx sorry (text str) doc
PprProgramError str doc ->
pprDebugAndThen ctx pgmError (text str) doc
_ -> liftIO $ throwIO e
traceCmd :: Logger -> String -> String -> IO a -> IO a
traceCmd logger phase_name cmd_line action = do
showPass logger phase_name
let
cmd_doc = text cmd_line
handle_exn exn = do
debugTraceMsg logger 2 (char '\n')
debugTraceMsg logger 2 (text "Failed:" <+> cmd_doc <+> text (show exn))
throwGhcExceptionIO (ProgramError (show exn))
debugTraceMsg logger 3 cmd_doc
loggerTraceFlush logger
action `catchIO` handle_exn