diff options
Diffstat (limited to 'compiler/GHC/Driver/Errors.hs')
| -rw-r--r-- | compiler/GHC/Driver/Errors.hs | 49 |
1 files changed, 29 insertions, 20 deletions
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 362282d1b9..7afb0f3b26 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -1,29 +1,25 @@ module GHC.Driver.Errors ( printOrThrowDiagnostics - , printBagOfErrors + , printMessages , handleFlagWarnings - , partitionMessageBag + , mkDriverPsHeaderMessage ) where import GHC.Driver.Session +import GHC.Driver.Errors.Types import GHC.Data.Bag -import GHC.Utils.Exception -import GHC.Utils.Error ( formatBulleted, sortMsgBag, mkPlainMsgEnvelope ) -import GHC.Types.SourceError ( mkSrcErr ) import GHC.Prelude +import GHC.Parser.Errors ( PsError(..) ) import GHC.Types.SrcLoc +import GHC.Types.SourceError import GHC.Types.Error +import GHC.Utils.Error import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle ) import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine --- | Partitions the messages and returns a tuple which first element are the warnings, and the --- second the errors. -partitionMessageBag :: Diagnostic e => Bag (MsgEnvelope e) -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) -partitionMessageBag = partitionBag isWarningMessage - -printBagOfErrors :: Diagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO () -printBagOfErrors logger dflags bag_of_errors +printMessages :: Diagnostic a => Logger -> DynFlags -> Messages a -> IO () +printMessages logger dflags msgs = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style in putLogMsg logger dflags (MCDiagnostic sev . diagnosticReason $ dia) s $ @@ -32,22 +28,35 @@ printBagOfErrors logger dflags bag_of_errors errMsgDiagnostic = dia, errMsgSeverity = sev, errMsgContext = unqual } <- sortMsgBag (Just dflags) - bag_of_errors ] + (getMessages msgs) ] handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO () handleFlagWarnings logger dflags warns = do let -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. - bag = listToBag [ mkPlainMsgEnvelope dflags reason loc (text warn) + bag = listToBag [ mkPlainMsgEnvelope dflags loc $ + GhcDriverMessage $ + DriverUnknownMessage $ + mkPlainDiagnostic reason $ + text warn | CmdLine.Warn reason (L loc warn) <- warns ] - printOrThrowDiagnostics logger dflags bag + printOrThrowDiagnostics logger dflags (mkMessages bag) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. -printOrThrowDiagnostics :: Logger -> DynFlags -> Bag WarnMsg -> IO () -printOrThrowDiagnostics logger dflags warns - | any ((==) SevError . errMsgSeverity) warns - = throwIO (mkSrcErr warns) +printOrThrowDiagnostics :: Logger -> DynFlags -> Messages GhcMessage -> IO () +printOrThrowDiagnostics logger dflags msgs + | errorsOrFatalWarningsFound msgs + = throwErrors msgs | otherwise - = printBagOfErrors logger dflags warns + = printMessages logger dflags 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 :: PsError -> MsgEnvelope DriverMessage +mkDriverPsHeaderMessage ps_err + = mkPlainErrorMsgEnvelope (errLoc ps_err) $ + DriverPsHeaderMessage (errDesc ps_err) (errHints ps_err) |