{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Driver.Errors (
    printOrThrowDiagnostics
  , printMessages
  , handleFlagWarnings
  , mkDriverPsHeaderMessage
  ) where

import GHC.Driver.Errors.Types
import GHC.Data.Bag
import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Error
import GHC.Utils.Error
import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle, sdocStyle )
import GHC.Utils.Logger
import qualified GHC.Driver.CmdLine as CmdLine

printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages :: forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagnosticOpts a
msg_opts DiagOpts
opts Messages a
msgs
  = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let style :: PprStyle
style = NamePprCtx -> PprStyle
mkErrStyle NamePprCtx
name_ppr_ctx
                    ctx :: SDocContext
ctx   = (DiagOpts -> SDocContext
diag_ppr_ctx DiagOpts
opts) { sdocStyle :: PprStyle
sdocStyle = PprStyle
style }
                in Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger (Severity
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev (forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason a
dia) (forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
dia)) SrcSpan
s forall a b. (a -> b) -> a -> b
$
                   PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
style (Diagnostic a => SDocContext -> a -> SDoc
messageWithHints SDocContext
ctx a
dia)
              | MsgEnvelope { errMsgSpan :: forall e. MsgEnvelope e -> SrcSpan
errMsgSpan       = SrcSpan
s,
                              errMsgDiagnostic :: forall e. MsgEnvelope e -> e
errMsgDiagnostic = a
dia,
                              errMsgSeverity :: forall e. MsgEnvelope e -> Severity
errMsgSeverity   = Severity
sev,
                              errMsgContext :: forall e. MsgEnvelope e -> NamePprCtx
errMsgContext    = NamePprCtx
name_ppr_ctx }
                  <- forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag (forall a. a -> Maybe a
Just DiagOpts
opts) (forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages a
msgs) ]
  where
    messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc
    messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc
messageWithHints SDocContext
ctx a
e =
      let main_msg :: SDoc
main_msg = SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx forall a b. (a -> b) -> a -> b
$ forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts a
msg_opts a
e
          in case forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
e of
               []  -> SDoc
main_msg
               [GhcHint
h] -> SDoc
main_msg forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Suggested fix:") Int
2 (forall a. Outputable a => a -> SDoc
ppr GhcHint
h)
               [GhcHint]
hs  -> SDoc
main_msg forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Suggested fixes:") Int
2
                                       (SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> DecoratedSDoc
mkDecorated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ [GhcHint]
hs)

handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO ()
handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings Logger
logger GhcMessageOpts
print_config DiagOpts
opts [Warn]
warns = do
  let -- It would be nicer if warns :: [Located SDoc], but that
      -- has circular import problems.
      bag :: Bag (MsgEnvelope GhcMessage)
bag = forall a. [a] -> Bag a
listToBag [ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
opts SrcSpan
loc forall a b. (a -> b) -> a -> b
$
                        DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$
                        UnknownDiagnostic -> DriverMessage
DriverUnknownMessage forall a b. (a -> b) -> a -> b
$
                        forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic forall a b. (a -> b) -> a -> b
$
                        DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
reason [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => String -> doc
text String
warn
                      | CmdLine.Warn DiagnosticReason
reason (L SrcSpan
loc String
warn) <- [Warn]
warns ]

  Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger GhcMessageOpts
print_config DiagOpts
opts (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages Bag (MsgEnvelope GhcMessage)
bag)

-- | Given a bag of diagnostics, turn them into an exception if
-- any has 'SevError', or print them out otherwise.
printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics :: Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger GhcMessageOpts
print_config DiagOpts
opts Messages GhcMessage
msgs
  | forall e. Messages e -> Bool
errorsOrFatalWarningsFound Messages GhcMessage
msgs
  = forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
msgs
  | Bool
otherwise
  = forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger GhcMessageOpts
print_config DiagOpts
opts Messages GhcMessage
msgs

-- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it
-- for dealing with parse errors when the driver is doing dependency analysis.
-- Defined here to avoid module loops between GHC.Driver.Error.Types and
-- GHC.Driver.Error.Ppr
mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsMessage -> DriverMessage
DriverPsHeaderMessage