{-# 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
  = [IO ()] -> IO ()
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 = style }
                in Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger (Severity
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev (a -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason a
dia) (a -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
dia)) SrcSpan
s (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                   PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
style (SDocContext -> a -> SDoc
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 }
                  <- Maybe DiagOpts -> Bag (MsgEnvelope a) -> [MsgEnvelope a]
forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag (DiagOpts -> Maybe DiagOpts
forall a. a -> Maybe a
Just DiagOpts
opts) (Messages a -> Bag (MsgEnvelope a)
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 (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts a
msg_opts a
e
          in case a -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
e of
               []  -> SDoc
main_msg
               [GhcHint
h] -> SDoc
main_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Suggested fix:") Int
2 (GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr GhcHint
h)
               [GhcHint]
hs  -> SDoc
main_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Suggested fixes:") Int
2
                                       (SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx (DecoratedSDoc -> SDoc)
-> ([GhcHint] -> DecoratedSDoc) -> [GhcHint] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> DecoratedSDoc
mkDecorated ([SDoc] -> DecoratedSDoc)
-> ([GhcHint] -> [SDoc]) -> [GhcHint] -> DecoratedSDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([GhcHint] -> SDoc) -> [GhcHint] -> SDoc
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 = [MsgEnvelope GhcMessage] -> Bag (MsgEnvelope GhcMessage)
forall a. [a] -> Bag a
listToBag [ DiagOpts -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
opts SrcSpan
loc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
                        DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$
                        UnknownDiagnostic -> DriverMessage
DriverUnknownMessage (UnknownDiagnostic -> DriverMessage)
-> UnknownDiagnostic -> DriverMessage
forall a b. (a -> b) -> a -> b
$
                        DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$
                        DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
reason [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
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 (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
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
  | Messages GhcMessage -> Bool
forall e. Messages e -> Bool
errorsOrFatalWarningsFound Messages GhcMessage
msgs
  = Messages GhcMessage -> IO ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
msgs
  | Bool
otherwise
  = Logger
-> DiagnosticOpts GhcMessage
-> DiagOpts
-> Messages GhcMessage
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagnosticOpts GhcMessage
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 = (PsMessage -> DriverMessage)
-> MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsMessage -> DriverMessage
DriverPsHeaderMessage