{-# LANGUAGE ViewPatterns #-}
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 (..), emptyDiagOpts, 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.Logger
import GHC.Types.Error
import GHC.Types.SrcLoc as SrcLoc
import GHC.Unit.Module.Warnings
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
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
data DiagOpts = DiagOpts
{ DiagOpts -> EnumSet WarningFlag
diag_warning_flags :: !(EnumSet WarningFlag)
, DiagOpts -> EnumSet WarningFlag
diag_fatal_warning_flags :: !(EnumSet WarningFlag)
, DiagOpts -> WarningCategorySet
diag_custom_warning_categories :: !WarningCategorySet
, DiagOpts -> WarningCategorySet
diag_fatal_custom_warning_categories :: !WarningCategorySet
, 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
}
emptyDiagOpts :: DiagOpts
emptyDiagOpts :: DiagOpts
emptyDiagOpts =
DiagOpts
{ diag_warning_flags :: EnumSet WarningFlag
diag_warning_flags = EnumSet WarningFlag
forall {k} (a :: k). EnumSet a
EnumSet.empty
, diag_fatal_warning_flags :: EnumSet WarningFlag
diag_fatal_warning_flags = EnumSet WarningFlag
forall {k} (a :: k). EnumSet a
EnumSet.empty
, diag_custom_warning_categories :: WarningCategorySet
diag_custom_warning_categories = WarningCategorySet
emptyWarningCategorySet
, diag_fatal_custom_warning_categories :: WarningCategorySet
diag_fatal_custom_warning_categories = WarningCategorySet
emptyWarningCategorySet
, diag_warn_is_error :: Bool
diag_warn_is_error = Bool
False
, diag_reverse_errors :: Bool
diag_reverse_errors = Bool
False
, diag_max_errors :: Maybe Int
diag_max_errors = Maybe Int
forall a. Maybe a
Nothing
, diag_ppr_ctx :: SDocContext
diag_ppr_ctx = SDocContext
defaultSDocContext
}
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
diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool
diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool
diag_wopt_custom WarningCategory
wflag DiagOpts
opts = WarningCategory
wflag WarningCategory -> WarningCategorySet -> Bool
`elemWarningCategorySet` DiagOpts -> WarningCategorySet
diag_custom_warning_categories DiagOpts
opts
diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool
diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool
diag_fatal_wopt_custom WarningCategory
wflag DiagOpts
opts = WarningCategory
wflag WarningCategory -> WarningCategorySet -> Bool
`elemWarningCategorySet` DiagOpts -> WarningCategorySet
diag_fatal_custom_warning_categories DiagOpts
opts
diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity DiagOpts
opts DiagnosticReason
reason = (Severity, ResolvedDiagnosticReason) -> Severity
forall a b. (a, b) -> a
fst (DiagOpts
-> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
diag_reason_severity DiagOpts
opts DiagnosticReason
reason)
diag_reason_severity :: DiagOpts -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
diag_reason_severity :: DiagOpts
-> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
diag_reason_severity DiagOpts
opts DiagnosticReason
reason = (DiagnosticReason -> ResolvedDiagnosticReason)
-> (Severity, DiagnosticReason)
-> (Severity, ResolvedDiagnosticReason)
forall a b. (a -> b) -> (Severity, a) -> (Severity, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DiagnosticReason -> ResolvedDiagnosticReason
ResolvedDiagnosticReason ((Severity, DiagnosticReason)
-> (Severity, ResolvedDiagnosticReason))
-> (Severity, DiagnosticReason)
-> (Severity, ResolvedDiagnosticReason)
forall a b. (a -> b) -> a -> b
$ case DiagnosticReason
reason of
WarningWithFlags NonEmpty WarningFlag
wflags -> case [WarningFlag]
wflags' of
[] -> (Severity
SevIgnore, DiagnosticReason
reason)
WarningFlag
w : [WarningFlag]
ws -> case [WarningFlag]
wflagsE of
[] -> (Severity
SevWarning, NonEmpty WarningFlag -> DiagnosticReason
WarningWithFlags (WarningFlag
w WarningFlag -> [WarningFlag] -> NonEmpty WarningFlag
forall a. a -> [a] -> NonEmpty a
:| [WarningFlag]
ws))
WarningFlag
e : [WarningFlag]
es -> (Severity
SevError, NonEmpty WarningFlag -> DiagnosticReason
WarningWithFlags (WarningFlag
e WarningFlag -> [WarningFlag] -> NonEmpty WarningFlag
forall a. a -> [a] -> NonEmpty a
:| [WarningFlag]
es))
where
wflags' :: [WarningFlag]
wflags' = (WarningFlag -> Bool) -> NonEmpty WarningFlag -> [WarningFlag]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (\WarningFlag
wflag -> WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
wflag DiagOpts
opts) NonEmpty WarningFlag
wflags
wflagsE :: [WarningFlag]
wflagsE = (WarningFlag -> Bool) -> [WarningFlag] -> [WarningFlag]
forall a. (a -> Bool) -> [a] -> [a]
filter (\WarningFlag
wflag -> WarningFlag -> DiagOpts -> Bool
diag_fatal_wopt WarningFlag
wflag DiagOpts
opts) [WarningFlag]
wflags'
WarningWithCategory WarningCategory
wcat
| Bool -> Bool
not (WarningCategory -> DiagOpts -> Bool
diag_wopt_custom WarningCategory
wcat DiagOpts
opts) -> (Severity
SevIgnore, DiagnosticReason
reason)
| WarningCategory -> DiagOpts -> Bool
diag_fatal_wopt_custom WarningCategory
wcat DiagOpts
opts -> (Severity
SevError, DiagnosticReason
reason)
| Bool
otherwise -> (Severity
SevWarning, DiagnosticReason
reason)
DiagnosticReason
WarningWithoutFlag
| DiagOpts -> Bool
diag_warn_is_error DiagOpts
opts -> (Severity
SevError, DiagnosticReason
reason)
| Bool
otherwise -> (Severity
SevWarning, DiagnosticReason
reason)
DiagnosticReason
ErrorWithoutFlag
-> (Severity
SevError, DiagnosticReason
reason)
mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
mkMCDiagnostic :: DiagOpts
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
mkMCDiagnostic DiagOpts
opts DiagnosticReason
reason Maybe DiagnosticCode
code = Severity
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev ResolvedDiagnosticReason
reason' Maybe DiagnosticCode
code
where
(Severity
sev, ResolvedDiagnosticReason
reason') = DiagOpts
-> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
diag_reason_severity DiagOpts
opts DiagnosticReason
reason
errorDiagnostic :: MessageClass
errorDiagnostic :: MessageClass
errorDiagnostic = Severity
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
SevError (DiagnosticReason -> ResolvedDiagnosticReason
ResolvedDiagnosticReason DiagnosticReason
ErrorWithoutFlag) Maybe DiagnosticCode
forall a. Maybe a
Nothing
mk_msg_envelope
:: Diagnostic e
=> Severity
-> SrcSpan
-> NamePprCtx
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
mk_msg_envelope :: forall e.
Diagnostic e =>
Severity
-> SrcSpan
-> NamePprCtx
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
mk_msg_envelope Severity
severity SrcSpan
locn NamePprCtx
name_ppr_ctx ResolvedDiagnosticReason
reason 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
, errMsgReason :: ResolvedDiagnosticReason
errMsgReason = ResolvedDiagnosticReason
reason
}
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
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
forall e.
Diagnostic e =>
Severity
-> SrcSpan
-> NamePprCtx
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
mk_msg_envelope Severity
sev SrcSpan
locn NamePprCtx
name_ppr_ctx ResolvedDiagnosticReason
reason e
err
where
(Severity
sev, ResolvedDiagnosticReason
reason) = DiagOpts
-> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
diag_reason_severity DiagOpts
opts (e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason 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
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
forall e.
Diagnostic e =>
Severity
-> SrcSpan
-> NamePprCtx
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
mk_msg_envelope Severity
SevError SrcSpan
locn NamePprCtx
name_ppr_ctx (DiagnosticReason -> ResolvedDiagnosticReason
ResolvedDiagnosticReason DiagnosticReason
ErrorWithoutFlag) 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
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
forall e.
Diagnostic e =>
Severity
-> SrcSpan
-> NamePprCtx
-> ResolvedDiagnosticReason
-> e
-> MsgEnvelope e
mk_msg_envelope Severity
SevError SrcSpan
locn NamePprCtx
alwaysQualify (DiagnosticReason -> ResolvedDiagnosticReason
ResolvedDiagnosticReason DiagnosticReason
ErrorWithoutFlag) 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 :: DecoratedSDoc -> SDoc
formatBulleted :: DecoratedSDoc -> SDoc
formatBulleted (DecoratedSDoc -> [SDoc]
unDecorated -> [SDoc]
docs)
= (SDocContext -> SDoc) -> SDoc
sdocWithContext ((SDocContext -> SDoc) -> SDoc) -> (SDocContext -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \SDocContext
ctx -> case SDocContext -> [SDoc]
msgs SDocContext
ctx of
[] -> SDoc
forall doc. IsOutput doc => doc
Outputable.empty
[SDoc
msg] -> SDoc
msg
[SDoc]
xs -> [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]
xs
where
msgs :: SDocContext -> [SDoc]
msgs SDocContext
ctx = (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 opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
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
, errMsgReason :: forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason = ResolvedDiagnosticReason
reason })
= 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
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev ResolvedDiagnosticReason
reason (e -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode e
e))
SrcSpan
s
(DecoratedSDoc -> SDoc
formatBulleted (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 Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printTimingsNotDumpToFile (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 (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)
alloc0 <- IO Int64 -> m Int64
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int64
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 = Int64
alloc0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
alloc1
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
when (logVerbAtLeast logger 2 && printTimingsNotDumpToFile)
$ 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 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 Bool
printTimings
printTimings :: Bool
printTimings =
PrintTimings
prtimings PrintTimings -> PrintTimings -> Bool
forall a. Eq a => a -> a -> Bool
== PrintTimings
PrintTimings
printTimingsNotDumpToFile :: Bool
printTimingsNotDumpToFile =
Bool
printTimings
Bool -> Bool -> Bool
&& Bool -> Bool
not (LogFlags -> Bool
log_dump_to_file (Logger -> LogFlags
logFlags Logger
logger))
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. (HasCallStack, 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 ())