{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Utils.Error (
Validity'(..), Validity, andValid, allValid, getInvalids,
Severity(..),
Diagnostic(..),
MsgEnvelope(..),
MessageClass(..),
SDoc,
DecoratedSDoc(unDecorated),
Messages,
mkMessages, unionMessages,
errorsFound, isEmptyMessages,
pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault,
pprMessages,
pprLocMsgEnvelope, pprLocMsgEnvelopeDefault,
formatBulleted,
DiagOpts (..), diag_wopt, diag_fatal_wopt,
emptyMessages, mkDecorated, mkLocMessage,
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,
traceSystoolCommand,
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
{ DiagOpts -> EnumSet WarningFlag
diag_warning_flags :: !(EnumSet WarningFlag)
, DiagOpts -> EnumSet WarningFlag
diag_fatal_warning_flags :: !(EnumSet WarningFlag)
, DiagOpts -> Bool
diag_warn_is_error :: !Bool
, DiagOpts -> Bool
diag_reverse_errors :: !Bool
, DiagOpts -> Maybe Int
diag_max_errors :: !(Maybe Int)
, DiagOpts -> SDocContext
diag_ppr_ctx :: !SDocContext
}
diag_wopt :: WarningFlag -> DiagOpts -> Bool
diag_wopt :: WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
wflag DiagOpts
opts = WarningFlag
wflag WarningFlag -> EnumSet WarningFlag -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
`EnumSet.member` DiagOpts -> EnumSet WarningFlag
diag_warning_flags DiagOpts
opts
diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
diag_fatal_wopt WarningFlag
wflag DiagOpts
opts = WarningFlag
wflag WarningFlag -> EnumSet WarningFlag -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
`EnumSet.member` DiagOpts -> EnumSet WarningFlag
diag_fatal_warning_flags DiagOpts
opts
diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity DiagOpts
opts DiagnosticReason
reason = case DiagnosticReason
reason of
WarningWithFlag WarningFlag
wflag
| Bool -> Bool
not (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
wflag DiagOpts
opts) -> Severity
SevIgnore
| WarningFlag -> DiagOpts -> Bool
diag_fatal_wopt WarningFlag
wflag DiagOpts
opts -> Severity
SevError
| Bool
otherwise -> Severity
SevWarning
DiagnosticReason
WarningWithoutFlag
| DiagOpts -> Bool
diag_warn_is_error DiagOpts
opts -> Severity
SevError
| Bool
otherwise -> Severity
SevWarning
DiagnosticReason
ErrorWithoutFlag
-> Severity
SevError
mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
mkMCDiagnostic :: DiagOpts
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
mkMCDiagnostic DiagOpts
opts DiagnosticReason
reason Maybe DiagnosticCode
code = Severity
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic (DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity DiagOpts
opts DiagnosticReason
reason) DiagnosticReason
reason Maybe DiagnosticCode
code
errorDiagnostic :: MessageClass
errorDiagnostic :: MessageClass
errorDiagnostic = Severity
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
SevError DiagnosticReason
ErrorWithoutFlag Maybe DiagnosticCode
forall a. Maybe a
Nothing
mk_msg_envelope
:: Diagnostic e
=> Severity
-> SrcSpan
-> NamePprCtx
-> e
-> MsgEnvelope e
mk_msg_envelope :: forall e.
Diagnostic e =>
Severity -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mk_msg_envelope Severity
severity SrcSpan
locn NamePprCtx
name_ppr_ctx e
err
= MsgEnvelope { errMsgSpan :: SrcSpan
errMsgSpan = SrcSpan
locn
, errMsgContext :: NamePprCtx
errMsgContext = NamePprCtx
name_ppr_ctx
, errMsgDiagnostic :: e
errMsgDiagnostic = e
err
, errMsgSeverity :: Severity
errMsgSeverity = Severity
severity
}
mkMsgEnvelope
:: Diagnostic e
=> DiagOpts
-> SrcSpan
-> NamePprCtx
-> e
-> MsgEnvelope e
mkMsgEnvelope :: forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
opts SrcSpan
locn NamePprCtx
name_ppr_ctx e
err
= Severity -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
Severity -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mk_msg_envelope (DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity DiagOpts
opts (e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason e
err)) SrcSpan
locn NamePprCtx
name_ppr_ctx e
err
mkErrorMsgEnvelope :: Diagnostic e
=> SrcSpan
-> NamePprCtx
-> e
-> MsgEnvelope e
mkErrorMsgEnvelope :: forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
locn NamePprCtx
name_ppr_ctx e
msg =
Bool -> MsgEnvelope e -> MsgEnvelope e
forall a. HasCallStack => Bool -> a -> a
assert (e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason e
msg DiagnosticReason -> DiagnosticReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiagnosticReason
ErrorWithoutFlag) (MsgEnvelope e -> MsgEnvelope e) -> MsgEnvelope e -> MsgEnvelope e
forall a b. (a -> b) -> a -> b
$ Severity -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
Severity -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mk_msg_envelope Severity
SevError SrcSpan
locn NamePprCtx
name_ppr_ctx e
msg
mkPlainMsgEnvelope :: Diagnostic e
=> DiagOpts
-> SrcSpan
-> e
-> MsgEnvelope e
mkPlainMsgEnvelope :: forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
opts SrcSpan
locn e
msg =
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
opts SrcSpan
locn NamePprCtx
alwaysQualify e
msg
mkPlainErrorMsgEnvelope :: Diagnostic e
=> SrcSpan
-> e
-> MsgEnvelope e
mkPlainErrorMsgEnvelope :: forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
locn e
msg =
Severity -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
Severity -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mk_msg_envelope Severity
SevError SrcSpan
locn NamePprCtx
alwaysQualify e
msg
data Validity' a
= IsValid
| NotValid a
deriving (forall a b. (a -> b) -> Validity' a -> Validity' b)
-> (forall a b. a -> Validity' b -> Validity' a)
-> Functor Validity'
forall a b. a -> Validity' b -> Validity' a
forall a b. (a -> b) -> Validity' a -> Validity' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Validity' a -> Validity' b
fmap :: forall a b. (a -> b) -> Validity' a -> Validity' b
$c<$ :: forall a b. a -> Validity' b -> Validity' a
<$ :: forall a b. a -> Validity' b -> Validity' a
Functor
type Validity = Validity' SDoc
andValid :: Validity' a -> Validity' a -> Validity' a
andValid :: forall a. Validity' a -> Validity' a -> Validity' a
andValid Validity' a
IsValid Validity' a
v = Validity' a
v
andValid Validity' a
v Validity' a
_ = Validity' a
v
allValid :: [Validity' a] -> Validity' a
allValid :: forall a. [Validity' a] -> Validity' a
allValid [] = Validity' a
forall a. Validity' a
IsValid
allValid (Validity' a
v : [Validity' a]
vs) = Validity' a
v Validity' a -> Validity' a -> Validity' a
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` [Validity' a] -> Validity' a
forall a. [Validity' a] -> Validity' a
allValid [Validity' a]
vs
getInvalids :: [Validity' a] -> [a]
getInvalids :: forall a. [Validity' a] -> [a]
getInvalids [Validity' a]
vs = [a
d | NotValid a
d <- [Validity' a]
vs]
formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc
formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx (DecoratedSDoc -> [SDoc]
unDecorated -> [SDoc]
docs)
= case [SDoc]
msgs of
[] -> SDoc
forall doc. IsOutput doc => doc
Outputable.empty
[SDoc
msg] -> SDoc
msg
[SDoc]
_ -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
starred [SDoc]
msgs
where
msgs :: [SDoc]
msgs = (SDoc -> Bool) -> [SDoc] -> [SDoc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> Bool
Outputable.isEmpty SDocContext
ctx) [SDoc]
docs
starred :: SDoc -> SDoc
starred = (SDoc
bulletSDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>)
pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc
pprMessages :: forall e. Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc
pprMessages DiagnosticOpts e
e = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> (Messages e -> [SDoc]) -> Messages e -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
forall e.
Diagnostic e =>
DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc DiagnosticOpts e
e (Bag (MsgEnvelope e) -> [SDoc])
-> (Messages e -> Bag (MsgEnvelope e)) -> Messages e -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages e -> Bag (MsgEnvelope e)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages
pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc :: forall e.
Diagnostic e =>
DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc DiagnosticOpts e
e Bag (MsgEnvelope e)
bag = [ DiagnosticOpts e -> MsgEnvelope e -> SDoc
forall e. Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
pprLocMsgEnvelope DiagnosticOpts e
e MsgEnvelope e
item | MsgEnvelope e
item <- Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag Maybe DiagOpts
forall a. Maybe a
Nothing Bag (MsgEnvelope e)
bag ]
pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLocDefault :: forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLocDefault Bag (MsgEnvelope e)
bag = [ MsgEnvelope e -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault MsgEnvelope e
item | MsgEnvelope e
item <- Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag Maybe DiagOpts
forall a. Maybe a
Nothing Bag (MsgEnvelope e)
bag ]
pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault :: forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault = DiagnosticOpts e -> MsgEnvelope e -> SDoc
forall e. Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
pprLocMsgEnvelope (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @e)
pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
pprLocMsgEnvelope :: forall e. Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
pprLocMsgEnvelope DiagnosticOpts e
opts (MsgEnvelope { errMsgSpan :: forall e. MsgEnvelope e -> SrcSpan
errMsgSpan = SrcSpan
s
, errMsgDiagnostic :: forall e. MsgEnvelope e -> e
errMsgDiagnostic = e
e
, errMsgSeverity :: forall e. MsgEnvelope e -> Severity
errMsgSeverity = Severity
sev
, errMsgContext :: forall e. MsgEnvelope e -> NamePprCtx
errMsgContext = NamePprCtx
name_ppr_ctx })
= (SDocContext -> SDoc) -> SDoc
sdocWithContext ((SDocContext -> SDoc) -> SDoc) -> (SDocContext -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \SDocContext
ctx ->
NamePprCtx -> SDoc -> SDoc
withErrStyle NamePprCtx
name_ppr_ctx (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage
(Severity
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev (e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason e
e) (e -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode e
e))
SrcSpan
s
(SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticOpts e -> e -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts e
opts e
e)
sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag :: forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag Maybe DiagOpts
mopts = [MsgEnvelope e] -> [MsgEnvelope e]
maybeLimit ([MsgEnvelope e] -> [MsgEnvelope e])
-> (Bag (MsgEnvelope e) -> [MsgEnvelope e])
-> Bag (MsgEnvelope e)
-> [MsgEnvelope e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope e -> MsgEnvelope e -> Ordering)
-> [MsgEnvelope e] -> [MsgEnvelope e]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
cmp (SrcSpan -> SrcSpan -> Ordering)
-> (MsgEnvelope e -> SrcSpan)
-> MsgEnvelope e
-> MsgEnvelope e
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` MsgEnvelope e -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan) ([MsgEnvelope e] -> [MsgEnvelope e])
-> (Bag (MsgEnvelope e) -> [MsgEnvelope e])
-> Bag (MsgEnvelope e)
-> [MsgEnvelope e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope e) -> [MsgEnvelope e]
forall a. Bag a -> [a]
bagToList
where
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp
| Just DiagOpts
opts <- Maybe DiagOpts
mopts
, DiagOpts -> Bool
diag_reverse_errors DiagOpts
opts
= SrcSpan -> SrcSpan -> Ordering
SrcLoc.rightmost_smallest
| Bool
otherwise
= SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest
maybeLimit :: [MsgEnvelope e] -> [MsgEnvelope e]
maybeLimit
| Just DiagOpts
opts <- Maybe DiagOpts
mopts
, Just Int
err_limit <- DiagOpts -> Maybe Int
diag_max_errors DiagOpts
opts
= Int -> [MsgEnvelope e] -> [MsgEnvelope e]
forall a. Int -> [a] -> [a]
take Int
err_limit
| Bool
otherwise
= [MsgEnvelope e] -> [MsgEnvelope e]
forall a. a -> a
id
ghcExit :: Logger -> Int -> IO ()
ghcExit :: Logger -> Int -> IO ()
ghcExit Logger
logger Int
val
| Int
val Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
| Bool
otherwise = do Logger -> SDoc -> IO ()
errorMsg Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\nCompilation had errors\n\n")
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
val)
errorMsg :: Logger -> SDoc -> IO ()
errorMsg :: Logger -> SDoc -> IO ()
errorMsg Logger
logger SDoc
msg
= Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
errorDiagnostic SrcSpan
noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
msg
fatalErrorMsg :: Logger -> SDoc -> IO ()
fatalErrorMsg :: Logger -> SDoc -> IO ()
fatalErrorMsg Logger
logger SDoc
msg =
Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
MCFatal SrcSpan
noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
msg
compilationProgressMsg :: Logger -> SDoc -> IO ()
compilationProgressMsg :: Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger SDoc
msg = do
let logflags :: LogFlags
logflags = Logger -> LogFlags
logFlags Logger
logger
let str :: String
str = SDocContext -> SDoc -> String
renderWithContext (LogFlags -> SDocContext
log_default_user_context LogFlags
logflags) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC progress: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
msg)
String -> IO ()
traceEventIO String
str
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger -> SDoc -> IO ()
logOutput Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
msg
showPass :: Logger -> String -> IO ()
showPass :: Logger -> String -> IO ()
showPass Logger
logger String
what =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"***" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
data PrintTimings = PrintTimings | DontPrintTimings
deriving (PrintTimings -> PrintTimings -> Bool
(PrintTimings -> PrintTimings -> Bool)
-> (PrintTimings -> PrintTimings -> Bool) -> Eq PrintTimings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrintTimings -> PrintTimings -> Bool
== :: PrintTimings -> PrintTimings -> Bool
$c/= :: PrintTimings -> PrintTimings -> Bool
/= :: PrintTimings -> PrintTimings -> Bool
Eq, Int -> PrintTimings -> ShowS
[PrintTimings] -> ShowS
PrintTimings -> String
(Int -> PrintTimings -> ShowS)
-> (PrintTimings -> String)
-> ([PrintTimings] -> ShowS)
-> Show PrintTimings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrintTimings -> ShowS
showsPrec :: Int -> PrintTimings -> ShowS
$cshow :: PrintTimings -> String
show :: PrintTimings -> String
$cshowList :: [PrintTimings] -> ShowS
showList :: [PrintTimings] -> ShowS
Show)
withTiming :: MonadIO m
=> Logger
-> SDoc
-> (a -> ())
-> m a
-> m a
withTiming :: forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger SDoc
what a -> ()
force m a
action =
Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' Logger
logger SDoc
what a -> ()
force PrintTimings
PrintTimings m a
action
withTimingSilent
:: MonadIO m
=> Logger
-> SDoc
-> (a -> ())
-> m a
-> m a
withTimingSilent :: forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger SDoc
what a -> ()
force m a
action =
Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' Logger
logger SDoc
what a -> ()
force PrintTimings
DontPrintTimings m a
action
withTiming' :: MonadIO m
=> Logger
-> SDoc
-> (a -> ())
-> PrintTimings
-> m a
-> m a
withTiming' :: forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' Logger
logger SDoc
what a -> ()
force_result PrintTimings
prtimings m a
action
= if Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2 Bool -> Bool -> Bool
|| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_timings
then do IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"***" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
let ctx :: SDocContext
ctx = LogFlags -> SDocContext
log_default_user_context (Logger -> LogFlags
logFlags Logger
logger)
Int64
alloc0 <- IO Int64 -> m Int64
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int64
getAllocationCounter
Integer
start <- IO Integer -> m Integer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
SDocContext -> SDoc -> m ()
eventBegins SDocContext
ctx SDoc
what
Int64 -> m ()
forall {m :: * -> *} {a}. (MonadIO m, Show a) => a -> m ()
recordAllocs Int64
alloc0
!a
r <- m a
action
() <- () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$ a -> ()
force_result a
r
SDocContext -> SDoc -> m ()
eventEnds SDocContext
ctx SDoc
what
Integer
end <- IO Integer -> m Integer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
Int64
alloc1 <- IO Int64 -> m Int64
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int64
getAllocationCounter
Int64 -> m ()
forall {m :: * -> *} {a}. (MonadIO m, Show a) => a -> m ()
recordAllocs Int64
alloc1
let alloc :: Int64
alloc = Int64
alloc0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
alloc1
time :: Double
time = Integer -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e-9
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2 Bool -> Bool -> Bool
&& PrintTimings
prtimings PrintTimings -> PrintTimings -> Bool
forall a. Eq a => a -> a -> Bool
== PrintTimings
PrintTimings)
(m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"!!!" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"finished in"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> Double -> SDoc
doublePrec Int
2 Double
time
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"milliseconds"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"allocated"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> Double -> SDoc
doublePrec Int
3 (Int64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int64
alloc Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1024 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1024)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"megabytes")
IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_timings String
"" DumpFormat
FormatText
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx
(SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"alloc=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int64
alloc
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"time=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> Double -> SDoc
doublePrec Int
3 Double
time
]
a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
else m a
action
where whenPrintTimings :: IO () -> m ()
whenPrintTimings = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrintTimings
prtimings PrintTimings -> PrintTimings -> Bool
forall a. Eq a => a -> a -> Bool
== PrintTimings
PrintTimings)
recordAllocs :: a -> m ()
recordAllocs a
alloc =
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceMarkerIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"GHC:allocs:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
alloc
eventBegins :: SDocContext -> SDoc -> m ()
eventBegins SDocContext
ctx SDoc
w = do
let doc :: String
doc = SDocContext -> SDoc -> String
eventBeginsDoc SDocContext
ctx SDoc
w
IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceMarkerIO String
doc
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceEventIO String
doc
eventEnds :: SDocContext -> SDoc -> m ()
eventEnds SDocContext
ctx SDoc
w = do
let doc :: String
doc = SDocContext -> SDoc -> String
eventEndsDoc SDocContext
ctx SDoc
w
IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceMarkerIO String
doc
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceEventIO String
doc
eventBeginsDoc :: SDocContext -> SDoc -> String
eventBeginsDoc SDocContext
ctx SDoc
w = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC:started:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
w
eventEndsDoc :: SDocContext -> SDoc -> String
eventEndsDoc SDocContext
ctx SDoc
w = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC:finished:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
w
debugTraceMsg :: Logger -> Int -> SDoc -> IO ()
debugTraceMsg :: Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
val SDoc
msg =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogFlags -> Int
log_verbosity (Logger -> LogFlags
logFlags Logger
logger) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
val) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger -> SDoc -> IO ()
logInfo Logger
logger (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle SDoc
msg)
{-# INLINE debugTraceMsg #-}
putMsg :: Logger -> SDoc -> IO ()
putMsg :: Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
msg = Logger -> SDoc -> IO ()
logInfo Logger
logger (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
msg)
printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
printInfoForUser Logger
logger NamePprCtx
name_ppr_ctx SDoc
msg
= Logger -> SDoc -> IO ()
logInfo Logger
logger (NamePprCtx -> Depth -> SDoc -> SDoc
withUserStyle NamePprCtx
name_ppr_ctx Depth
AllTheWay SDoc
msg)
printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
printOutputForUser Logger
logger NamePprCtx
name_ppr_ctx SDoc
msg
= Logger -> SDoc -> IO ()
logOutput Logger
logger (NamePprCtx -> Depth -> SDoc -> SDoc
withUserStyle NamePprCtx
name_ppr_ctx Depth
AllTheWay SDoc
msg)
logInfo :: Logger -> SDoc -> IO ()
logInfo :: Logger -> SDoc -> IO ()
logInfo Logger
logger SDoc
msg = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
MCInfo SrcSpan
noSrcSpan SDoc
msg
logOutput :: Logger -> SDoc -> IO ()
logOutput :: Logger -> SDoc -> IO ()
logOutput Logger
logger SDoc
msg = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
MCOutput SrcSpan
noSrcSpan SDoc
msg
prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors :: forall (m :: * -> *) a. ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors Logger
logger = do
let ctx :: SDocContext
ctx = LogFlags -> SDocContext
log_default_user_context (Logger -> LogFlags
logFlags Logger
logger)
(GhcException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle ((GhcException -> m a) -> m a -> m a)
-> (GhcException -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \GhcException
e -> case GhcException
e of
PprPanic String
str SDoc
doc ->
SDocContext -> (String -> m a) -> SDoc -> SDoc -> m a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
ctx String -> m a
forall a. HasCallStack => String -> a
panic (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
str) SDoc
doc
PprSorry String
str SDoc
doc ->
SDocContext -> (String -> m a) -> SDoc -> SDoc -> m a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
ctx String -> m a
forall a. HasCallStack => String -> a
sorry (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
str) SDoc
doc
PprProgramError String
str SDoc
doc ->
SDocContext -> (String -> m a) -> SDoc -> SDoc -> m a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
ctx String -> m a
forall a. HasCallStack => String -> a
pgmError (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
str) SDoc
doc
GhcException
_ -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ GhcException -> IO a
forall e a. Exception e => e -> IO a
throwIO GhcException
e
traceCmd :: Logger -> String -> String -> IO a -> IO a
traceCmd :: forall a. Logger -> String -> String -> IO a -> IO a
traceCmd Logger
logger String
phase_name String
cmd_line IO a
action = do
Logger -> String -> IO ()
showPass Logger
logger String
phase_name
let
cmd_doc :: SDoc
cmd_doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
cmd_line
handle_exn :: IOException -> IO a
handle_exn IOException
exn = do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\n')
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Failed:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cmd_doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (IOException -> String
forall a. Show a => a -> String
show IOException
exn))
GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError (IOException -> String
forall a. Show a => a -> String
show IOException
exn))
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 SDoc
cmd_doc
Logger -> IO ()
loggerTraceFlush Logger
logger
IO a
action IO a -> (IOException -> IO a) -> IO a
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` IOException -> IO a
handle_exn
traceSystoolCommand :: Logger -> String -> IO a -> IO a
traceSystoolCommand :: forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
tool = Logger -> SDoc -> (a -> ()) -> IO a -> IO a
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"systool:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
tool) (() -> a -> ()
forall a b. a -> b -> a
const ())