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

import GHC.Driver.Errors.Types
import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Error
import GHC.Utils.Json
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Logger

reportError :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> SDoc -> IO ()
reportError :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> SDoc -> IO ()
reportError Logger
logger NamePprCtx
nameContext DiagOpts
opts SrcSpan
span SDoc
doc = do
  let
    message :: MsgEnvelope DiagnosticMessage
    message :: MsgEnvelope DiagnosticMessage
message = SrcSpan
-> NamePprCtx -> DiagnosticMessage -> MsgEnvelope DiagnosticMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
span NamePprCtx
nameContext DiagnosticMessage {
        diagMessage :: DecoratedSDoc
diagMessage = [SDoc] -> DecoratedSDoc
mkDecorated [SDoc
doc]
      , diagReason :: DiagnosticReason
diagReason = DiagnosticReason
ErrorWithoutFlag
      , diagHints :: [GhcHint]
diagHints = []
      }
  Logger
-> DiagnosticOpts DiagnosticMessage
-> DiagOpts
-> MsgEnvelope DiagnosticMessage
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage Logger
logger NoDiagnosticOpts
DiagnosticOpts DiagnosticMessage
NoDiagnosticOpts DiagOpts
opts MsgEnvelope DiagnosticMessage
message

reportDiagnostic :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> DiagnosticReason -> SDoc -> IO ()
reportDiagnostic :: Logger
-> NamePprCtx
-> DiagOpts
-> SrcSpan
-> DiagnosticReason
-> SDoc
-> IO ()
reportDiagnostic Logger
logger NamePprCtx
nameContext DiagOpts
opts SrcSpan
span DiagnosticReason
reason SDoc
doc = do
  let
    message :: MsgEnvelope DiagnosticMessage
    message :: MsgEnvelope DiagnosticMessage
message = DiagOpts
-> SrcSpan
-> NamePprCtx
-> DiagnosticMessage
-> MsgEnvelope DiagnosticMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
opts SrcSpan
span NamePprCtx
nameContext DiagnosticMessage {
        diagMessage :: DecoratedSDoc
diagMessage = [SDoc] -> DecoratedSDoc
mkDecorated [SDoc
doc]
      , diagReason :: DiagnosticReason
diagReason = DiagnosticReason
reason
      , diagHints :: [GhcHint]
diagHints = []
      }
  Logger
-> DiagnosticOpts DiagnosticMessage
-> DiagOpts
-> MsgEnvelope DiagnosticMessage
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage Logger
logger NoDiagnosticOpts
DiagnosticOpts DiagnosticMessage
NoDiagnosticOpts DiagOpts
opts MsgEnvelope DiagnosticMessage
message

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 = (MsgEnvelope a -> IO ()) -> [MsgEnvelope a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage Logger
logger DiagnosticOpts a
msg_opts DiagOpts
opts) ([MsgEnvelope a] -> IO ())
-> (Messages a -> [MsgEnvelope a]) -> Messages a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages a -> [MsgEnvelope a]
sortMessages
  where
    sortMessages :: Messages a -> [MsgEnvelope a]
    sortMessages :: Messages a -> [MsgEnvelope a]
sortMessages = 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) (Bag (MsgEnvelope a) -> [MsgEnvelope a])
-> (Messages a -> Bag (MsgEnvelope a))
-> Messages a
-> [MsgEnvelope a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages a -> Bag (MsgEnvelope a)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages

printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage :: forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage Logger
logger DiagnosticOpts a
msg_opts DiagOpts
opts MsgEnvelope a
message
  | Bool
log_diags_as_json = do
      decorated <- LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
decorateDiagnostic LogFlags
logflags MessageClass
messageClass SrcSpan
location SDoc
doc
      let
        rendered :: String
        rendered = SDocContext -> SDoc -> String
renderWithContext (LogFlags -> SDocContext
log_default_user_context LogFlags
logflags) SDoc
decorated

        jsonMessage :: JsonDoc
        jsonMessage = String -> MsgEnvelope a -> JsonDoc
forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc
jsonDiagnostic String
rendered MsgEnvelope a
message

      logJsonMsg logger messageClass jsonMessage

  | Bool
otherwise = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
messageClass SrcSpan
location SDoc
doc
  where
    logflags :: LogFlags
    logflags :: LogFlags
logflags = Logger -> LogFlags
logFlags Logger
logger

    doc :: SDoc
    doc :: SDoc
doc = (SDocContext -> SDocContext) -> SDoc -> SDoc
updSDocContext (\SDocContext
_ -> SDocContext
ctx) (a -> SDoc
messageWithHints a
diagnostic)

    messageClass :: MessageClass
    messageClass :: MessageClass
messageClass = Severity
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
severity (MsgEnvelope a -> ResolvedDiagnosticReason
forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason MsgEnvelope a
message) (a -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
diagnostic)

    style :: PprStyle
    style :: PprStyle
style = NamePprCtx -> PprStyle
mkErrStyle (MsgEnvelope a -> NamePprCtx
forall e. MsgEnvelope e -> NamePprCtx
errMsgContext MsgEnvelope a
message)

    location :: SrcSpan
    location :: SrcSpan
location = MsgEnvelope a -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope a
message

    ctx :: SDocContext
    ctx :: SDocContext
ctx = (DiagOpts -> SDocContext
diag_ppr_ctx DiagOpts
opts) { sdocStyle = style }

    diagnostic :: a
    diagnostic :: a
diagnostic = MsgEnvelope a -> a
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope a
message

    severity :: Severity
    severity :: Severity
severity = MsgEnvelope a -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity MsgEnvelope a
message

    messageWithHints :: a -> SDoc
    messageWithHints :: a -> SDoc
messageWithHints a
e =
      let main_msg :: SDoc
main_msg = DecoratedSDoc -> SDoc
formatBulleted (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 -> [DiagnosticHint a]
forall a. Diagnostic a => a -> [DiagnosticHint a]
diagnosticHints a
e of
               []  -> SDoc
main_msg
               [DiagnosticHint a
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 (DiagnosticHint a -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticHint a
h)
               [DiagnosticHint a]
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
                                       (DecoratedSDoc -> SDoc
formatBulleted  (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> DecoratedSDoc
mkDecorated ([SDoc] -> DecoratedSDoc)
-> ([DiagnosticHint a] -> [SDoc])
-> [DiagnosticHint a]
-> DecoratedSDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagnosticHint a -> SDoc) -> [DiagnosticHint a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map DiagnosticHint a -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([DiagnosticHint a] -> DecoratedSDoc)
-> [DiagnosticHint a] -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [DiagnosticHint a]
hs)

    log_diags_as_json :: Bool
    log_diags_as_json :: Bool
log_diags_as_json = LogFlags -> Bool
log_diagnostics_as_json (Logger -> LogFlags
logFlags Logger
logger)

-- | 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