{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE DeriveFunctor   #-}
{-# LANGUAGE RankNTypes      #-}
{-# 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,
        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
  { 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 -> MessageClass
mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass
mkMCDiagnostic DiagOpts
opts DiagnosticReason
reason = Severity -> DiagnosticReason -> MessageClass
MCDiagnostic (DiagOpts -> DiagnosticReason -> Severity
diagReasonSeverity DiagOpts
opts DiagnosticReason
reason) DiagnosticReason
reason
errorDiagnostic :: MessageClass
errorDiagnostic :: MessageClass
errorDiagnostic = Severity -> DiagnosticReason -> MessageClass
MCDiagnostic Severity
SevError DiagnosticReason
ErrorWithoutFlag
mk_msg_envelope
  :: Diagnostic e
  => Severity
  -> SrcSpan
  -> PrintUnqualified
  -> e
  -> MsgEnvelope e
mk_msg_envelope :: forall e.
Diagnostic e =>
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_msg_envelope Severity
severity SrcSpan
locn PrintUnqualified
print_unqual e
err
 = MsgEnvelope { errMsgSpan :: SrcSpan
errMsgSpan = SrcSpan
locn
               , errMsgContext :: PrintUnqualified
errMsgContext = PrintUnqualified
print_unqual
               , errMsgDiagnostic :: e
errMsgDiagnostic = e
err
               , errMsgSeverity :: Severity
errMsgSeverity = Severity
severity
               }
mkMsgEnvelope
  :: Diagnostic e
  => DiagOpts
  -> SrcSpan
  -> PrintUnqualified
  -> e
  -> MsgEnvelope e
mkMsgEnvelope :: forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
opts SrcSpan
locn PrintUnqualified
print_unqual e
err
 = Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
Severity -> SrcSpan -> PrintUnqualified -> 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 PrintUnqualified
print_unqual e
err
mkErrorMsgEnvelope :: Diagnostic e
                   => SrcSpan
                   -> PrintUnqualified
                   -> e
                   -> MsgEnvelope e
mkErrorMsgEnvelope :: forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
locn PrintUnqualified
unqual 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 -> PrintUnqualified -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_msg_envelope Severity
SevError SrcSpan
locn PrintUnqualified
unqual 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 -> PrintUnqualified -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
opts SrcSpan
locn PrintUnqualified
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 -> PrintUnqualified -> e -> MsgEnvelope e
forall e.
Diagnostic e =>
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_msg_envelope Severity
SevError SrcSpan
locn PrintUnqualified
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
Outputable.empty
        [SDoc
msg] -> SDoc
msg
        [SDoc]
_     -> [SDoc] -> SDoc
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
<+>)
pprMessages :: Diagnostic e => Messages e -> SDoc
pprMessages :: forall e. Diagnostic e => Messages e -> SDoc
pprMessages = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> (Messages e -> [SDoc]) -> Messages e -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope e) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (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 => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc :: forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc Bag (MsgEnvelope e)
bag = [ MsgEnvelope e -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope 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 ]
pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope :: forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope (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 -> PrintUnqualified
errMsgContext   = PrintUnqualified
unqual })
  = (SDocContext -> SDoc) -> SDoc
sdocWithContext ((SDocContext -> SDoc) -> SDoc) -> (SDocContext -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \SDocContext
ctx ->
    PrintUnqualified -> SDoc -> SDoc
withErrStyle PrintUnqualified
unqual (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
      MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage (Severity -> DiagnosticReason -> MessageClass
MCDiagnostic Severity
sev (e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason e
e)) SrcSpan
s (SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ e -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage 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
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
text String
"GHC progress: " SDoc -> SDoc -> SDoc
<> 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
text String
"***" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<> SDoc
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
text String
"***" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
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
text String
"!!!" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"finished in"
                     SDoc -> SDoc -> SDoc
<+> Int -> Double -> SDoc
doublePrec Int
2 Double
time
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"milliseconds"
                     SDoc -> SDoc -> SDoc
<> SDoc
comma
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"allocated"
                     SDoc -> SDoc -> SDoc
<+> 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
<+> String -> SDoc
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
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
hsep [ SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon
                           , String -> SDoc
text String
"alloc=" SDoc -> SDoc -> SDoc
<> Int64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int64
alloc
                           , String -> SDoc
text String
"time=" SDoc -> SDoc -> SDoc
<> 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
text String
"GHC:started:" SDoc -> SDoc -> SDoc
<+> 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
text String
"GHC:finished:" SDoc -> SDoc -> SDoc
<+> 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 -> PrintUnqualified -> SDoc -> IO ()
printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()
printInfoForUser Logger
logger PrintUnqualified
print_unqual SDoc
msg
  = Logger -> SDoc -> IO ()
logInfo Logger
logger (PrintUnqualified -> Depth -> SDoc -> SDoc
withUserStyle PrintUnqualified
print_unqual Depth
AllTheWay SDoc
msg)
printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser Logger
logger PrintUnqualified
print_unqual SDoc
msg
  = Logger -> SDoc -> IO ()
logOutput Logger
logger (PrintUnqualified -> Depth -> SDoc -> SDoc
withUserStyle PrintUnqualified
print_unqual 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.
(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. String -> a
panic (String -> SDoc
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. String -> a
sorry (String -> SDoc
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. String -> a
pgmError (String -> SDoc
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
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
char Char
'\n')
      Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (String -> SDoc
text String
"Failed:" SDoc -> SDoc -> SDoc
<+> SDoc
cmd_doc SDoc -> SDoc -> SDoc
<+> String -> SDoc
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