diff options
| author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-04-06 16:27:14 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-04-29 17:27:19 -0400 |
| commit | 7d18e1bace3f3a85eae177654690d91b688c0e8f (patch) | |
| tree | fca073e898068e90dd49c4ea9243c628dbb4469b | |
| parent | 7bb3443a4fe8acfaa3fec34f58c91173f737777d (diff) | |
| download | haskell-7d18e1bace3f3a85eae177654690d91b688c0e8f.tar.gz | |
Add GhcMessage and ancillary types
This commit adds GhcMessage and ancillary (PsMessage, TcRnMessage, ..)
types.
These types will be expanded to represent more errors generated
by different subsystems within GHC. Right now, they are underused,
but more will come in the glorious future.
See
https://gitlab.haskell.org/ghc/ghc/-/wikis/Errors-as-(structured)-values
for a design overview.
Along the way, lots of other things had to happen:
* Adds Semigroup and Monoid instance for Bag
* Fixes #19746 by parsing OPTIONS_GHC pragmas into Located Strings.
See GHC.Parser.Header.toArgs (moved from GHC.Utils.Misc, where it
didn't belong anyway).
* Addresses (but does not completely fix) #19709, now reporting
desugarer warnings and errors appropriately for TH splices.
Not done: reporting type-checker warnings for TH splices.
* Some small refactoring around Safe Haskell inference, in order
to keep separate classes of messages separate.
* Some small refactoring around initDsTc, in order to keep separate
classes of messages separate.
* Separate out the generation of messages (that is, the construction
of the text block) from the wrapping of messages (that is, assigning
a SrcSpan). This is more modular than the previous design, which
mixed the two.
Close #19746.
This was a collaborative effort by Alfredo di Napoli and
Richard Eisenberg, with a key assist on #19746 by Iavor
Diatchki.
Metric Increase:
MultiLayerModules
88 files changed, 1333 insertions, 653 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 59f49453ed..2a75c2b840 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -307,6 +307,7 @@ import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename , isSourceFilename, startPhase ) import GHC.Driver.Env import GHC.Driver.Errors +import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session import qualified GHC.Driver.Session as Session @@ -338,7 +339,6 @@ import GHC.Iface.Load ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Iface.Tidy -import GHC.Data.Bag ( listToBag ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt @@ -382,6 +382,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SafeHaskell +import GHC.Types.Error hiding ( getMessages, getErrorMessages ) import GHC.Types.Fixity import GHC.Types.Target import GHC.Types.Basic @@ -390,7 +391,6 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.SourceFile -import GHC.Types.Error ( DiagnosticMessage ) import GHC.Unit import GHC.Unit.Env @@ -912,9 +912,11 @@ checkNewInteractiveDynFlags logger dflags0 = do -- We currently don't support use of StaticPointers in expressions entered on -- the REPL. See #12356. if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowDiagnostics logger dflags0 $ listToBag - [mkPlainMsgEnvelope dflags0 Session.WarningWithoutFlag interactiveSrcSpan - $ text "StaticPointers is not supported in GHCi interactive expressions."] + then do liftIO $ printOrThrowDiagnostics logger dflags0 $ singleMessage + $ mkPlainMsgEnvelope dflags0 interactiveSrcSpan + $ GhcDriverMessage $ DriverUnknownMessage + $ mkPlainDiagnostic Session.WarningWithoutFlag + $ text "StaticPointers is not supported in GHCi interactive expressions." return $ xopt_unset dflags0 LangExt.StaticPointers else return dflags0 @@ -1505,7 +1507,7 @@ getNameToInstancesIndex :: GhcMonad m -- if it is visible from at least one module in the list. -> Maybe [Module] -- ^ modules to load. If this is not specified, we load -- modules for everything that is in scope unqualified. - -> m (Messages DiagnosticMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) + -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $ @@ -1610,7 +1612,7 @@ getTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return ts - PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst)) + PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with @@ -1621,7 +1623,7 @@ getRichTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst)) + PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the @@ -1801,11 +1803,12 @@ parser str dflags filename = PFailed pst -> let (warns,errs) = getMessages pst in - (fmap (mkParserWarn dflags) warns, Left (fmap mkParserErr errs)) + (foldPsMessages (mkParserWarn dflags) warns + , Left (foldPsMessages mkParserErr errs)) POk pst rdr_module -> let (warns,_) = getMessages pst in - (fmap (mkParserWarn dflags) warns, Right rdr_module) + (foldPsMessages (mkParserWarn dflags) warns, Right rdr_module) -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs index e314309efc..338b463832 100644 --- a/compiler/GHC/Data/Bag.hs +++ b/compiler/GHC/Data/Bag.hs @@ -37,6 +37,7 @@ import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Foldable as Foldable +import qualified Data.Semigroup ( (<>) ) infixr 3 `consBag` infixl 3 `snocBag` @@ -343,3 +344,9 @@ instance IsList (Bag a) where type Item (Bag a) = a fromList = listToBag toList = bagToList + +instance Semigroup (Bag a) where + (<>) = unionBags + +instance Monoid (Bag a) where + mempty = emptyBag diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index b781685e91..30289129c4 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -31,6 +31,7 @@ import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Env import GHC.Driver.Errors +import GHC.Driver.Errors.Types import GHC.Parser import GHC.Parser.Header @@ -107,7 +108,7 @@ doBackpack [src_filename] = do buf <- liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst)) + PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it. @@ -808,9 +809,10 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing Nothing -- GHC API buffer support not supported [] -- No exclusions case r of - Nothing -> throwOneError (mkPlainErrorMsgEnvelope loc - (text "module" <+> ppr modname <+> text "was not found")) - Just (Left err) -> throwErrors err + Nothing -> throwOneError $ mkPlainErrorMsgEnvelope loc $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + (text "module" <+> ppr modname <+> text "was not found") + Just (Left err) -> throwErrors (fmap GhcDriverMessage err) Just (Right summary) -> return summary -- | Up until now, GHC has assumed a single compilation target per source file. diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 3fff8ab65c..219e66106b 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -50,6 +50,7 @@ import GHC.Core.InstEnv ( ClsInst ) import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import GHC.Types.CompleteMatch +import GHC.Types.Error ( emptyMessages ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.TyThing @@ -57,7 +58,6 @@ import GHC.Types.TyThing import GHC.Builtin.Names ( gHC_PRIM ) import GHC.Data.Maybe -import GHC.Data.Bag import GHC.Utils.Outputable import GHC.Utils.Monad @@ -69,7 +69,7 @@ import Data.IORef runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do - (a, w) <- hsc hsc_env emptyBag + (a, w) <- hsc hsc_env emptyMessages printOrThrowDiagnostics (hsc_logger hsc_env) (hsc_dflags hsc_env) w return a diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index d1fc22314a..d672de33e6 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -4,12 +4,13 @@ module GHC.Driver.Env.Types , HscEnv(..) ) where +import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Driver.Session ( DynFlags, HasDynFlags(..) ) import GHC.Prelude import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types ( Interp ) -import GHC.Types.Error ( WarningMessages ) +import GHC.Types.Error ( Messages ) import GHC.Types.Name.Cache import GHC.Types.Target import GHC.Types.TypeEnv @@ -25,8 +26,8 @@ import Control.Monad ( ap ) import Control.Monad.IO.Class import Data.IORef --- | The Hsc monad: Passing an environment and warning state -newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) +-- | The Hsc monad: Passing an environment and diagnostic state +newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)) deriving (Functor) instance Applicative Hsc where 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) diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs new file mode 100644 index 0000000000..06ebe0be96 --- /dev/null +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} + +module GHC.Driver.Errors.Ppr where + +import GHC.Prelude + +import GHC.Types.Error +import GHC.Driver.Errors.Types +import GHC.Parser.Errors.Ppr +import GHC.Tc.Errors.Ppr () +import GHC.HsToCore.Errors.Ppr () + +instance Diagnostic GhcMessage where + diagnosticMessage = \case + GhcPsMessage m + -> diagnosticMessage m + GhcTcRnMessage m + -> diagnosticMessage m + GhcDsMessage m + -> diagnosticMessage m + GhcDriverMessage m + -> diagnosticMessage m + GhcUnknownMessage m + -> diagnosticMessage m + + diagnosticReason = \case + GhcPsMessage m + -> diagnosticReason m + GhcTcRnMessage m + -> diagnosticReason m + GhcDsMessage m + -> diagnosticReason m + GhcDriverMessage m + -> diagnosticReason m + GhcUnknownMessage m + -> diagnosticReason m + +instance Diagnostic DriverMessage where + diagnosticMessage (DriverUnknownMessage m) = diagnosticMessage m + diagnosticMessage (DriverPsHeaderMessage desc hints) + = mkSimpleDecorated $ pprPsError desc hints + + diagnosticReason (DriverUnknownMessage m) = diagnosticReason m + diagnosticReason (DriverPsHeaderMessage {}) = ErrorWithoutFlag diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs new file mode 100644 index 0000000000..017852fcbb --- /dev/null +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE GADTs #-} + +module GHC.Driver.Errors.Types ( + GhcMessage(..) + , DriverMessage(..), DriverMessages + , WarningMessages + , ErrorMessages + , WarnMsg + -- * Constructors + , ghcUnknownMessage + -- * Utility functions + , hoistTcRnMessage + , hoistDsMessage + , foldPsMessages + ) where + +import GHC.Prelude + +import Data.Typeable +import GHC.Types.Error + +import GHC.Parser.Errors ( PsErrorDesc, PsHint ) +import GHC.Parser.Errors.Types ( PsMessage ) +import GHC.Tc.Errors.Types ( TcRnMessage ) +import GHC.HsToCore.Errors.Types ( DsMessage ) +import Data.Bifunctor + +-- | A collection of warning messages. +-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. +type WarningMessages = Messages GhcMessage + +-- | A collection of error messages. +-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevError' severity. +type ErrorMessages = Messages GhcMessage + +-- | A single warning message. +-- /INVARIANT/: It must have 'SevWarning' severity. +type WarnMsg = MsgEnvelope GhcMessage + + +{- Note [GhcMessage] +~~~~~~~~~~~~~~~~~~~~ + +We might need to report diagnostics (error and/or warnings) to the users. The +'GhcMessage' type is the root of the diagnostic hierarchy. + +It's useful to have a separate type constructor for the different stages of +the compilation pipeline. This is not just helpful for tools, as it gives a +clear indication on where the error occurred exactly. Furthermore it increases +the modularity amongst the different components of GHC (i.e. to avoid having +"everything depend on everything else") and allows us to write separate +functions that renders the different kind of messages. + +-} + +-- | The umbrella type that encompasses all the different messages that GHC +-- might output during the different compilation stages. See +-- Note [GhcMessage]. +data GhcMessage where + -- | A message from the parsing phase. + GhcPsMessage :: PsMessage -> GhcMessage + -- | A message from typecheck/renaming phase. + GhcTcRnMessage :: TcRnMessage -> GhcMessage + -- | A message from the desugaring (HsToCore) phase. + GhcDsMessage :: DsMessage -> GhcMessage + -- | A message from the driver. + GhcDriverMessage :: DriverMessage -> GhcMessage + + -- | An \"escape\" hatch which can be used when we don't know the source of + -- the message or if the message is not one of the typed ones. The + -- 'Diagnostic' and 'Typeable' constraints ensure that if we /know/, at + -- pattern-matching time, the originating type, we can attempt a cast and + -- access the fully-structured error. This would be the case for a GHC + -- plugin that offers a domain-specific error type but that doesn't want to + -- place the burden on IDEs/application code to \"know\" it. The + -- 'Diagnostic' constraint ensures that worst case scenario we can still + -- render this into something which can be eventually converted into a + -- 'DecoratedSDoc'. + GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage + +-- | Creates a new 'GhcMessage' out of any diagnostic. This function is also +-- provided to ease the integration of #18516 by allowing diagnostics to be +-- wrapped into the general (but structured) 'GhcMessage' type, so that the +-- conversion can happen gradually. This function should not be needed within +-- GHC, as it would typically be used by plugin or library authors (see +-- comment for the 'GhcUnknownMessage' type constructor) +ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage +ghcUnknownMessage = GhcUnknownMessage + +-- | Given a collection of @e@ wrapped in a 'Foldable' structure, converts it +-- into 'Messages' via the supplied transformation function. +foldPsMessages :: Foldable f + => (e -> MsgEnvelope PsMessage) + -> f e + -> Messages GhcMessage +foldPsMessages f = foldMap (singleMessage . fmap GhcPsMessage . f) + +-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on +-- the result of 'IO (Messages TcRnMessage, a)'. +hoistTcRnMessage :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a) +hoistTcRnMessage = fmap (first (fmap GhcTcRnMessage)) + +-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on +-- the result of 'IO (Messages DsMessage, a)'. +hoistDsMessage :: Monad m => m (Messages DsMessage, a) -> m (Messages GhcMessage, a) +hoistDsMessage = fmap (first (fmap GhcDsMessage)) + +-- | A message from the driver. +data DriverMessage + = DriverUnknownMessage !DiagnosticMessage + -- ^ Simply rewraps a generic 'DiagnosticMessage'. More + -- constructors will be added in the future (#18516). + | DriverPsHeaderMessage !PsErrorDesc ![PsHint] + -- ^ A parse error in parsing a Haskell file header during dependency + -- analysis + +-- | A collection of driver messages +type DriverMessages = Messages DriverMessage + +-- | A message about Safe Haskell. diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index cac12cae50..c147733bb3 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -95,6 +95,7 @@ import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Env import GHC.Driver.Errors +import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config import GHC.Driver.Hooks @@ -144,6 +145,7 @@ import GHC.CoreToStg ( coreToStg ) import GHC.Parser.Errors import GHC.Parser.Errors.Ppr +import GHC.Parser.Errors.Types import GHC.Parser import GHC.Parser.Lexer as Lexer @@ -188,7 +190,8 @@ import GHC.Types.SourceError import GHC.Types.SafeHaskell import GHC.Types.ForeignStubs import GHC.Types.Var.Env ( emptyTidyEnv ) -import GHC.Types.Error hiding ( getMessages ) +import GHC.Types.Error hiding ( getMessages ) +import qualified GHC.Types.Error as Error.Types import GHC.Types.Fixity.Env import GHC.Types.CostCentre import GHC.Types.IPE @@ -206,7 +209,6 @@ import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Outputable -import GHC.Utils.Exception import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -265,14 +267,14 @@ newHscEnv dflags = do -- ----------------------------------------------------------------------------- -getWarnings :: Hsc WarningMessages -getWarnings = Hsc $ \_ w -> return (w, w) +getDiagnostics :: Hsc (Messages GhcMessage) +getDiagnostics = Hsc $ \_ w -> return (w, w) -clearWarnings :: Hsc () -clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) +clearDiagnostics :: Hsc () +clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages) -logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc () -logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) +logDiagnostics :: Messages GhcMessage -> Hsc () +logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w) @@ -281,32 +283,32 @@ handleWarnings :: Hsc () handleWarnings = do dflags <- getDynFlags logger <- getLogger - w <- getWarnings + w <- getDiagnostics liftIO $ printOrThrowDiagnostics logger dflags w - clearWarnings + clearDiagnostics -- | log warning in the monad, and if there are errors then -- throw a SourceError exception. logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do dflags <- getDynFlags - let warns = fmap (mkParserWarn dflags) warnings - errs = fmap mkParserErr errors + let warns = foldPsMessages (mkParserWarn dflags) warnings + errs = foldPsMessages mkParserErr errors logDiagnostics warns - when (not $ isEmptyBag errs) $ throwErrors errs + when (not $ isEmptyMessages errs) $ throwErrors errs -- | Log warnings and throw errors, assuming the messages -- contain at least one error (e.g. coming from PFailed) handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do dflags <- getDynFlags - let warns = fmap (mkParserWarn dflags) warnings - errs = fmap mkParserErr errors + let warns = foldPsMessages (mkParserWarn dflags) warnings + errs = foldPsMessages mkParserErr errors logDiagnostics warns logger <- getLogger - let (wWarns, wErrs) = partitionMessageBag warns - liftIO $ printBagOfErrors logger dflags wWarns - throwErrors (unionBags errs wErrs) + let (wWarns, wErrs) = partitionMessages warns + liftIO $ printMessages logger dflags wWarns + throwErrors $ errs `unionMessages` wErrs -- | Deal with errors and warnings returned by a compilation step -- @@ -324,21 +326,21 @@ handleWarningsThrowErrors (warnings, errors) = do -- 2. If there are no error messages, but the second result indicates failure -- there should be warnings in the first result. That is, if the action -- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc a +ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a ioMsgMaybe ioA = do (msgs, mb_r) <- liftIO ioA let (warns, errs) = partitionMessages msgs logDiagnostics warns case mb_r of Nothing -> throwErrors errs - Just r -> ASSERT( isEmptyBag errs ) return r + Just r -> ASSERT( isEmptyMessages errs ) return r -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a) ioMsgMaybe' ioA = do (msgs, mb_r) <- liftIO $ ioA - logDiagnostics (getWarningMessages msgs) + logDiagnostics (mkMessages $ getWarningMessages msgs) return mb_r -- ----------------------------------------------------------------------------- @@ -348,12 +350,12 @@ hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name] hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do { hsc_env <- getHscEnv - ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } + ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name } hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv - ioMsgMaybe' $ tcRnLookupName hsc_env name + ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name -- ignore errors: the only error we're likely to get is -- "name not found", and the Maybe in the return type -- is used to indicate that. @@ -363,23 +365,23 @@ hscTcRnGetInfo :: HscEnv -> Name hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do { hsc_env <- getHscEnv - ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } + ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name } hscIsGHCiMonad :: HscEnv -> String -> IO Name hscIsGHCiMonad hsc_env name - = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name + = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name hscGetModuleInterface :: HscEnv -> Module -> IO ModIface hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv - ioMsgMaybe $ getModuleInterface hsc_env mod + ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod -- ----------------------------------------------------------------------------- -- | Rename some import declarations hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv - ioMsgMaybe $ tcRnImportDecls hsc_env import_decls + ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls -- ----------------------------------------------------------------------------- -- | parse a file, returning the abstract syntax @@ -417,7 +419,10 @@ hscParse' mod_summary PFailed pst -> handleWarningsThrowErrors (getMessages pst) POk pst rdr_module -> do - let (warns, errs) = bimap (fmap (mkParserWarn dflags)) (fmap mkParserErr) (getMessages pst) + let (warns, errs) = + bimap (foldPsMessages (mkParserWarn dflags)) + (foldPsMessages mkParserErr) + (getMessages pst) logDiagnostics warns liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) @@ -427,7 +432,7 @@ hscParse' mod_summary rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module) - when (not $ isEmptyBag errs) $ throwErrors errs + when (not $ isEmptyMessages errs) $ throwErrors errs -- To get the list of extra source files, we take the list -- that the parser gave us, @@ -537,7 +542,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do keep_rn' = gopt Opt_WriteHie dflags || keep_rn MASSERT( isHomeModule home_unit outer_mod ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) - then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else do hpm <- case mb_rdr_module of Just hpm -> return hpm @@ -545,7 +550,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing - ioMsgMaybe $ + ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0 -- TODO are we extracting anything when we merely instantiate a signature? @@ -564,18 +569,20 @@ tcRnModule' sum save_rn_syntax mod = do -- -Wmissing-safe-haskell-mode when (not (safeHaskellModeEnabled dflags) && wopt Opt_WarnMissingSafeHaskellMode dflags) $ - logDiagnostics $ unitBag $ - mkPlainMsgEnvelope dflags reason (getLoc (hpm_module mod)) $ - warnMissingSafeHaskellMode + logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope dflags (getLoc (hpm_module mod)) $ + GhcDriverMessage $ DriverUnknownMessage $ + mkPlainDiagnostic reason warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ + ioMsgMaybe $ hoistTcRnMessage $ tcRnModule hsc_env sum save_rn_syntax mod -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case. - (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res) + tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res) + whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res) let allSafeOK = safeInferred dflags && tcSafeOK -- end of the safe haskell line, how to respond to user? @@ -587,20 +594,22 @@ tcRnModule' sum save_rn_syntax mod = do -- module (could be) safe, throw warning if needed else do tcg_res' <- hscCheckSafeImports tcg_res - safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') + safe <- liftIO $ readIORef (tcg_safe_infer tcg_res') when safe $ case wopt Opt_WarnSafe dflags of True | safeHaskell dflags == Sf_Safe -> return () - | otherwise -> (logDiagnostics $ unitBag $ - mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnSafe) - (warnSafeOnLoc dflags) $ + | otherwise -> (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope dflags (warnSafeOnLoc dflags) $ + GhcDriverMessage $ DriverUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> - (logDiagnostics $ unitBag $ - mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnTrustworthySafe) - (trustworthyOnLoc dflags) $ + (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope dflags (trustworthyOnLoc dflags) $ + GhcDriverMessage $ DriverUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) $ errTwthySafe tcg_res') False -> return () return tcg_res' @@ -620,9 +629,9 @@ hscDesugar hsc_env mod_summary tc_result = hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts hscDesugar' mod_location tc_result = do hsc_env <- getHscEnv - r <- ioMsgMaybe $ - {-# SCC "deSugar" #-} - deSugar hsc_env mod_location tc_result + r <- ioMsgMaybe $ hoistDsMessage $ + {-# SCC "deSugar" #-} + deSugar hsc_env mod_location tc_result -- always check -Werror after desugaring, this is the last opportunity for -- warnings to arise before the backend. @@ -1177,7 +1186,7 @@ hscCheckSafeImports tcg_env = do case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES - logDiagnostics $ warns dflags (tcg_rules tcg_env') + logDiagnostics $ fmap GhcDriverMessage $ warns dflags (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- SafeInferred: user defined RULES, so not safe @@ -1188,11 +1197,13 @@ hscCheckSafeImports tcg_env = do | otherwise -> return tcg_env' - warns dflags rules = listToBag $ map (warnRules dflags) rules + warns dflags rules = mkMessages $ listToBag $ map (warnRules dflags) rules - warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage + warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage warnRules df (L loc (HsRule { rd_name = n })) = - mkPlainMsgEnvelope df WarningWithoutFlag (locA loc) $ + mkPlainMsgEnvelope df (locA loc) $ + DriverUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1218,33 +1229,33 @@ checkSafeImports tcg_env -- We want to use the warning state specifically for detecting if safe -- inference has failed, so store and clear any existing warnings. - oldErrs <- getWarnings - clearWarnings + oldErrs <- getDiagnostics + clearDiagnostics -- Check safe imports are correct safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps - safeErrs <- getWarnings - clearWarnings + safeErrs <- getDiagnostics + clearDiagnostics -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyBag, S.empty) + False -> return (emptyMessages, S.empty) True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps - infErrs <- getWarnings - clearWarnings + infErrs <- getDiagnostics + clearDiagnostics return (infErrs, infPkgs) -- restore old errors logDiagnostics oldErrs - case (isEmptyBag safeErrs) of + case (isEmptyMessages safeErrs) of -- Failed safe check - False -> liftIO . throwIO . mkSrcErr $ safeErrs + False -> liftIO . throwErrors $ safeErrs -- Passed safe check True -> do - let infPassed = isEmptyBag infErrs + let infPassed = isEmptyMessages infErrs tcg_env' <- case (not infPassed) of True -> markUnsafeInfer tcg_env infErrs False -> return tcg_env @@ -1268,9 +1279,11 @@ checkSafeImports tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = throwOneError $ mkPlainErrorMsgEnvelope (imv_span v1) - (text "Module" <+> ppr (imv_name v1) <+> - (text $ "is imported both as a safe and unsafe import!")) + = throwOneError $ + mkPlainErrorMsgEnvelope (imv_span v1) $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + text "Module" <+> ppr (imv_name v1) <+> + (text $ "is imported both as a safe and unsafe import!") | otherwise = return v1 @@ -1299,15 +1312,15 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do dflags <- getDynFlags pkgs <- snd `fmap` hscCheckSafe' m l when (packageTrustOn dflags) $ checkPkgTrust pkgs - errs <- getWarnings - return $ isEmptyBag errs + errs <- getDiagnostics + return $ isEmptyMessages errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l - good <- isEmptyBag `fmap` getWarnings - clearWarnings -- don't want them printed... + good <- isEmptyMessages `fmap` getDiagnostics + clearDiagnostics -- don't want them printed... let pkgs' | Just p <- self = S.insert p pkgs | otherwise = pkgs return (good, pkgs') @@ -1336,9 +1349,11 @@ hscCheckSafe' m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainErrorMsgEnvelope l - $ text "Can't load the interface file for" <+> ppr m - <> text ", to check that it can be safely imported" + Nothing -> throwOneError $ + mkPlainErrorMsgEnvelope l $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" -- got iface, check trust Just iface' -> @@ -1355,10 +1370,10 @@ hscCheckSafe' m l = do && safeLanguageOn dflags && trust == Sf_SafeInferred then inferredImportWarn dflags - else emptyBag + else emptyMessages -- General errors we throw but Safe errors we log errs = case (safeM, safeP) of - (True, True ) -> emptyBag + (True, True ) -> emptyMessages (True, False) -> pkgTrustErr (False, _ ) -> modTrustErr in do @@ -1368,24 +1383,29 @@ hscCheckSafe' m l = do where state = hsc_units hsc_env - inferredImportWarn dflags = unitBag - $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports) - l (pkgQual state) + inferredImportWarn dflags = singleMessage + $ mkMsgEnvelope dflags l (pkgQual state) + $ GhcDriverMessage $ DriverUnknownMessage + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag - $ mkShortErrorMsgEnvelope l (pkgQual state) + pkgTrustErr = singleMessage + $ mkErrorMsgEnvelope l (pkgQual state) + $ GhcDriverMessage $ DriverUnknownMessage + $ mkPlainError $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" <> (pprWithUnitState state $ ppr (moduleUnit m)) <> text ") the module resides in isn't trusted." ] - modTrustErr = unitBag - $ mkShortErrorMsgEnvelope l (pkgQual state) + modTrustErr = singleMessage + $ mkErrorMsgEnvelope l (pkgQual state) + $ GhcDriverMessage $ DriverUnknownMessage + $ mkPlainError $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1425,20 +1445,24 @@ hscCheckSafe' m l = do checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do hsc_env <- getHscEnv - let errors = S.foldr go [] pkgs + let errors = S.foldr go emptyBag pkgs state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkShortErrorMsgEnvelope noSrcSpan (pkgQual state) + = (`consBag` acc) + $ mkErrorMsgEnvelope noSrcSpan (pkgQual state) + $ GhcDriverMessage + $ DriverUnknownMessage + $ mkPlainError $ pprWithUnitState state $ text "The package (" <> ppr pkg <> text ") is required to be trusted but it isn't!" - case errors of - [] -> return () - _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + if isEmptyBag errors + then return () + else liftIO $ throwErrors $ mkMessages errors -- | Set module to unsafe and (potentially) wipe trust information. -- @@ -1450,16 +1474,20 @@ checkPkgTrust pkgs = do -- may call it on modules using Trustworthy or Unsafe flags so as to allow -- warning flags for safety to function correctly. See Note [Safe Haskell -- Inference]. -markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags let reason = WarningWithFlag Opt_WarnUnsafe when (wopt Opt_WarnUnsafe dflags) - (logDiagnostics $ unitBag $ - mkPlainMsgEnvelope dflags reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) - - liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) + (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope dflags (warnUnsafeOnLoc dflags) $ + GhcDriverMessage $ DriverUnknownMessage $ + mkPlainDiagnostic reason $ + whyUnsafe' dflags) + + liftIO $ writeIORef (tcg_safe_infer tcg_env) False + liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other -- times inference may be on but we are in Trustworthy mode -- so we want -- to record safe-inference failed but not wipe the trust dependencies. @@ -1473,7 +1501,7 @@ markUnsafeInfer tcg_env whyUnsafe = do whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" , nest 4 $ (vcat $ badFlags df) $+$ - (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$ + (vcat $ pprMsgEnvelopeBagWithLoc (Error.Types.getMessages whyUnsafe)) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer @@ -1689,7 +1717,10 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do $ do (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename - return (mkMessages (fmap (mkParserWarn dflags) warns `unionBags` fmap mkParserErr errs), cmm) + let msgs = foldPsMessages (mkParserWarn dflags) warns + `unionMessages` + foldPsMessages mkParserErr errs + return (msgs, cmm) liftIO $ do dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) @@ -1889,10 +1920,10 @@ hscParsedStmt :: HscEnv , FixityEnv)) hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do -- Rename and typecheck it - (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt + (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt -- Desugar it - ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr + ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr) handleWarnings @@ -1936,7 +1967,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do let interp = hscInterp hsc_env {- Rename and typecheck it -} - tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls + tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls {- Grab the new instances -} -- We grab the whole environment because of the overlapping that may have @@ -2051,6 +2082,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do [L _ i] -> return i _ -> liftIO $ throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ + GhcPsMessage $ PsUnknownMessage $ mkPlainError $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -2061,7 +2093,7 @@ hscTcExpr :: HscEnv hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv parsed_expr <- hscParseExpr expr - ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr + ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr -- | Find the kind of a type, after generalisation hscKcType @@ -2072,15 +2104,17 @@ hscKcType hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ty <- hscParseType str - ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty + ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty hscParseExpr :: String -> Hsc (LHsExpr GhcPs) hscParseExpr expr = do maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan - (text "not an expression:" <+> quotes (text expr)) + _ -> throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcPsMessage $ PsUnknownMessage $ mkPlainError $ + text "not an expression:" <+> quotes (text expr) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) hscParseStmt = hscParseThing parseStmt diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 484353ae4d..68245b42ca 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -61,16 +61,16 @@ import GHC.Driver.Backend import GHC.Driver.Monad import GHC.Driver.Env import GHC.Driver.Errors +import GHC.Driver.Errors.Types import GHC.Driver.Main import GHC.Parser.Header -import GHC.Parser.Errors.Ppr import GHC.Iface.Load ( cannotFindModule ) import GHC.IfaceToCore ( typecheckIface ) import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) ) -import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) +import GHC.Data.Bag ( listToBag ) import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) @@ -164,20 +164,20 @@ depanal :: GhcMonad m => -> m ModuleGraph depanal excluded_mods allow_dup_roots = do (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots - if isEmptyBag errs + if isEmptyMessages errs then pure mod_graph - else throwErrors errs + else throwErrors (fmap GhcDriverMessage errs) -- | Perform dependency analysis like in 'depanal'. -- In case of errors, the errors and an empty module graph are returned. depanalE :: GhcMonad m => -- New for #17459 [ModuleName] -- ^ excluded modules -> Bool -- ^ allow duplicate roots - -> m (ErrorMessages, ModuleGraph) + -> m (DriverMessages, ModuleGraph) depanalE excluded_mods allow_dup_roots = do hsc_env <- getSession (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots - if isEmptyBag errs + if isEmptyMessages errs then do warnMissingHomeModules hsc_env mod_graph setSession hsc_env { hsc_mod_graph = mod_graph } @@ -202,7 +202,7 @@ depanalPartial :: GhcMonad m => [ModuleName] -- ^ excluded modules -> Bool -- ^ allow duplicate roots - -> m (ErrorMessages, ModuleGraph) + -> m (DriverMessages, ModuleGraph) -- ^ possibly empty 'Bag' of errors and a module graph. depanalPartial excluded_mods allow_dup_roots = do hsc_env <- getSession @@ -230,7 +230,7 @@ depanalPartial excluded_mods allow_dup_roots = do (errs, mod_summaries) = partitionEithers mod_summariesE mod_graph = mkModuleGraph' $ fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env) - return (unionManyBags errs, mod_graph) + return (unionManyMessages errs, mod_graph) -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. -- These are used to represent the type checking that is done after @@ -271,7 +271,7 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () warnMissingHomeModules hsc_env mod_graph = when (not (null missing)) $ - logWarnings (listToBag [warn]) + logDiagnostics warn where dflags = hsc_dflags hsc_env targets = map targetId (hsc_targets hsc_env) @@ -318,8 +318,10 @@ warnMissingHomeModules hsc_env mod_graph = (text "Modules are not listed in command line but needed for compilation: ") 4 (sep (map ppr missing)) - warn = - mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg + warn = singleMessage $ + mkPlainMsgEnvelope (hsc_dflags hsc_env) noSrcSpan $ + GhcDriverMessage $ DriverUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingHomeModules) msg -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -351,9 +353,9 @@ load how_much = do (errs, mod_graph) <- depanalE [] False -- #17459 success <- load' how_much (Just batchMsg) mod_graph warnUnusedPackages - if isEmptyBag errs + if isEmptyMessages errs then pure success - else throwErrors errs + else throwErrors (fmap GhcDriverMessage errs) -- Note [Unused packages] -- @@ -384,15 +386,17 @@ warnUnusedPackages = do = filter (\arg -> not $ any (matching state arg) loadedPackages) requestedArgs - let warn = - mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg + let warn = singleMessage $ + mkPlainMsgEnvelope dflags noSrcSpan $ + GhcDriverMessage $ DriverUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedPackages) msg msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] when (not (null unusedArgs)) $ - logWarnings (listToBag [warn]) + logDiagnostics warn where packageArg (ExposePackage _ arg _) = Just arg @@ -1419,7 +1423,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags hsc_env <- readMVar hsc_env_var old_hpt <- readIORef old_hpt_var - let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err) + let logg err = printMessages lcl_logger lcl_dflags (srcErrorMessages err) -- Limit the number of parallel compiles. let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem) @@ -1671,7 +1675,7 @@ upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do case mHscMessage of Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid) Nothing -> return () - runHsc hsc_env $ ioMsgMaybe $ tcRnCheckUnit hsc_env $ VirtUnit iuid + runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid pure () -- | Compile a single module. Always produce a Linkable for it if @@ -2214,17 +2218,18 @@ warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () warnUnnecessarySourceImports sccs = do dflags <- getDynFlags when (wopt Opt_WarnUnusedImports dflags) - (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) + (logDiagnostics (mkMessages $ listToBag (concatMap (check dflags . flattenSCC) sccs))) where check dflags ms = let mods_in_this_cycle = map ms_mod_name ms in [ warn dflags i | m <- ms, i <- ms_home_srcimps m, unLoc i `notElem` mods_in_this_cycle ] - warn :: DynFlags -> Located ModuleName -> WarnMsg + warn :: DynFlags -> Located ModuleName -> MsgEnvelope GhcMessage warn dflags (L loc mod) = - mkPlainMsgEnvelope dflags WarningWithoutFlag loc - (text "{-# SOURCE #-} unnecessary in import of " - <+> quotes (ppr mod)) + mkPlainMsgEnvelope dflags loc $ + GhcDriverMessage $ DriverUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag $ + text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod) ----------------------------------------------------------------------------- @@ -2250,7 +2255,7 @@ downsweep :: HscEnv -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M - -> IO [Either ErrorMessages ExtendedModSummary] + -> IO [Either DriverMessages ExtendedModSummary] -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats @@ -2286,7 +2291,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots old_summary_map :: ModNodeMap ExtendedModSummary old_summary_map = mkNodeMap old_summaries - getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary) + getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary) getRootSummary Target { targetId = TargetFile file mb_phase , targetAllowObjCode = obj_allowed , targetContents = maybe_buf @@ -2295,8 +2300,10 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else return $ Left $ unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $ - text "can't find file:" <+> text file + else return $ Left $ singleMessage $ + mkPlainErrorMsgEnvelope noSrcSpan $ + DriverUnknownMessage $ mkPlainError $ + text "can't find file:" <+> text file getRootSummary Target { targetId = TargetModule modl , targetAllowObjCode = obj_allowed , targetContents = maybe_buf @@ -2316,7 +2323,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- ignored, leading to confusing behaviour). checkDuplicates :: ModNodeMap - [Either ErrorMessages + [Either DriverMessages ExtendedModSummary] -> IO () checkDuplicates root_map @@ -2329,11 +2336,11 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots loop :: [GenWithIsBoot (Located ModuleName)] -- Work list: process these modules - -> ModNodeMap [Either ErrorMessages ExtendedModSummary] + -> ModNodeMap [Either DriverMessages ExtendedModSummary] -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) + -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) -- The result is the completed NodeMap loop [] done = return done loop (s : ss) done @@ -2373,8 +2380,8 @@ enableCodeGenForTH -> TmpFs -> HomeUnit -> Backend - -> ModNodeMap [Either ErrorMessages ExtendedModSummary] - -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) + -> ModNodeMap [Either DriverMessages ExtendedModSummary] + -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) enableCodeGenForTH logger tmpfs home_unit = enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession where @@ -2399,8 +2406,8 @@ enableCodeGenWhen -> TempFileLifetime -> TempFileLifetime -> Backend - -> ModNodeMap [Either ErrorMessages ExtendedModSummary] - -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) + -> ModNodeMap [Either DriverMessages ExtendedModSummary] + -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where @@ -2469,7 +2476,7 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd mkRootMap :: [ExtendedModSummary] - -> ModNodeMap [Either ErrorMessages ExtendedModSummary] + -> ModNodeMap [Either DriverMessages ExtendedModSummary] mkRootMap summaries = ModNodeMap $ Map.insertListWith (flip (++)) [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ] @@ -2514,7 +2521,7 @@ summariseFile -> Maybe Phase -- start phase -> Bool -- object code allowed? -> Maybe (StringBuffer,UTCTime) - -> IO (Either ErrorMessages ExtendedModSummary) + -> IO (Either DriverMessages ExtendedModSummary) summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the @@ -2642,7 +2649,7 @@ summariseModule -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude - -> IO (Maybe (Either ErrorMessages ExtendedModSummary)) -- Its new summary + -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) obj_allowed maybe_buf excl_mods @@ -2730,7 +2737,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ + throwE $ singleMessage $ + mkPlainErrorMsgEnvelope pi_mod_name_loc $ + DriverUnknownMessage $ mkPlainError $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -2742,7 +2751,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : homeUnitInstantiations home_unit) ]) - in throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ + in throwE $ singleMessage $ + mkPlainErrorMsgEnvelope pi_mod_name_loc $ + DriverUnknownMessage $ mkPlainError $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags then parens (text "Try adding" <+> quotes (ppr pi_mod_name) @@ -2845,7 +2856,7 @@ getPreprocessedImports -> Maybe Phase -> Maybe (StringBuffer, UTCTime) -- ^ optional source code buffer and modification time - -> ExceptT ErrorMessages IO PreprocessedImports + -> ExceptT DriverMessages IO PreprocessedImports getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do (pi_local_dflags, pi_hspp_fn) <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase @@ -2855,7 +2866,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags popts = initParserOpts pi_local_dflags mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn - return (first (fmap mkParserErr) mimps) + return (first (mkMessages . fmap mkDriverPsHeaderMessage) mimps) return PreprocessedImports {..} @@ -2899,24 +2910,30 @@ withDeferredDiagnostics f = do (\_ -> popLogHookM >> printDeferredDiagnostics) (\_ -> f) -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DiagnosticMessage +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrorMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err + = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + cannotFindModule hsc_env wanted_mod err -noHsFileErr :: SrcSpan -> String -> ErrorMessages +noHsFileErr :: SrcSpan -> String -> DriverMessages noHsFileErr loc path - = unitBag $ mkPlainErrorMsgEnvelope loc $ text "Can't find" <+> text path + = singleMessage $ mkPlainErrorMsgEnvelope loc $ + DriverUnknownMessage $ mkPlainError $ + text "Can't find" <+> text path -moduleNotFoundErr :: ModuleName -> ErrorMessages +moduleNotFoundErr :: ModuleName -> DriverMessages moduleNotFoundErr mod - = unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $ + = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan $ + DriverUnknownMessage $ mkPlainError $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ + = throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index ea1bf1f501..6acc547202 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -23,6 +23,7 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Driver.Env +import GHC.Driver.Errors.Types import qualified GHC.SysTools as SysTools import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Utils.Outputable @@ -305,7 +306,9 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do -> return Nothing fail -> - throwOneError $ mkPlainErrorMsgEnvelope srcloc $ + throwOneError $ + mkPlainErrorMsgEnvelope srcloc $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ cannotFindModule hsc_env imp fail ----------------------------- @@ -454,4 +457,3 @@ pprCycle summaries = pp_group (CyclicSCC summaries) depStartMarker, depEndMarker :: String depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" - diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 1a42d8402f..2fa3c51cc1 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -27,8 +27,8 @@ module GHC.Driver.Monad ( putMsgM, withTimingM, - -- ** Warnings - logWarnings, printException, + -- ** Diagnostics + logDiagnostics, printException, WarnErrLogger, defaultWarnErrLogger ) where @@ -36,7 +36,8 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Env -import GHC.Driver.Errors ( printOrThrowDiagnostics, printBagOfErrors ) +import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages ) +import GHC.Driver.Errors.Types import GHC.Utils.Monad import GHC.Utils.Exception @@ -141,10 +142,10 @@ withTimingM doc force action = do withTiming logger dflags doc force action -- ----------------------------------------------------------------------------- --- | A monad that allows logging of warnings. +-- | A monad that allows logging of diagnostics. -logWarnings :: GhcMonad m => WarningMessages -> m () -logWarnings warns = do +logDiagnostics :: GhcMonad m => Messages GhcMessage -> m () +logDiagnostics warns = do dflags <- getSessionDynFlags logger <- getLogger liftIO $ printOrThrowDiagnostics logger dflags warns @@ -240,13 +241,13 @@ instance ExceptionMonad m => GhcMonad (GhcT m) where setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' --- | Print the error message and all warnings. Useful inside exception --- handlers. Clears warnings after printing. +-- | Print the all diagnostics in a 'SourceError'. Useful inside exception +-- handlers. printException :: GhcMonad m => SourceError -> m () printException err = do dflags <- getSessionDynFlags logger <- getLogger - liftIO $ printBagOfErrors logger dflags (srcErrorMessages err) + liftIO $ printMessages logger dflags (srcErrorMessages err) -- | A function called to log warnings and errors. type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () @@ -254,4 +255,3 @@ type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () defaultWarnErrLogger :: WarnErrLogger defaultWarnErrLogger Nothing = return () defaultWarnErrLogger (Just e) = printException e - diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 8589b81ee5..5496fe31a2 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -47,6 +47,7 @@ import GHC.Tc.Types import GHC.Driver.Main import GHC.Driver.Env hiding ( Hsc ) import GHC.Driver.Errors +import GHC.Driver.Errors.Types import GHC.Driver.Pipeline.Monad import GHC.Driver.Config import GHC.Driver.Phases @@ -81,7 +82,6 @@ import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt import GHC.Settings -import GHC.Data.Bag ( unitBag ) import GHC.Data.FastString ( mkFastString ) import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) import GHC.Data.Maybe ( expectJust ) @@ -89,6 +89,7 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Iface.Make ( mkFullIface ) import GHC.Types.Basic ( SuccessFlag(..) ) +import GHC.Types.Error ( singleMessage, getMessages ) import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -130,9 +131,9 @@ preprocess :: HscEnv -> Maybe InputFileBuffer -- ^ optional buffer to use instead of reading the input file -> Maybe Phase -- ^ starting phase - -> IO (Either ErrorMessages (DynFlags, FilePath)) + -> IO (Either DriverMessages (DynFlags, FilePath)) preprocess hsc_env input_fn mb_input_buf mb_phase = - handleSourceError (\err -> return (Left (srcErrorMessages err))) $ + handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $ MC.handle handler $ fmap Right $ do MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) @@ -148,10 +149,21 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = return (dflags, fp) where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 - handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainErrorMsgEnvelope srcspan $ text msg + handler (ProgramError msg) = + return $ Left $ singleMessage $ + mkPlainErrorMsgEnvelope srcspan $ + DriverUnknownMessage $ mkPlainError $ text msg handler ex = throwGhcExceptionIO ex + to_driver_messages :: Messages GhcMessage -> Messages DriverMessage + to_driver_messages msgs = case traverse to_driver_message msgs of + Nothing -> pprPanic "non-driver message in preprocess" + (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs)) + Just msgs' -> msgs' + + to_driver_message (GhcDriverMessage msg) = Just msg + to_driver_message _other = Nothing + -- --------------------------------------------------------------------------- -- | Compile @@ -1259,7 +1271,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn popts = initParserOpts dflags eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of - Left errs -> throwErrors (fmap mkParserErr errs) + Left errs -> throwErrors (foldPsMessages mkParserErr errs) Right (src_imps,imps,L _ mod_name) -> return (Just buf, mod_name, imps, src_imps) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index a4bbc290e2..a5f638ab12 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -29,6 +29,7 @@ import GHC.Hs import GHC.HsToCore.Usage import GHC.HsToCore.Monad +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl @@ -59,6 +60,7 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) import GHC.Data.OrdList import GHC.Utils.Error @@ -82,7 +84,6 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.HpcInfo -import GHC.Types.Error import GHC.Unit import GHC.Unit.Module.ModGuts @@ -101,7 +102,7 @@ import GHC.Driver.Plugins ( LoadedPlugin(..) ) -} -- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DiagnosticMessage, Maybe ModGuts) +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env @@ -285,7 +286,7 @@ So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DiagnosticMessage, Maybe CoreExpr) +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env @@ -293,15 +294,27 @@ deSugarExpr hsc_env tc_expr = do showPass logger dflags "Desugar" -- Do desugaring - (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ - dsLExpr tc_expr + (tc_msgs, mb_result) <- runTcInteractive hsc_env $ + initDsTc $ + dsLExpr tc_expr + + MASSERT( isEmptyMessages tc_msgs ) -- the type-checker isn't doing anything here + + -- mb_result is Nothing only when a failure happens in the type-checker, + -- but mb_core_expr is Nothing when a failure happens in the desugarer + let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result case mb_core_expr of Nothing -> return () Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared" FormatCore (pprCoreExpr expr) - return (msgs, mb_core_expr) + -- callers (i.e. ioMsgMaybe) expect that no expression is returned if + -- there are errors + let final_res | errorsFound ds_msgs = Nothing + | otherwise = mb_core_expr + + return (ds_msgs, final_res) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs new file mode 100644 index 0000000000..f453a82743 --- /dev/null +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -0,0 +1,11 @@ + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage + +module GHC.HsToCore.Errors.Ppr where + +import GHC.Types.Error +import GHC.HsToCore.Errors.Types + +instance Diagnostic DsMessage where + diagnosticMessage (DsUnknownMessage m) = diagnosticMessage m + diagnosticReason (DsUnknownMessage m) = diagnosticReason m diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs new file mode 100644 index 0000000000..45a47d5c30 --- /dev/null +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -0,0 +1,10 @@ + +module GHC.HsToCore.Errors.Types where + +import GHC.Types.Error + +-- | Diagnostics messages emitted during desugaring. +data DsMessage = + DsUnknownMessage !DiagnosticMessage + -- ^ Simply rewraps a generic 'DiagnosticMessage'. More + -- constructors will be added in the future (#18516). diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 788f4828e2..9bc893f814 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -64,6 +64,7 @@ import GHC.Driver.Ppr import GHC.Hs import GHC.HsToCore.Types +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas) import GHC.Core.FamInstEnv @@ -204,17 +205,22 @@ type DsWarning = (SrcSpan, SDoc) -- into a Doc. -- | Run a 'DsM' action inside the 'TcM' monad. -initDsTc :: DsM a -> TcM a +initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a) initDsTc thing_inside = do { tcg_env <- getGblEnv - ; msg_var <- getErrsVar + ; msg_var <- liftIO $ newIORef emptyMessages ; hsc_env <- getTopEnv ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; setEnvs envs thing_inside + ; e_result <- tryM $ -- need to tryM so that we don't discard + -- DsMessages + setEnvs envs thing_inside + ; msgs <- liftIO $ readIORef msg_var + ; return (msgs, case e_result of Left _ -> Nothing + Right x -> Just x) } -- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a) initDs hsc_env tcg_env thing_inside = do { msg_var <- newIORef emptyMessages ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env @@ -223,7 +229,7 @@ initDs hsc_env tcg_env thing_inside -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef (Messages DiagnosticMessage) -> TcGblEnv + => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState @@ -242,7 +248,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env msg_var cc_st_var next_wrapper_num_var complete_matches } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl (tryM thing_inside) @@ -255,7 +261,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside } -- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a) initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds , mg_tcs = tycons, mg_fam_insts = fam_insts , mg_patsyns = patsyns, mg_rdr_env = rdr_env @@ -316,7 +322,7 @@ initTcDsForSolver thing_inside Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState + -> IORef (Messages DsMessage) -> IORef CostCentreState -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var @@ -466,7 +472,9 @@ diagnosticDs reason warn = do { env <- getGblEnv ; loc <- getSrcSpanDs ; dflags <- getDynFlags - ; let msg = mkShortMsgEnvelope dflags reason loc (ds_unqual env) warn + ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $ + DsUnknownMessage $ + mkPlainDiagnostic reason warn ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags @@ -479,7 +487,9 @@ errDs :: SDoc -> DsM () errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkShortErrorMsgEnvelope loc (ds_unqual env) err + ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $ + DsUnknownMessage $ + mkPlainError err ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index 58273e250e..bc9d7b4c1d 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -19,6 +19,7 @@ import GHC.Types.Name.Reader (GlobalRdrEnv) import GHC.Hs (LForeignDecl, HsExpr, GhcTc) import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) import GHC.HsToCore.Pmc.Types (Nablas) +import GHC.HsToCore.Errors.Types import GHC.Core (CoreExpr) import GHC.Core.FamInstEnv import GHC.Utils.Outputable as Outputable @@ -49,7 +50,7 @@ data DsGblEnv -- constructors are in scope during -- pattern-match satisfiability checking , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef (Messages DiagnosticMessage) -- Diagnostic messages + , ds_msgs :: IORef (Messages DsMessage) -- Diagnostic messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_complete_matches :: CompleteMatches diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index b52498129f..9c3417825b 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -44,6 +44,7 @@ import {-# SOURCE #-} GHC.IfaceToCore , tcIfaceAnnotations, tcIfaceCompleteMatches ) import GHC.Driver.Env +import GHC.Driver.Errors.Types import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Ppr @@ -707,7 +708,7 @@ computeInterface hsc_env doc_str hi_boot_file mod0 = do Succeeded (iface0, path) -> rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case Right x -> return (Succeeded (x, path)) - Left errs -> throwErrors errs + Left errs -> throwErrors (GhcTcRnMessage <$> errs) Failed err -> return (Failed err) (mod, _) -> find_iface mod @@ -1224,4 +1225,3 @@ pprExtensibleFields :: ExtensibleFields -> SDoc pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs where pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes" - diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index f4e8b449f5..500e12a1db 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -31,6 +31,7 @@ import GHC.Unit.State import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail @@ -47,18 +48,16 @@ import GHC.Utils.Error import GHC.Utils.Fingerprint import GHC.Utils.Panic -import GHC.Data.Bag - import qualified Data.Traversable as T import Data.IORef -tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a +tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a tcRnMsgMaybe do_this = do r <- liftIO $ do_this case r of - Left errs -> do - addMessages (mkMessages errs) + Left msgs -> do + addMessages msgs failM Right x -> return x @@ -77,7 +76,10 @@ failWithRn doc = do errs_var <- fmap sh_if_errs getGblEnv errs <- readTcRef errs_var -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainErrorMsgEnvelope noSrcSpan doc) + let msg = mkPlainErrorMsgEnvelope noSrcSpan $ + TcRnUnknownMessage $ + mkPlainError doc + writeTcRef errs_var (msg `addMessage` errs) failM -- | What we have is a generalized ModIface, which corresponds to @@ -101,7 +103,7 @@ failWithRn doc = do -- should be Foo.T; then we'll also rename this (this is used -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape - -> ModIface -> IO (Either ErrorMessages ModIface) + -> ModIface -> IO (Either (Messages TcRnMessage) ModIface) rnModIface hsc_env insts nsubst iface = initRnIface hsc_env iface insts nsubst $ do mod <- rnModule (mi_module iface) @@ -125,7 +127,7 @@ rnModIface hsc_env insts nsubst iface = -- | Rename just the exports of a 'ModIface'. Useful when we're doing -- shaping prior to signature merging. -rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo]) +rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either (Messages TcRnMessage) [AvailInfo]) rnModExports hsc_env insts iface = initRnIface hsc_env iface insts Nothing $ mapM rnAvailInfo (mi_exports iface) @@ -185,9 +187,9 @@ rnDepModules sel deps = do -- | Run a computation in the 'ShIfM' monad. initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape - -> ShIfM a -> IO (Either ErrorMessages a) + -> ShIfM a -> IO (Either (Messages TcRnMessage) a) initRnIface hsc_env iface insts nsubst do_this = do - errs_var <- newIORef emptyBag + errs_var <- newIORef emptyMessages let hsubst = listToUFM insts rn_mod = renameHoleModule (hsc_units hsc_env) hsubst env = ShIfEnv { @@ -201,9 +203,9 @@ initRnIface hsc_env iface insts nsubst do_this = do res <- initTcRnIf 'c' hsc_env env () $ tryM do_this msgs <- readIORef errs_var case res of - Left _ -> return (Left msgs) - Right r | not (isEmptyBag msgs) -> return (Left msgs) - | otherwise -> return (Right r) + Left _ -> return (Left msgs) + Right r | not (isEmptyMessages msgs) -> return (Left msgs) + | otherwise -> return (Right r) -- | Environment for 'ShIfM' monads. data ShIfEnv = ShIfEnv { @@ -221,8 +223,8 @@ data ShIfEnv = ShIfEnv { -- we just load the target interface and look at the export -- list to determine the renaming. sh_if_shape :: Maybe NameShape, - -- Mutable reference to keep track of errors (similar to 'tcl_errs') - sh_if_errs :: IORef ErrorMessages + -- Mutable reference to keep track of diagnostics (similar to 'tcl_errs') + sh_if_errs :: IORef (Messages TcRnMessage) } getHoleSubst :: ShIfM ShHoleSubst diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index e48f04aae5..570385c773 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -9,7 +9,7 @@ module GHC.Parser.Errors , LexErr(..) , CmmParserError(..) , LexErrKind(..) - , Hint(..) + , PsHint(..) , StarIsType (..) ) where @@ -82,8 +82,8 @@ data TransLayoutReason data PsError = PsError { errDesc :: !PsErrorDesc -- ^ Error description - , errHints :: ![Hint] -- ^ Hints - , errLoc :: !SrcSpan -- ^ Error position + , errHints :: ![PsHint] -- ^ Hints + , errLoc :: !SrcSpan -- ^ Error position } data PsErrorDesc @@ -396,7 +396,7 @@ data NumUnderscoreReason | NumUnderscore_Float deriving (Show,Eq,Ord) -data Hint +data PsHint = SuggestTH | SuggestRecursiveDo | SuggestDo diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 0e83949a2e..3b73e068b4 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -2,15 +2,19 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage + module GHC.Parser.Errors.Ppr ( mkParserWarn , mkParserErr + , pprPsError ) where import GHC.Prelude import GHC.Driver.Flags import GHC.Parser.Errors +import GHC.Parser.Errors.Types import GHC.Parser.Types import GHC.Types.Basic import GHC.Types.Error @@ -27,26 +31,30 @@ import GHC.Builtin.Types (filterCTuple) import GHC.Driver.Session (DynFlags) import GHC.Utils.Error (diagReasonSeverity) -mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage +instance Diagnostic PsMessage where + diagnosticMessage (PsUnknownMessage m) = diagnosticMessage m + diagnosticReason (PsUnknownMessage m) = diagnosticReason m + +mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope PsMessage mk_parser_err span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag + , errMsgDiagnostic = PsUnknownMessage $ DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag , errMsgSeverity = SevError } -mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage +mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope PsMessage mk_parser_warn df flag span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) reason + , errMsgDiagnostic = PsUnknownMessage $ DiagnosticMessage (mkDecorated [doc]) reason , errMsgSeverity = diagReasonSeverity df reason } where reason :: DiagnosticReason reason = WarningWithFlag flag -mkParserWarn :: DynFlags -> PsWarning -> MsgEnvelope DiagnosticMessage +mkParserWarn :: DynFlags -> PsWarning -> MsgEnvelope PsMessage mkParserWarn df = \case PsWarnTab loc tc -> mk_parser_warn df Opt_WarnTabs loc $ @@ -132,9 +140,13 @@ mkParserWarn df = \case OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -mkParserErr :: PsError -> MsgEnvelope DiagnosticMessage -mkParserErr err = mk_parser_err (errLoc err) $ vcat - (pp_err (errDesc err) : map pp_hint (errHints err)) +mkParserErr :: PsError -> MsgEnvelope PsMessage +mkParserErr err = mk_parser_err (errLoc err) $ + pprPsError (errDesc err) (errHints err) + +-- | Render a 'PsErrorDesc' into an 'SDoc', with its 'PsHint's. +pprPsError :: PsErrorDesc -> [PsHint] -> SDoc +pprPsError desc hints = vcat (pp_err desc : map pp_hint hints) pp_err :: PsErrorDesc -> SDoc pp_err = \case @@ -602,7 +614,7 @@ pp_unexpected_fun_app e a = $$ text "You could write it with parentheses" $$ text "Or perhaps you meant to enable BlockArguments?" -pp_hint :: Hint -> SDoc +pp_hint :: PsHint -> SDoc pp_hint = \case SuggestTH -> text "Perhaps you intended to use TemplateHaskell" SuggestDo -> text "Perhaps this statement should be within a 'do' block?" diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs new file mode 100644 index 0000000000..293dcc3ee0 --- /dev/null +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -0,0 +1,9 @@ + +module GHC.Parser.Errors.Types where + +import GHC.Types.Error + +data PsMessage + = PsUnknownMessage !DiagnosticMessage + -- ^ Simply rewraps a generic 'DiagnosticMessage'. More + -- constructors will be added in the future (#18516). diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 84cbb5e0d4..02503924ee 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -16,7 +16,7 @@ module GHC.Parser.Header , mkPrelImports -- used by the renamer too , getOptionsFromFile , getOptions - , optionsErrorMsgs + , toArgs , checkProcessArgsResult ) where @@ -29,7 +29,9 @@ import GHC.Platform import GHC.Driver.Session import GHC.Driver.Config +import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! +import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr import GHC.Parser.Errors import GHC.Parser ( parseHeader ) @@ -39,7 +41,7 @@ import GHC.Hs import GHC.Unit.Module import GHC.Builtin.Names -import GHC.Types.Error hiding ( getMessages, getErrorMessages, getWarningMessages ) +import GHC.Types.Error hiding ( getErrorMessages, getWarningMessages, getMessages ) import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.SourceText @@ -53,13 +55,17 @@ import GHC.Utils.Exception as Exception import GHC.Data.StringBuffer import GHC.Data.Maybe -import GHC.Data.Bag ( Bag, listToBag, unitBag, isEmptyBag ) +import GHC.Data.Bag (Bag, isEmptyBag ) import GHC.Data.FastString import Control.Monad import System.IO import System.IO.Unsafe import Data.List (partition) +import Data.Char (isSpace) +import Text.ParserCombinators.ReadP (readP_to_S, gather) +import Text.ParserCombinators.ReadPrec (readPrec_to_P) +import Text.Read (readPrec) ------------------------------------------------------------------------------ @@ -91,7 +97,7 @@ getImports popts implicit_prelude buf filename source_filename = do -- don't log warnings: they'll be reported when we parse the file -- for real. See #2500. if not (isEmptyBag errs) - then throwIO $ mkSrcErr (fmap mkParserErr errs) + then throwErrors $ foldPsMessages mkParserErr errs else let hsmod = unLoc rdr_module mb_mod = hsmodName hsmod @@ -260,10 +266,14 @@ getOptions' dflags toks parseToks (open:close:xs) | IToptions_prag str <- unLoc open , ITclose_prag <- unLoc close - = case toArgs str of + = case toArgs starting_loc str of Left _err -> optionsParseError str $ -- #15053 combineSrcSpans (getLoc open) (getLoc close) - Right args -> map (L (getLoc open)) args ++ parseToks xs + Right args -> args ++ parseToks xs + where + src_span = getLoc open + real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span) + starting_loc = realSrcSpanStart real_src_span parseToks (open:close:xs) | ITinclude_prag str <- unLoc open , ITclose_prag <- unLoc close @@ -304,6 +314,107 @@ getOptions' dflags toks (ITdocSection {}) -> True _ -> False +toArgs :: RealSrcLoc + -> String -> Either String -- Error + [Located String] -- Args +toArgs starting_loc orig_str + = let (after_spaces_loc, after_spaces_str) = consume_spaces starting_loc orig_str in + case after_spaces_str of + '[':after_bracket -> + let after_bracket_loc = advanceSrcLoc after_spaces_loc '[' + (after_bracket_spaces_loc, after_bracket_spaces_str) + = consume_spaces after_bracket_loc after_bracket in + case after_bracket_spaces_str of + ']':rest | all isSpace rest -> Right [] + _ -> readAsList after_bracket_spaces_loc after_bracket_spaces_str + + _ -> toArgs' after_spaces_loc after_spaces_str + where + consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String) + consume_spaces loc [] = (loc, []) + consume_spaces loc (c:cs) + | isSpace c = consume_spaces (advanceSrcLoc loc c) cs + | otherwise = (loc, c:cs) + + break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String + -> (String, RealSrcLoc, String) -- location is start of second string + break_with_loc p = go [] + where + go reversed_acc loc [] = (reverse reversed_acc, loc, []) + go reversed_acc loc (c:cs) + | p c = (reverse reversed_acc, loc, c:cs) + | otherwise = go (c:reversed_acc) (advanceSrcLoc loc c) cs + + advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc + advance_src_loc_many = foldl' advanceSrcLoc + + locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a + locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Nothing) x + + toArgs' :: RealSrcLoc -> String -> Either String [Located String] + -- Remove outer quotes: + -- > toArgs' "\"foo\" \"bar baz\"" + -- Right ["foo", "bar baz"] + -- + -- Keep inner quotes: + -- > toArgs' "-DFOO=\"bar baz\"" + -- Right ["-DFOO=\"bar baz\""] + toArgs' loc s = + let (after_spaces_loc, after_spaces_str) = consume_spaces loc s in + case after_spaces_str of + [] -> Right [] + '"' : _ -> do + -- readAsString removes outer quotes + (arg, new_loc, rest) <- readAsString after_spaces_loc after_spaces_str + check_for_space rest + (locate after_spaces_loc new_loc arg:) + `fmap` toArgs' new_loc rest + _ -> case break_with_loc (isSpace <||> (== '"')) after_spaces_loc after_spaces_str of + (argPart1, loc2, s''@('"':_)) -> do + (argPart2, loc3, rest) <- readAsString loc2 s'' + check_for_space rest + -- show argPart2 to keep inner quotes + (locate after_spaces_loc loc3 (argPart1 ++ show argPart2):) + `fmap` toArgs' loc3 rest + (arg, loc2, s'') -> (locate after_spaces_loc loc2 arg:) + `fmap` toArgs' loc2 s'' + + check_for_space :: String -> Either String () + check_for_space [] = Right () + check_for_space (c:_) + | isSpace c = Right () + | otherwise = Left ("Whitespace expected after string in " ++ show orig_str) + + reads_with_consumed :: Read a => String + -> [((String, a), String)] + -- ((consumed string, parsed result), remainder of input) + reads_with_consumed = readP_to_S (gather (readPrec_to_P readPrec 0)) + + readAsString :: RealSrcLoc + -> String + -> Either String (String, RealSrcLoc, String) + readAsString loc s = case reads_with_consumed s of + [((consumed, arg), rest)] -> + Right (arg, advance_src_loc_many loc consumed, rest) + _ -> + Left ("Couldn't read " ++ show s ++ " as String") + + -- input has had the '[' stripped off + readAsList :: RealSrcLoc -> String -> Either String [Located String] + readAsList loc s = do + let (after_spaces_loc, after_spaces_str) = consume_spaces loc s + (arg, after_arg_loc, after_arg_str) <- readAsString after_spaces_loc after_spaces_str + let (after_arg_spaces_loc, after_arg_spaces_str) + = consume_spaces after_arg_loc after_arg_str + (locate after_spaces_loc after_arg_loc arg :) <$> + case after_arg_spaces_str of + ',':after_comma -> readAsList (advanceSrcLoc after_arg_spaces_loc ',') after_comma + ']':after_bracket + | all isSpace after_bracket + -> Right [] + _ -> Left ("Couldn't read " ++ show ('[' : s) ++ " as [String]") + -- reinsert missing '[' for clarity. + ----------------------------------------------------------------------------- -- | Complain about non-dynamic flags in OPTIONS pragmas. @@ -313,11 +424,12 @@ getOptions' dflags toks checkProcessArgsResult :: MonadIO m => [Located String] -> m () checkProcessArgsResult flags = when (notNull flags) $ - liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags + liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags where mkMsg (L loc flag) = mkPlainErrorMsgEnvelope loc $ - (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> - text flag) + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> + text flag ----------------------------------------------------------------------------- @@ -349,19 +461,6 @@ unsupportedExtnError dflags loc unsup = supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags suggestions = fuzzyMatch unsup supported - -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DiagnosticMessage -optionsErrorMsgs unhandled_flags flags_lines _filename - = mkMessages $ listToBag (map mkMsg unhandled_flags_lines) - where unhandled_flags_lines :: [Located String] - unhandled_flags_lines = [ L l f - | f <- unhandled_flags - , L l f' <- flags_lines - , f == f' ] - mkMsg (L flagSpan flag) = - mkPlainErrorMsgEnvelope flagSpan $ - text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag - optionsParseError :: String -> SrcSpan -> a -- #15053 optionsParseError str loc = throwErr loc $ @@ -372,4 +471,5 @@ optionsParseError str loc = throwErr :: SrcSpan -> SDoc -> a -- #15053 throwErr loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainErrorMsgEnvelope loc doc + let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage $ PsUnknownMessage $ mkPlainError doc + in throw $ mkSrcErr $ singleMessage msg diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 6411df34d9..0ffc3125e6 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1078,7 +1078,7 @@ checkImportDecl mPre mPost = do checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_hints :: [PsHint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat) checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) @@ -2721,7 +2721,7 @@ failOpFewArgs (L loc op) = data PV_Context = PV_Context { pv_options :: ParserOpts - , pv_hints :: [Hint] -- See Note [Parser-Validator Hint] + , pv_hints :: [PsHint] -- See Note [Parser-Validator Hint] } data PV_Accum = @@ -2771,7 +2771,7 @@ instance Monad PV where runPV :: PV a -> P a runPV = runPV_hints [] -runPV_hints :: [Hint] -> PV a -> P a +runPV_hints :: [PsHint] -> PV a -> P a runPV_hints hints m = P $ \s -> let @@ -2792,7 +2792,7 @@ runPV_hints hints m = PV_Ok acc' a -> POk (mkPState acc') a PV_Failed acc' -> PFailed (mkPState acc') -add_hint :: Hint -> PV a -> PV a +add_hint :: PsHint -> PV a -> PV a add_hint hint m = let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in PV (\ctx acc -> unPV m (modifyHint ctx) acc) diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index d8c8c781da..80868c1eea 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -50,6 +50,7 @@ import GHC.Prelude import GHC.Driver.Monad import GHC.Driver.Main +import GHC.Driver.Errors.Types ( hoistTcRnMessage ) import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr @@ -1032,7 +1033,7 @@ typeKind normalise str = withSession $ \hsc_env -> getInstancesForType :: GhcMonad m => Type -> m [ClsInst] getInstancesForType ty = withSession $ \hsc_env -> liftIO $ runInteractiveHsc hsc_env $ - ioMsgMaybe $ runTcInteractive hsc_env $ do + ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env $ do -- Bring class and instances from unqualified modules into scope, this fixes #16793. loadUnqualIfaces hsc_env (hsc_IC hsc_env) matches <- findMatchingInstances ty @@ -1045,7 +1046,7 @@ parseInstanceHead str = withSession $ \hsc_env0 -> do (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ty <- hscParseType str - ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty + ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty return ty diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 40761ed38c..c71ad4b7b8 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -2007,7 +2007,7 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism -- See Note [Deriving strategies] ; when (exotic_mechanism && className clas `elem` genericClassNames) $ do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } + ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } } where exotic_mechanism = not $ isDerivSpecStock mechanism diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 1f972c6425..9de37b0313 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1029,26 +1029,26 @@ mkErrorReport :: DiagnosticReason -> ReportErrCtxt -> TcLclEnv -> Report - -> TcM (MsgEnvelope DiagnosticMessage) + -> TcM (MsgEnvelope TcRnMessage) mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkDecoratedSDocAt rea - (RealSrcSpan (tcl_loc tcl_env) Nothing) - (vcat important) - context - (vcat $ relevant_bindings ++ valid_subs) + ; mkTcRnMessage rea + (RealSrcSpan (tcl_loc tcl_env) Nothing) + (vcat important) + context + (vcat $ relevant_bindings ++ valid_subs) } -- This version does not include the context mkErrorReportNC :: DiagnosticReason -> TcLclEnv -> Report - -> TcM (MsgEnvelope DiagnosticMessage) + -> TcM (MsgEnvelope TcRnMessage) mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs) - = mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc tcl_env) Nothing) - (vcat important) - O.empty - (vcat $ relevant_bindings ++ valid_subs) + = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Nothing) + (vcat important) + O.empty + (vcat $ relevant_bindings ++ valid_subs) type UserGiven = Implication @@ -1186,7 +1186,7 @@ See also 'reportUnsolved'. ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. -mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DiagnosticMessage) +mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) @@ -1310,7 +1310,6 @@ mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ When working with typed holes we have to deal with the case where we want holes to be reported as warnings to users during compile time but as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings' -with a function which is able to override the 'DiagnosticReason' of a 'DiagnosticMessage', so that the correct 'Severity' can be computed out of that later on. -} diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs new file mode 100644 index 0000000000..c6da9f1b9b --- /dev/null +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage + +module GHC.Tc.Errors.Ppr where + +import GHC.Tc.Errors.Types +import GHC.Types.Error + +instance Diagnostic TcRnMessage where + diagnosticMessage (TcRnUnknownMessage m) = diagnosticMessage m + diagnosticReason (TcRnUnknownMessage m) = diagnosticReason m diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs new file mode 100644 index 0000000000..1241735191 --- /dev/null +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -0,0 +1,12 @@ +module GHC.Tc.Errors.Types ( + -- * Main types + TcRnMessage(..) + ) where + +import GHC.Types.Error + +-- | An error which might arise during typechecking/renaming. +data TcRnMessage + = TcRnUnknownMessage !DiagnosticMessage + -- ^ Simply rewraps a generic 'DiagnosticMessage'. More + -- constructors will be added in the future (#18516). diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 57b99e703a..166f366038 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -475,7 +475,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- handle safe infer fail _ | check_safe && safeInferOn dflags - -> recordUnsafeInfer emptyBag + -> recordUnsafeInfer emptyMessages -- handle safe language typecheck fail _ | check_safe && safeLanguageOn dflags diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 589513af97..7124dcd52e 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -34,6 +34,7 @@ module GHC.Tc.Gen.Splice( import GHC.Prelude +import GHC.Driver.Errors import GHC.Driver.Plugins import GHC.Driver.Main import GHC.Driver.Session @@ -42,6 +43,7 @@ import GHC.Driver.Hooks import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Expr @@ -917,6 +919,48 @@ runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] -> TcM [LHsDecl GhcPs] runMetaD = runMeta metaRequestD +{- Note [Errors in desugaring a splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do if there are errors when desugaring a splice? We should +abort. There are several cases to consider: + +(a) The desugarer hits an unrecoverable error and fails in the monad. +(b) The desugarer hits a recoverable error, reports it, and continues. +(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues. +(d) The desugarer reports a non-fatal warning, and continues. + +Each case is tested in th/T19709[abcd]. + +General principle: we wish to report all messages from dealing with a splice +eagerly, as these messages arise during an earlier stage than type-checking +generally. It's also likely that a compile-time warning from spliced code +will be easier to understand then an error that arises from processing the +code the splice produces. (Rationale: the warning will be about the code the +user actually wrote, not what is generated.) + +Case (a): We have no choice but to abort here, but we must make sure that +the messages are printed or logged before aborting. Logging them is annoying, +because we're in the type-checker, and the messages are DsMessages, from the +desugarer. So we report and then fail in the monad. This case is detected +by the fact that initDsTc returns Nothing. + +Case (b): We detect this case by looking for errors in the messages returned +from initDsTc and aborting if we spot any (after printing, of course). Note +that initDsTc will return a Just ds_expr in this case, but we don't wish to +use the (likely very bogus) expression. + +Case (c): This is functionally the same as (b), except that the expression +isn't bogus. We still don't wish to use it, as the user's request for -Werror +tells us not to. + +Case (d): We report the warnings and then carry on with the expression. +This might result in warnings printed out of source order, but this is +appropriate, as the warnings from the splice arise from an earlier stage +of compilation. + +Previously, we failed to abort in cases (b) and (c), leading to #19709. +-} + --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -> (hs_syn -> SDoc) -- how to print the code @@ -932,11 +976,11 @@ runMeta' show_code ppr_hs run_and_convert expr -- Check that we've had no errors of any sort so far. -- For example, if we found an error in an earlier defn f, but -- recovered giving it type f :: forall a.a, it'd be very dodgy - -- to carry ont. Mind you, the staging restrictions mean we won't + -- to carry on. Mind you, the staging restrictions mean we won't -- actually run f, but it still seems wrong. And, more concretely, -- see #5358 for an example that fell over when trying to -- reify a function with a "?" kind in it. (These don't occur - -- in type-correct programs. + -- in type-correct programs.) ; failIfErrsM -- run plugins @@ -944,7 +988,23 @@ runMeta' show_code ppr_hs run_and_convert expr ; expr' <- withPlugins hsc_env spliceRunAction expr -- Desugar - ; ds_expr <- initDsTc (dsLExpr expr') + ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr') + + -- Print any messages (even warnings) eagerly: they might be helpful if anything + -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all + -- cases. + ; logger <- getLogger + ; dflags <- getDynFlags + ; liftIO $ printMessages logger dflags ds_msgs + + ; ds_expr <- case mb_ds_expr of + Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice] + Just ds_expr -> -- There still might be a fatal warning or recoverable + -- Cases (b) and (c) from Note [Errors in desugaring a splice] + do { when (errorsOrFatalWarningsFound ds_msgs) + failM + ; return ds_expr } + -- Compile and link it; might fail if linking fails ; src_span <- getSrcSpanM ; traceTc "About to run (desugared)" (ppr ds_expr) @@ -1442,7 +1502,7 @@ runTH ty fhv = do -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH :: IServInstance - -> [Messages DiagnosticMessage] -- saved from nested calls to qRecover + -> [Messages TcRnMessage] -- saved from nested calls to qRecover -> TcM () runRemoteTH iserv recovers = do THMsg msg <- liftIO $ readIServ iserv getTHMessage diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 777086343b..0511e1e268 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -54,6 +54,7 @@ import GHC.Driver.Plugins import GHC.Driver.Session import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType ) @@ -191,7 +192,7 @@ tcRnModule :: HscEnv -> ModSummary -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages DiagnosticMessage, Maybe TcGblEnv) + -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} @@ -213,7 +214,8 @@ tcRnModule hsc_env mod_sum save_rn_syntax logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env err_msg = mkPlainErrorMsgEnvelope loc $ - text "Module does not have a RealSrcSpan:" <+> ppr this_mod + TcRnUnknownMessage $ mkPlainError $ + text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) pair@(this_mod,_) @@ -2010,7 +2012,7 @@ get two defns for 'main' in the interface file! ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DiagnosticMessage, Maybe a) +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside @@ -2126,7 +2128,7 @@ We don't bother with the tcl_th_bndrs environment either. -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages DiagnosticMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) + -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt = runTcInteractive hsc_env $ do { @@ -2507,7 +2509,7 @@ getGhciStepIO = do return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages DiagnosticMessage, Maybe Name) +isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) isGHCiMonad hsc_env ty = runTcInteractive hsc_env $ do rdrEnv <- getGlobalRdrEnv @@ -2534,7 +2536,7 @@ data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:typ tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs - -> IO (Messages DiagnosticMessage, Maybe Type) + -> IO (Messages TcRnMessage, Maybe Type) tcRnExpr hsc_env mode rdr_expr = runTcInteractive hsc_env $ do { @@ -2603,7 +2605,7 @@ has a special case for application chains. -------------------------- tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] - -> IO (Messages DiagnosticMessage, Maybe GlobalRdrEnv) + -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls. In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls @@ -2619,7 +2621,7 @@ tcRnType :: HscEnv -> ZonkFlexi -> Bool -- Normalise the returned type -> LHsType GhcPs - -> IO (Messages DiagnosticMessage, Maybe (Type, Kind)) + -> IO (Messages TcRnMessage, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] @@ -2753,7 +2755,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi. tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] - -> IO (Messages DiagnosticMessage, Maybe TcGblEnv) + -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ tcRnSrcDecls False Nothing local_decls @@ -2778,13 +2780,13 @@ externaliseAndTidyId this_mod id -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages DiagnosticMessage, Maybe ModIface) +getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> LocatedN RdrName - -> IO (Messages DiagnosticMessage, Maybe [Name]) + -> IO (Messages TcRnMessage, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ @@ -2798,7 +2800,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages DiagnosticMessage, Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) tcRnLookupName hsc_env name = runTcInteractive hsc_env $ tcRnLookupName' name @@ -2817,7 +2819,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO ( Messages DiagnosticMessage + -> IO ( Messages TcRnMessage , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -- Used to implement :info in GHCi @@ -3147,5 +3149,9 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ recordUnsafeInfer pluginUnsafe where unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainMsgEnvelope dflags WarningWithoutFlag noSrcSpan - (Outputable.text unsafeText) ) + pluginUnsafe = + singleMessage $ + mkPlainMsgEnvelope dflags noSrcSpan $ + TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag $ + Outputable.text unsafeText diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 5e79a75472..76ce179b9d 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -152,7 +152,7 @@ simplifyTop wanteds ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var ; TcM.writeTcRef errs_var saved_msg - ; recordUnsafeInfer whyUnsafe + ; recordUnsafeInfer (mkMessages whyUnsafe) } ; traceTc "reportUnsolved (unsafe overlapping) }" empty @@ -708,10 +708,10 @@ How is this implemented? It's complicated! So we'll step through it all: available and how they overlap. So we once again call `lookupInstEnv` to figure that out so we can generate a helpful error message. - 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an - IORef called `tcg_safeInfer`. + 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in + IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling + 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence failed. diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 40cdf54d12..8e9e1db1b7 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -81,7 +81,10 @@ module GHC.Tc.Types( lookupRoleAnnot, getRoleAnnots, -- Linting - lintGblEnv + lintGblEnv, + + -- Diagnostics + TcRnMessage ) where #include "HsVersions.h" @@ -100,6 +103,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin ) +import GHC.Tc.Errors.Types import GHC.Core.Type import GHC.Core.TyCon ( TyCon, tyConKind ) @@ -130,7 +134,6 @@ import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo -import GHC.Types.Error ( DiagnosticMessage ) import GHC.Data.IOEnv import GHC.Data.Bag @@ -560,11 +563,18 @@ data TcGblEnv -- function, if this module is -- the main module. - tcg_safeInfer :: TcRef (Bool, WarningMessages), - -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell) + tcg_safe_infer :: TcRef Bool, + -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)? -- See Note [Safe Haskell Overlapping Instances Implementation], -- although this is used for more than just that failure case. + tcg_safe_infer_reasons :: TcRef (Messages TcRnMessage), + -- ^ Unreported reasons why tcg_safe_infer is False. + -- INVARIANT: If this Messages is non-empty, then tcg_safe_infer is False. + -- It may be that tcg_safe_infer is False but this is empty, if no reasons + -- are supplied (#19714), or if those reasons have already been + -- reported by GHC.Driver.Main.markUnsafeInfer + tcg_tc_plugins :: [TcPluginSolver], -- ^ A list of user-defined plugins for the constraint solver. tcg_hf_plugins :: [HoleFitPlugin], @@ -769,7 +779,7 @@ data TcLclEnv -- Changes as we move inside an expression -- and for tidying types tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef (Messages DiagnosticMessage) -- Place to accumulate errors + tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics } setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index a1f802b254..a27c4de082 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -23,7 +23,6 @@ import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Types.Basic (TypeOrKind(..)) -import GHC.Types.Error ( DiagnosticMessage ) import GHC.Types.Fixity (defaultFixity) import GHC.Types.Fixity.Env import GHC.Types.TypeEnv @@ -372,7 +371,7 @@ checkUnit (VirtUnit indef) = do -- an @hsig@ file.) tcRnCheckUnit :: HscEnv -> Unit -> - IO (Messages DiagnosticMessage, Maybe ()) + IO (Messages TcRnMessage, Maybe ()) tcRnCheckUnit hsc_env uid = withTiming logger dflags (text "Check unit id" <+> ppr uid) @@ -393,7 +392,7 @@ tcRnCheckUnit hsc_env uid = -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages DiagnosticMessage, Maybe TcGblEnv) + -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = withTiming logger dflags (text "Signature merging" <+> brackets (ppr this_mod)) @@ -931,7 +930,7 @@ mergeSignatures -- an @hsig@ file.) tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> - IO (Messages DiagnosticMessage, Maybe TcGblEnv) + IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = withTiming logger dflags (text "Signature instantiation"<+>brackets (ppr this_mod)) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 5568e34b75..3243be77de 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -76,7 +76,7 @@ module GHC.Tc.Utils.Monad( tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportDiagnostic, reportDiagnostics, + mkLongErrAt, mkTcRnMessage, addLongErrAt, reportDiagnostic, reportDiagnostics, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, askNoErrs, discardErrs, tryTcDiscardingErrs, @@ -215,6 +215,7 @@ import qualified GHC.LanguageExtensions as LangExt import Data.IORef import Control.Monad +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv ) import qualified Data.Map as Map @@ -234,7 +235,7 @@ initTc :: HscEnv -> Module -> RealSrcSpan -> TcM r - -> IO (Messages DiagnosticMessage, Maybe r) + -> IO (Messages TcRnMessage, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -243,7 +244,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this used_gre_var <- newIORef [] ; th_var <- newIORef False ; th_splice_var<- newIORef False ; - infer_var <- newIORef (True, emptyBag) ; + infer_var <- newIORef True ; + infer_reasons_var <- newIORef emptyMessages ; dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { Just (_mod, te_var) -> return te_var ; @@ -341,7 +343,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_hpc = False, tcg_main = Nothing, tcg_self_boot = NoSelfBoot, - tcg_safeInfer = infer_var, + tcg_safe_infer = infer_var, + tcg_safe_infer_reasons = infer_reasons_var, tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], tcg_hf_plugins = [], @@ -362,7 +365,7 @@ initTcWithGbl :: HscEnv -> TcGblEnv -> RealSrcSpan -> TcM r - -> IO (Messages DiagnosticMessage, Maybe r) + -> IO (Messages TcRnMessage, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef emptyMessages @@ -408,7 +411,7 @@ initTcWithGbl hsc_env gbl_env loc do_this ; return (msgs, final_res) } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages DiagnosticMessage, Maybe a) +initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False @@ -968,10 +971,10 @@ wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a) -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages DiagnosticMessage)) +getErrsVar :: TcRn (TcRef (Messages TcRnMessage)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages DiagnosticMessage) -> TcRn a -> TcRn a +setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) addErr :: SDoc -> TcRn () @@ -1001,7 +1004,7 @@ checkErr :: Bool -> SDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages DiagnosticMessage -> TcRn () +addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar ; msgs0 <- readTcRef errs_var ; @@ -1030,40 +1033,42 @@ discardWarnings thing_inside ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage) +mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope TcRnMessage) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; - dflags <- getDynFlags ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongMsgEnvelope dflags ErrorWithoutFlag loc printer msg' extra } + return $ mkErrorMsgEnvelope loc printer + $ TcRnUnknownMessage + $ mkDecoratedError [msg', extra] } -mkDecoratedSDocAt :: DiagnosticReason - -> SrcSpan - -> SDoc +mkTcRnMessage :: DiagnosticReason + -> SrcSpan + -> SDoc -- ^ The important part of the message - -> SDoc + -> SDoc -- ^ The context of the message - -> SDoc + -> SDoc -- ^ Any supplementary information. - -> TcRn (MsgEnvelope DiagnosticMessage) -mkDecoratedSDocAt reason loc important context extra + -> TcRn (MsgEnvelope TcRnMessage) +mkTcRnMessage reason loc important context extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; dflags <- getDynFlags ; - let f = pprWithUnitState unit_state - errDoc = [important, context, extra] - errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason + let errDocs = map (pprWithUnitState unit_state) + [important, context, extra] in - return $ mkMsgEnvelope dflags loc printer errDoc' } + return $ mkMsgEnvelope dflags loc printer + $ TcRnUnknownMessage + $ mkDecoratedDiagnostic reason errDocs } addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic -reportDiagnostics :: [MsgEnvelope DiagnosticMessage] -> TcM () +reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () reportDiagnostics = mapM_ reportDiagnostic -reportDiagnostic :: MsgEnvelope DiagnosticMessage -> TcRn () +reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ; errs_var <- getErrsVar ; @@ -1241,7 +1246,7 @@ capture_constraints thing_inside ; lie <- readTcRef lie_var ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages DiagnosticMessage) +capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) -- capture_messages simply captures and returns the -- errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! @@ -1411,7 +1416,7 @@ foldAndRecoverM f acc (x:xs) = Just acc' -> foldAndRecoverM f acc' xs } ----------------------- -tryTc :: TcRn a -> TcRn (Maybe a, Messages DiagnosticMessage) +tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) -- Nothing, if m fails @@ -1561,9 +1566,9 @@ add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn () add_diagnostic_at reason loc msg extra_info = do { printer <- getPrintUnqualified ; dflags <- getDynFlags ; - let { dia = mkLongMsgEnvelope dflags reason - loc printer - msg extra_info } ; + let { dia = mkMsgEnvelope dflags loc printer $ + TcRnUnknownMessage $ + mkDecoratedDiagnostic reason [msg, extra_info] } ; reportDiagnostic dia } @@ -1982,14 +1987,15 @@ addModFinalizersWithLclEnv mod_finalizers -- | Mark that safe inference has failed -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case. -recordUnsafeInfer :: WarningMessages -> TcM () -recordUnsafeInfer warns = - getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) +recordUnsafeInfer :: Messages TcRnMessage -> TcM () +recordUnsafeInfer msgs = + getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False + writeTcRef (tcg_safe_infer_reasons env) msgs -- | Figure out the final correct safe haskell mode finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode finalSafeMode dflags tcg_env = do - safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) + safeInf <- readIORef (tcg_safe_infer tcg_env) return $ case safeHaskell dflags of Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred | otherwise -> Sf_None diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 91f1bcdbe7..a85158c122 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -68,7 +68,6 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Uniques ( mkAlphaTyVarUnique ) -import GHC.Data.Bag ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -1565,7 +1564,7 @@ check_special_inst_head dflags is_boot is_sig ctxt clas cls_args | clas_nm `elem` genericClassNames , hand_written_bindings = do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } + ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } | clas_nm == hasFieldClassName = checkHasFieldInst clas cls_args diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index e995ad8a4b..0ec3e8756c 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} module GHC.Types.Error ( -- * Messages Messages - , WarningMessages - , ErrorMessages , mkMessages , getMessages , emptyMessages , isEmptyMessages + , singleMessage , addMessage , unionMessages + , unionManyMessages , MsgEnvelope (..) - , WarnMsg -- * Classifying Messages @@ -23,23 +24,31 @@ module GHC.Types.Error , Diagnostic (..) , DiagnosticMessage (..) , DiagnosticReason (..) + , mkDiagnosticMessage + , mkPlainDiagnostic + , mkPlainError + , mkDecoratedDiagnostic + , mkDecoratedError -- * Rendering Messages , SDoc , DecoratedSDoc (unDecorated) + , mkDecorated, mkSimpleDecorated + , pprMessageBag - , mkDecorated , mkLocMessage , mkLocMessageAnn , getCaretDiagnostic -- * Queries , isIntrinsicErrorMessage + , isExtrinsicErrorMessage , isWarningMessage , getErrorMessages , getWarningMessages , partitionMessages , errorsFound + , errorsOrFatalWarningsFound ) where @@ -56,46 +65,62 @@ import GHC.Data.FastString (unpackFS) import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import GHC.Utils.Json +import Data.Bifunctor +import Data.Foldable ( fold ) + {- Note [Messages] ~~~~~~~~~~~~~~~ We represent the 'Messages' as a single bag of warnings and errors. -The reason behind that is that there is a fluid relationship between errors and warnings and we want to -be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors -or -XPartialTypeSignatures). More specifically, every diagnostic has a 'DiagnosticReason', but a warning -'DiagnosticReason' might be associated with 'SevError', in the case of -Werror. +The reason behind that is that there is a fluid relationship between errors +and warnings and we want to be able to promote or demote errors and warnings +based on certain flags (e.g. -Werror, -fdefer-type-errors or +-XPartialTypeSignatures). More specifically, every diagnostic has a +'DiagnosticReason', but a warning 'DiagnosticReason' might be associated with +'SevError', in the case of -Werror. We rely on the 'Severity' to distinguish between a warning and an error. -'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but -in future iterations these can be either parameterised over an 'e' message type (to make type signatures -a bit more declarative) or removed altogether. +'WarningMessages' and 'ErrorMessages' are for now simple type aliases to +retain backward compatibility, but in future iterations these can be either +parameterised over an 'e' message type (to make type signatures a bit more +declarative) or removed altogether. -} --- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically --- a warning or an error. See Note [Messages]. +-- | A collection of messages emitted by GHC during error reporting. A +-- diagnostic message is typically a warning or an error. See Note [Messages]. +-- +-- /INVARIANT/: All the messages in this collection must be relevant, i.e. +-- their 'Severity' should /not/ be 'SevIgnore'. The smart constructor +-- 'mkMessages' will filter out any message which 'Severity' is 'SevIgnore'. newtype Messages e = Messages { getMessages :: Bag (MsgEnvelope e) } - -instance Functor Messages where - fmap f (Messages xs) = Messages (mapBag (fmap f) xs) + deriving newtype (Semigroup, Monoid) + deriving stock (Functor, Foldable, Traversable) emptyMessages :: Messages e emptyMessages = Messages emptyBag mkMessages :: Bag (MsgEnvelope e) -> Messages e -mkMessages = Messages +mkMessages = Messages . filterBag interesting + where + interesting :: MsgEnvelope e -> Bool + interesting = (/=) SevIgnore . errMsgSeverity isEmptyMessages :: Messages e -> Bool isEmptyMessages (Messages msgs) = isEmptyBag msgs +singleMessage :: MsgEnvelope e -> Messages e +singleMessage e = addMessage e emptyMessages + {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is -just an optimisation, as GHC would /also/ suppress any diagnostic which severity is -'SevIgnore' before printing the message: See for example 'putLogMsg' and 'defaultLogAction'. +Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is just +an optimisation, as GHC would /also/ suppress any diagnostic which severity is +'SevIgnore' before printing the message: See for example 'putLogMsg' and +'defaultLogAction'. -} @@ -110,36 +135,38 @@ addMessage x (Messages xs) -- See Note [Discarding Messages]. unionMessages :: Messages e -> Messages e -> Messages e unionMessages (Messages msgs1) (Messages msgs2) = - Messages (filterBag interesting $ msgs1 `unionBags` msgs2) - where - interesting :: MsgEnvelope e -> Bool - interesting = (/=) SevIgnore . errMsgSeverity + Messages (msgs1 `unionBags` msgs2) -type WarningMessages = Bag (MsgEnvelope DiagnosticMessage) -type ErrorMessages = Bag (MsgEnvelope DiagnosticMessage) +-- | Joins many 'Messages's together +unionManyMessages :: Foldable f => f (Messages e) -> Messages e +unionManyMessages = fold -type WarnMsg = MsgEnvelope DiagnosticMessage - --- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]' --- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets --- between each elements of the list. --- The type of decoration depends on the formatting function used, but in practice GHC uses the --- 'formatBulleted'. +-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the +-- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its +-- final form, where the typical case would be adding bullets between each +-- elements of the list. The type of decoration depends on the formatting +-- function used, but in practice GHC uses the 'formatBulleted'. newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] } -- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'. mkDecorated :: [SDoc] -> DecoratedSDoc mkDecorated = Decorated +-- | Creates a new 'DecoratedSDoc' out of a single 'SDoc' +mkSimpleDecorated :: SDoc -> DecoratedSDoc +mkSimpleDecorated doc = Decorated [doc] + {- Note [Rendering Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~ -Turning 'Messages' into something that renders nicely for the user is one of the last steps, and it -happens typically at the application's boundaries (i.e. from the 'Driver' upwards). +Turning 'Messages' into something that renders nicely for the user is one of +the last steps, and it happens typically at the application's boundaries (i.e. +from the 'Driver' upwards). -For now (see #18516) this class has few instance, but the idea is that as -the more domain-specific types are defined, the more instances we would get. For example, given something like: +For now (see #18516) this class has few instance, but the idea is that as the +more domain-specific types are defined, the more instances we would get. For +example, given something like: data TcRnDiagnostic = TcRnOutOfScope .. @@ -147,36 +174,40 @@ the more domain-specific types are defined, the more instances we would get. For newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic) -We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather than scattering pieces of -'SDoc' around the codebase, we would write once for all: +We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather +than scattering pieces of 'SDoc' around the codebase, we would write once for +all: instance Diagnostic TcRnDiagnostic where diagnosticMessage (TcRnMessage msg) = case diagMessage msg of TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."] ... -This way, we can easily write generic rendering functions for errors that all they care about is the -knowledge that a given type 'e' has a 'Diagnostic' constraint. +This way, we can easily write generic rendering functions for errors that all +they care about is the knowledge that a given type 'e' has a 'Diagnostic' +constraint. -} -- | A class identifying a diagnostic. -- Dictionary.com defines a diagnostic as: -- --- \"a message output by a computer diagnosing an error in a computer program, computer system, --- or component device\". +-- \"a message output by a computer diagnosing an error in a computer program, +-- computer system, or component device\". -- --- A 'Diagnostic' carries the /actual/ description of the message (which, in GHC's case, it can be --- an error or a warning) and the /reason/ why such message was generated in the first place. --- See also Note [Rendering Messages]. +-- A 'Diagnostic' carries the /actual/ description of the message (which, in +-- GHC's case, it can be an error or a warning) and the /reason/ why such +-- message was generated in the first place. See also Note [Rendering +-- Messages]. class Diagnostic a where diagnosticMessage :: a -> DecoratedSDoc diagnosticReason :: a -> DiagnosticReason --- | A generic 'Diagnostic' message, without any further classification or provenance: --- By looking at a 'DiagnosticMessage' we don't know neither /where/ it was generated nor how to --- intepret its payload (as it's just a structured document). All we can do is to print it out and --- look at its 'DiagnosticReason'. +-- | A generic 'Diagnostic' message, without any further classification or +-- provenance: By looking at a 'DiagnosticMessage' we don't know neither +-- /where/ it was generated nor how to intepret its payload (as it's just a +-- structured document). All we can do is to print it out and look at its +-- 'DiagnosticReason'. data DiagnosticMessage = DiagnosticMessage { diagMessage :: !DecoratedSDoc , diagReason :: !DiagnosticReason @@ -186,13 +217,34 @@ instance Diagnostic DiagnosticMessage where diagnosticMessage = diagMessage diagnosticReason = diagReason --- | The reason /why/ a 'Diagnostic' was emitted in the first place. Diagnostic messages --- are born within GHC with a very precise reason, which can be completely statically-computed --- (i.e. this is an error or a warning no matter what), or influenced by the specific state --- of the 'DynFlags' at the moment of the creation of a new 'Diagnostic'. For example, a parsing --- error is /always/ going to be an error, whereas a 'WarningWithoutFlag Opt_WarnUnusedImports' might turn --- into an error due to '-Werror' or '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' --- together with its associated 'Severity' gives us the full picture. +-- | Create a 'DiagnosticMessage' with a 'DiagnosticReason' +mkDiagnosticMessage :: DecoratedSDoc -> DiagnosticReason -> DiagnosticMessage +mkDiagnosticMessage = DiagnosticMessage + +mkPlainDiagnostic :: DiagnosticReason -> SDoc -> DiagnosticMessage +mkPlainDiagnostic rea doc = DiagnosticMessage (mkSimpleDecorated doc) rea + +-- | Create an error 'DiagnosticMessage' holding just a single 'SDoc' +mkPlainError :: SDoc -> DiagnosticMessage +mkPlainError doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag + +-- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason' +mkDecoratedDiagnostic :: DiagnosticReason -> [SDoc] -> DiagnosticMessage +mkDecoratedDiagnostic rea docs = DiagnosticMessage (mkDecorated docs) rea + +-- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs +mkDecoratedError :: [SDoc] -> DiagnosticMessage +mkDecoratedError docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag + +-- | The reason /why/ a 'Diagnostic' was emitted in the first place. +-- Diagnostic messages are born within GHC with a very precise reason, which +-- can be completely statically-computed (i.e. this is an error or a warning +-- no matter what), or influenced by the specific state of the 'DynFlags' at +-- the moment of the creation of a new 'Diagnostic'. For example, a parsing +-- error is /always/ going to be an error, whereas a 'WarningWithoutFlag +-- Opt_WarnUnusedImports' might turn into an error due to '-Werror' or +-- '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' together +-- with its associated 'Severity' gives us the full picture. data DiagnosticReason = WarningWithoutFlag -- ^ Born as a warning. @@ -211,19 +263,22 @@ instance Outputable DiagnosticReason where -- | An envelope for GHC's facts about a running program, parameterised over the -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. -- --- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped --- into a 'MsgEnvelope' that carries specific information like where the error happened, etc. --- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user. +-- To say things differently, GHC emits /diagnostics/ about the running +-- program, each of which is wrapped into a 'MsgEnvelope' that carries +-- specific information like where the error happened, etc. Finally, multiple +-- 'MsgEnvelope's are aggregated into 'Messages' that are returned to the +-- user. data MsgEnvelope e = MsgEnvelope { errMsgSpan :: SrcSpan -- ^ The SrcSpan is used for sorting errors into line-number order , errMsgContext :: PrintUnqualified , errMsgDiagnostic :: e , errMsgSeverity :: Severity - } deriving Functor + } deriving (Functor, Foldable, Traversable) --- | The class for a diagnostic message. The main purpose is to classify a message within GHC, --- to distinguish it from a debug/dump message vs a proper diagnostic, for which we include a 'DiagnosticReason'. +-- | The class for a diagnostic message. The main purpose is to classify a +-- message within GHC, to distinguish it from a debug/dump message vs a proper +-- diagnostic, for which we include a 'DiagnosticReason'. data MessageClass = MCOutput | MCFatal @@ -238,33 +293,37 @@ data MessageClass -- No file\/line\/column stuff. | MCDiagnostic Severity DiagnosticReason - -- ^ Diagnostics from the compiler. This constructor - -- is very powerful as it allows the construction - -- of a 'MessageClass' with a completely arbitrary - -- permutation of 'Severity' and 'DiagnosticReason'. As such, - -- users are encouraged to use the 'mkMCDiagnostic' smart constructor instead. - -- Use this constructor directly only if you need to construct and manipulate diagnostic - -- messages directly, for example inside 'GHC.Utils.Error'. In all the other circumstances, - -- /especially/ when emitting compiler diagnostics, use the smart constructor. + -- ^ Diagnostics from the compiler. This constructor is very powerful as + -- it allows the construction of a 'MessageClass' with a completely + -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, + -- users are encouraged to use the 'mkMCDiagnostic' smart constructor + -- instead. Use this constructor directly only if you need to construct + -- and manipulate diagnostic messages directly, for example inside + -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when + -- emitting compiler diagnostics, use the smart constructor. deriving (Eq, Show) {- Note [Suppressing Messages] -The 'SevIgnore' constructor is used to generate messages for diagnostics which are -meant to be suppressed and not reported to the user: the classic example are warnings -for which the user didn't enable the corresponding 'WarningFlag', so GHC shouldn't print them. +The 'SevIgnore' constructor is used to generate messages for diagnostics which +are meant to be suppressed and not reported to the user: the classic example +are warnings for which the user didn't enable the corresponding 'WarningFlag', +so GHC shouldn't print them. -A different approach would be to extend the zoo of 'mkMsgEnvelope' functions to return -a 'Maybe (MsgEnvelope e)', so that we won't need to even create the message to begin with. -Both approaches have been evaluated, but we settled on the "SevIgnore one" for a number of reasons: +A different approach would be to extend the zoo of 'mkMsgEnvelope' functions +to return a 'Maybe (MsgEnvelope e)', so that we won't need to even create the +message to begin with. Both approaches have been evaluated, but we settled on +the "SevIgnore one" for a number of reasons: * It's less invasive to deal with; -* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as for those we need - to be able to /always/ produce a message (so that is reported at runtime); -* It gives us more freedom: we can still decide to drop a 'SevIgnore' message at leisure, or we can - decide to keep it around until the last moment. Maybe in the future we would need to - turn a 'SevIgnore' into something else, for example to "unsuppress" diagnostics if a flag is - set: with this approach, we have more leeway to accommodate new features. +* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as + for those we need to be able to /always/ produce a message (so that is + reported at runtime); +* It gives us more freedom: we can still decide to drop a 'SevIgnore' message + at leisure, or we can decide to keep it around until the last moment. Maybe + in the future we would need to turn a 'SevIgnore' into something else, for + example to "unsuppress" diagnostics if a flag is set: with this approach, we + have more leeway to accommodate new features. -} @@ -446,36 +505,49 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = {- Note [Intrinsic And Extrinsic Failures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in the former category -those diagnostics which are /essentially/ failures, and their nature can't be changed. This is -the case for 'ErrorWithoutFlag'. We classify as /extrinsic/ all those diagnostics (like fatal warnings) -which are born as warnings but which are still failures under particular 'DynFlags' settings. It's important -to be aware of such logic distinction, because when we are inside the typechecker or the desugarer, we are -interested about intrinsic errors, and to bail out as soon as we find one of them. Conversely, if we find -an /extrinsic/ one, for example because a particular 'WarningFlag' makes a warning and error, we /don't/ -want to bail out, that's still not the right time to do so: Rather, we want to first collect all the -diagnostics, and later classify and report them appropriately (in the driver). - +We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in +the former category those diagnostics which are /essentially/ failures, and +their nature can't be changed. This is the case for 'ErrorWithoutFlag'. We +classify as /extrinsic/ all those diagnostics (like fatal warnings) which are +born as warnings but which are still failures under particular 'DynFlags' +settings. It's important to be aware of such logic distinction, because when +we are inside the typechecker or the desugarer, we are interested about +intrinsic errors, and to bail out as soon as we find one of them. Conversely, +if we find an /extrinsic/ one, for example because a particular 'WarningFlag' +makes a warning and error, we /don't/ want to bail out, that's still not the +right time to do so: Rather, we want to first collect all the diagnostics, and +later classify and report them appropriately (in the driver). -} - --- | Returns 'True' if this is, intrinsically, a failure. See Note [Intrinsic And Extrinsic Failures]. +-- | Returns 'True' if this is, intrinsically, a failure. See +-- Note [Intrinsic And Extrinsic Failures]. isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool isWarningMessage = not . isIntrinsicErrorMessage +-- | Are there any hard errors here? -Werror warnings are /not/ detected. If +-- you want to check for -Werror warnings, use 'errorsOrFatalWarningsFound'. errorsFound :: Diagnostic e => Messages e -> Bool errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs +-- | Returns 'True' if the envelope contains a message that will stop +-- compilation: either an intrinsic error or a fatal (-Werror) warning +isExtrinsicErrorMessage :: MsgEnvelope e -> Bool +isExtrinsicErrorMessage = (==) SevError . errMsgSeverity + +-- | Are there any errors or -Werror warnings here? +errorsOrFatalWarningsFound :: Messages e -> Bool +errorsOrFatalWarningsFound (Messages msgs) = any isExtrinsicErrorMessage msgs + getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs --- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the --- second the errors. -partitionMessages :: Diagnostic e => Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) -partitionMessages (Messages xs) = partitionBag isWarningMessage xs +-- | Partitions the 'Messages' and returns a tuple which first element are the +-- warnings, and the second the errors. +partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e) +partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs) diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs index b8a1e932e0..4979d9188b 100644 --- a/compiler/GHC/Types/SourceError.hs +++ b/compiler/GHC/Types/SourceError.hs @@ -10,25 +10,29 @@ module GHC.Types.SourceError where import GHC.Prelude -import GHC.Data.Bag import GHC.Types.Error import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Exception +import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc) +import GHC.Utils.Outputable + +import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage +import GHC.Driver.Errors.Types import Control.Monad.Catch as MC (MonadCatch, catch) -mkSrcErr :: ErrorMessages -> SourceError +mkSrcErr :: Messages GhcMessage -> SourceError mkSrcErr = SourceError -srcErrorMessages :: SourceError -> ErrorMessages +srcErrorMessages :: SourceError -> Messages GhcMessage srcErrorMessages (SourceError msgs) = msgs -throwErrors :: MonadIO io => ErrorMessages -> io a +throwErrors :: MonadIO io => Messages GhcMessage -> io a throwErrors = liftIO . throwIO . mkSrcErr -throwOneError :: MonadIO io => MsgEnvelope DiagnosticMessage -> io a -throwOneError = throwErrors . unitBag +throwOneError :: MonadIO io => MsgEnvelope GhcMessage -> io a +throwOneError = throwErrors . singleMessage -- | A source error is an error that is caused by one or more errors in the -- source code. A 'SourceError' is thrown by many functions in the @@ -46,10 +50,18 @@ throwOneError = throwErrors . unitBag -- -- See 'printExceptionAndWarnings' for more information on what to take care -- of when writing a custom error handler. -newtype SourceError = SourceError ErrorMessages +newtype SourceError = SourceError (Messages GhcMessage) instance Show SourceError where - show (SourceError msgs) = unlines . map show . bagToList $ msgs + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (SourceError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLoc + . getMessages + $ msgs instance Exception SourceError diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 99bff97a5b..7e614588f6 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -15,13 +15,13 @@ module GHC.Utils.Error ( Severity(..), -- * Messages - WarnMsg, + Diagnostic(..), MsgEnvelope(..), MessageClass(..), SDoc, DecoratedSDoc(unDecorated), - Messages, ErrorMessages, WarningMessages, - unionMessages, + Messages, + mkMessages, unionMessages, errorsFound, isEmptyMessages, -- ** Formatting @@ -33,9 +33,14 @@ module GHC.Utils.Error ( -- ** Construction emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, - mkShortMsgEnvelope, mkShortErrorMsgEnvelope, mkLongMsgEnvelope, + mkErrorMsgEnvelope, mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, + mkPlainError, + mkPlainDiagnostic, + mkDecoratedError, + mkDecoratedDiagnostic, + -- * Utilities doIfSet, doIfSet_dyn, getCaretDiagnostic, @@ -97,6 +102,15 @@ diagReasonSeverity _ ErrorWithoutFlag +-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the 'DynFlags'. +mkMCDiagnostic :: DynFlags -> DiagnosticReason -> MessageClass +mkMCDiagnostic dflags reason = MCDiagnostic (diagReasonSeverity dflags reason) reason + +-- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the +-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'. +errorDiagnostic :: MessageClass +errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag + -- -- Creating MsgEnvelope(s) -- @@ -115,6 +129,9 @@ mk_msg_envelope severity locn print_unqual err , errMsgSeverity = severity } +-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. +-- If you know your 'Diagnostic' is an error, consider using 'mkErrorMsgEnvelope', +-- which does not require looking at the 'DynFlags' mkMsgEnvelope :: Diagnostic e => DynFlags @@ -125,63 +142,34 @@ mkMsgEnvelope mkMsgEnvelope dflags locn print_unqual err = mk_msg_envelope (diagReasonSeverity dflags (diagnosticReason err)) locn print_unqual err --- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the 'DynFlags'. -mkMCDiagnostic :: DynFlags -> DiagnosticReason -> MessageClass -mkMCDiagnostic dflags reason = MCDiagnostic (diagReasonSeverity dflags reason) reason - --- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the --- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'. -errorDiagnostic :: MessageClass -errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag - --- | A long (multi-line) diagnostic message. --- The 'Severity' will be calculated out of the 'DiagnosticReason', and will likely be --- incorrect in the presence of '-Werror'. -mkLongMsgEnvelope :: DynFlags - -> DiagnosticReason - -> SrcSpan - -> PrintUnqualified - -> SDoc - -> SDoc - -> MsgEnvelope DiagnosticMessage -mkLongMsgEnvelope dflags rea locn unqual msg extra = - mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea) - --- | A short (one-line) diagnostic message. --- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. -mkShortMsgEnvelope :: DynFlags - -> DiagnosticReason - -> SrcSpan +-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. +-- Precondition: the diagnostic is, in fact, an error. That is, +-- @diagnosticReason msg == ErrorWithoutFlag@. +mkErrorMsgEnvelope :: Diagnostic e + => SrcSpan -> PrintUnqualified - -> SDoc - -> MsgEnvelope DiagnosticMessage -mkShortMsgEnvelope dflags rea locn unqual msg = - mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg]) rea) - -mkShortErrorMsgEnvelope :: SrcSpan - -> PrintUnqualified - -> SDoc - -> MsgEnvelope DiagnosticMessage -mkShortErrorMsgEnvelope locn unqual msg = - mk_msg_envelope SevError locn unqual (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag) + -> e + -> MsgEnvelope e +mkErrorMsgEnvelope locn unqual msg = + mk_msg_envelope SevError locn unqual msg -- | Variant that doesn't care about qualified/unqualified names. --- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. -mkPlainMsgEnvelope :: DynFlags - -> DiagnosticReason +mkPlainMsgEnvelope :: Diagnostic e + => DynFlags -> SrcSpan - -> SDoc - -> MsgEnvelope DiagnosticMessage -mkPlainMsgEnvelope dflags rea locn msg = - mkMsgEnvelope dflags locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea) + -> e + -> MsgEnvelope e +mkPlainMsgEnvelope dflags locn msg = + mkMsgEnvelope dflags locn alwaysQualify msg -- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we -- are constructing a diagnostic with a 'ErrorWithoutFlag' reason. -mkPlainErrorMsgEnvelope :: SrcSpan - -> SDoc - -> MsgEnvelope DiagnosticMessage +mkPlainErrorMsgEnvelope :: Diagnostic e + => SrcSpan + -> e + -> MsgEnvelope e mkPlainErrorMsgEnvelope locn msg = - mk_msg_envelope SevError locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag) + mk_msg_envelope SevError locn alwaysQualify msg ------------------------- data Validity @@ -582,5 +570,3 @@ of the execution through the various labels) and ghc.totals.txt (total time spent in each label). -} - - diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index c977f89078..67d3f11c67 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -91,9 +91,6 @@ module GHC.Utils.Misc ( looksLikeModuleName, looksLikePackageName, - -- * Argument processing - getCmd, toCmdArgs, toArgs, - -- * Integers exactLog2, @@ -1102,67 +1099,6 @@ looksLikeModuleName (c:cs) = isUpper c && go cs looksLikePackageName :: String -> Bool looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' -{- -Akin to @Prelude.words@, but acts like the Bourne shell, treating -quoted strings as Haskell Strings, and also parses Haskell [String] -syntax. --} - -getCmd :: String -> Either String -- Error - (String, String) -- (Cmd, Rest) -getCmd s = case break isSpace $ dropWhile isSpace s of - ([], _) -> Left ("Couldn't find command in " ++ show s) - res -> Right res - -toCmdArgs :: String -> Either String -- Error - (String, [String]) -- (Cmd, Args) -toCmdArgs s = case getCmd s of - Left err -> Left err - Right (cmd, s') -> case toArgs s' of - Left err -> Left err - Right args -> Right (cmd, args) - -toArgs :: String -> Either String -- Error - [String] -- Args -toArgs str - = case dropWhile isSpace str of - s@('[':_) -> case reads s of - [(args, spaces)] - | all isSpace spaces -> - Right args - _ -> - Left ("Couldn't read " ++ show str ++ " as [String]") - s -> toArgs' s - where - toArgs' :: String -> Either String [String] - -- Remove outer quotes: - -- > toArgs' "\"foo\" \"bar baz\"" - -- Right ["foo", "bar baz"] - -- - -- Keep inner quotes: - -- > toArgs' "-DFOO=\"bar baz\"" - -- Right ["-DFOO=\"bar baz\""] - toArgs' s = case dropWhile isSpace s of - [] -> Right [] - ('"' : _) -> do - -- readAsString removes outer quotes - (arg, rest) <- readAsString s - (arg:) `fmap` toArgs' rest - s' -> case break (isSpace <||> (== '"')) s' of - (argPart1, s''@('"':_)) -> do - (argPart2, rest) <- readAsString s'' - -- show argPart2 to keep inner quotes - ((argPart1 ++ show argPart2):) `fmap` toArgs' rest - (arg, s'') -> (arg:) `fmap` toArgs' s'' - - readAsString :: String -> Either String (String, String) - readAsString s = case reads s of - [(arg, rest)] - -- rest must either be [] or start with a space - | all isSpace (take 1 rest) -> - Right (arg, rest) - _ -> - Left ("Couldn't read " ++ show s ++ " as String") ----------------------------------------------------------------------------- -- Integers diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f260600ba5..15018529d3 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -384,6 +384,8 @@ Library GHC.Driver.Env GHC.Driver.Env.Types GHC.Driver.Errors + GHC.Driver.Errors.Ppr + GHC.Driver.Errors.Types GHC.Driver.Flags GHC.Driver.Hooks GHC.Driver.Main @@ -413,6 +415,8 @@ Library GHC.HsToCore.Binds GHC.HsToCore.Coverage GHC.HsToCore.Docs + GHC.HsToCore.Errors.Ppr + GHC.HsToCore.Errors.Types GHC.HsToCore.Expr GHC.HsToCore.Foreign.Call GHC.HsToCore.Foreign.Decl @@ -475,6 +479,7 @@ Library GHC.Parser.CharClass GHC.Parser.Errors GHC.Parser.Errors.Ppr + GHC.Parser.Errors.Types GHC.Parser.Header GHC.Parser.Lexer GHC.Parser.PostProcess @@ -574,6 +579,8 @@ Library GHC.Tc.Errors GHC.Tc.Errors.Hole GHC.Tc.Errors.Hole.FitTypes + GHC.Tc.Errors.Ppr + GHC.Tc.Errors.Types GHC.Tc.Gen.Annotation GHC.Tc.Gen.App GHC.Tc.Gen.Arrow diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index c53f6771b5..4f126b92b3 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -77,6 +77,7 @@ import GHC.Builtin.Types( stringTyCon_RDR ) import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName ) import GHC.Types.SrcLoc as SrcLoc import qualified GHC.Parser.Lexer as Lexer +import GHC.Parser.Header ( toArgs ) import GHC.Unit import GHC.Unit.State @@ -293,7 +294,7 @@ keepGoing' a str = a str >> return False keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) keepGoingPaths a str - = do case toArgs str of + = do case toArgsNoLoc str of Left err -> liftIO $ hPutStrLn stderr err Right args -> a args return False @@ -1562,7 +1563,7 @@ pprInfo (thing, fixity, cls_insts, fam_insts, docs) -- :main runMain :: GhciMonad m => String -> m () -runMain s = case toArgs s of +runMain s = case toArgsNoLoc s of Left err -> liftIO (hPutStrLn stderr err) Right args -> do dflags <- getDynFlags @@ -1583,6 +1584,33 @@ doWithArgs :: GhciMonad m => [String] -> String -> m () doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ show args ++ " (" ++ cmd ++ ")"] +{- +Akin to @Prelude.words@, but acts like the Bourne shell, treating +quoted strings as Haskell Strings, and also parses Haskell [String] +syntax. +-} + +getCmd :: String -> Either String -- Error + (String, String) -- (Cmd, Rest) +getCmd s = case break isSpace $ dropWhile isSpace s of + ([], _) -> Left ("Couldn't find command in " ++ show s) + res -> Right res + +toCmdArgs :: String -> Either String -- Error + (String, [String]) -- (Cmd, Args) +toCmdArgs s = case getCmd s of + Left err -> Left err + Right (cmd, s') -> case toArgsNoLoc s' of + Left err -> Left err + Right args -> Right (cmd, args) + +-- wrapper around GHC.Parser.Header.toArgs, but without locations +toArgsNoLoc :: String -> Either String [String] +toArgsNoLoc str = map unLoc <$> toArgs fake_loc str + where + fake_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 + -- this should never be seen, because it's discarded with the `map unLoc` + ----------------------------------------------------------------------------- -- :cd @@ -2854,11 +2882,11 @@ setCmd "-a" = showOptions True setCmd str = case getCmd str of Right ("args", rest) -> - case toArgs rest of + case toArgsNoLoc rest of Left err -> liftIO (hPutStrLn stderr err) Right args -> setArgs args Right ("prog", rest) -> - case toArgs rest of + case toArgsNoLoc rest of Right [prog] -> setProg prog _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>") @@ -2877,7 +2905,7 @@ setCmd str Right ("stop", rest) -> setStop $ dropWhile isSpace rest Right ("local-config", rest) -> setLocalConfigBehaviour $ dropWhile isSpace rest - _ -> case toArgs str of + _ -> case toArgsNoLoc str of Left err -> liftIO (hPutStrLn stderr err) Right wds -> setOptions wds @@ -2885,7 +2913,7 @@ setiCmd :: GhciMonad m => String -> m () setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True setiCmd str = - case toArgs str of + case toArgsNoLoc str of Left err -> liftIO (hPutStrLn stderr err) Right wds -> newDynFlags True wds diff --git a/testsuite/tests/driver/StringListOptions.hs b/testsuite/tests/driver/StringListOptions.hs new file mode 100644 index 0000000000..51f8b6db4d --- /dev/null +++ b/testsuite/tests/driver/StringListOptions.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC [ ] #-} + +module StringListOptions where diff --git a/testsuite/tests/driver/T2464.stderr b/testsuite/tests/driver/T2464.stderr index 3d0074fc82..bba952fd30 100644 --- a/testsuite/tests/driver/T2464.stderr +++ b/testsuite/tests/driver/T2464.stderr @@ -1,3 +1,3 @@ -T2464.hs:3:16: warning: [-Wdeprecated-flags (in -Wdefault)] +T2464.hs:3:17: warning: [-Wdeprecated-flags (in -Wdefault)] -fffi is deprecated: use -XForeignFunctionInterface or pragma {-# LANGUAGE ForeignFunctionInterface #-} instead diff --git a/testsuite/tests/driver/T2499.stderr b/testsuite/tests/driver/T2499.stderr index 9a082d34b1..88d8dbe56a 100644 --- a/testsuite/tests/driver/T2499.stderr +++ b/testsuite/tests/driver/T2499.stderr @@ -1,4 +1,6 @@ -T2499.hs:1:12: unknown flag in {-# OPTIONS_GHC #-} pragma: -package +T2499.hs:1:13: error: + unknown flag in {-# OPTIONS_GHC #-} pragma: -package -T2499.hs:1:12: unknown flag in {-# OPTIONS_GHC #-} pragma: blargh +T2499.hs:1:22: error: + unknown flag in {-# OPTIONS_GHC #-} pragma: blargh diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 94ecb3006c..447a4d0800 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -234,6 +234,7 @@ test('T10970', normal, compile_and_run, ['']) test('T4931', normal, compile_and_run, ['']) test('T11182', normal, compile_and_run, ['']) test('T11381', normal, compile_fail, ['']) +test('StringListOptions', normal, compile, ['']) test('T11429a', normal, compile, ['-Wunrecognised-warning-flags -Wfoobar']) test('T11429b', normal, compile, ['-Wno-unrecognised-warning-flags -Wfoobar']) test('T11429c', normal, compile_fail, ['-Wunrecognised-warning-flags -Werror -Wfoobar']) diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs index e0b6a57764..7c16e7f0d0 100644 --- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs +++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs @@ -49,7 +49,7 @@ main = do let (warnings, errors) = partitionMessages messages case mres of Nothing -> do - printBagOfErrors logger dflags warnings - printBagOfErrors logger dflags errors + printMessages logger dflags warnings + printMessages logger dflags errors Just (t, _) -> do putStrLn $ showSDoc dflags (debugPprType t) diff --git a/testsuite/tests/parser/should_compile/T16619.stderr b/testsuite/tests/parser/should_compile/T16619.stderr index 68a8bf5da8..aab7175abd 100644 --- a/testsuite/tests/parser/should_compile/T16619.stderr +++ b/testsuite/tests/parser/should_compile/T16619.stderr @@ -1,3 +1,3 @@ -T16619.hs:2:12: warning: [-Wdeprecated-flags (in -Wdefault)] +T16619.hs:2:13: warning: [-Wdeprecated-flags (in -Wdefault)] -Wmissing-space-after-bang is deprecated: bang patterns can no longer be written with a space diff --git a/testsuite/tests/parser/should_fail/T16270.stderr b/testsuite/tests/parser/should_fail/T16270.stderr index 6666ac7963..323d9c93e3 100644 --- a/testsuite/tests/parser/should_fail/T16270.stderr +++ b/testsuite/tests/parser/should_fail/T16270.stderr @@ -1,5 +1,5 @@ -T16270.hs:3:12: warning: [-Wdeprecated-flags (in -Wdefault)] +T16270.hs:3:13: warning: [-Wdeprecated-flags (in -Wdefault)] -Werror=missing-space-after-bang is deprecated: bang patterns can no longer be written with a space T16270.hs:8:1: warning: [-Wtabs (in -Wdefault)] diff --git a/testsuite/tests/parser/should_fail/readFail044.stderr b/testsuite/tests/parser/should_fail/readFail044.stderr index 27becac67c..1976b56079 100644 --- a/testsuite/tests/parser/should_fail/readFail044.stderr +++ b/testsuite/tests/parser/should_fail/readFail044.stderr @@ -1,6 +1,6 @@ -readFail044.hs:3:16: +readFail044.hs:3:17: error: unknown flag in {-# OPTIONS_GHC #-} pragma: -this-flag-does-not-exist -readFail044.hs:3:16: +readFail044.hs:3:43: error: unknown flag in {-# OPTIONS_GHC #-} pragma: -nor-does-this-one diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index a9479a9d8d..cb96d95d78 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -1,4 +1,4 @@ -Found 245 Language.Haskell.Syntax module dependencies +Found 255 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -83,6 +83,8 @@ GHC.Driver.CmdLine GHC.Driver.Env GHC.Driver.Env.Types GHC.Driver.Errors +GHC.Driver.Errors.Ppr +GHC.Driver.Errors.Types GHC.Driver.Flags GHC.Driver.Hooks GHC.Driver.Monad @@ -103,12 +105,18 @@ GHC.Hs.Lit GHC.Hs.Pat GHC.Hs.Type GHC.Hs.Utils +GHC.HsToCore.Errors.Ppr +GHC.HsToCore.Errors.Types GHC.Iface.Ext.Fields GHC.Iface.Recomp.Binary GHC.Iface.Syntax GHC.Iface.Type GHC.Linker.Types GHC.Parser.Annotation +GHC.Parser.Errors +GHC.Parser.Errors.Ppr +GHC.Parser.Errors.Types +GHC.Parser.Types GHC.Platform GHC.Platform.AArch64 GHC.Platform.ARM @@ -138,6 +146,8 @@ GHC.StgToCmm.Types GHC.SysTools.BaseDir GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes +GHC.Tc.Errors.Ppr +GHC.Tc.Errors.Types GHC.Tc.Types GHC.Tc.Types.Constraint GHC.Tc.Types.Evidence diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 73a238fd09..82daac1a97 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 253 GHC.Parser module dependencies +Found 261 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -84,6 +84,8 @@ GHC.Driver.CmdLine GHC.Driver.Env GHC.Driver.Env.Types GHC.Driver.Errors +GHC.Driver.Errors.Ppr +GHC.Driver.Errors.Types GHC.Driver.Flags GHC.Driver.Hooks GHC.Driver.Monad @@ -104,6 +106,8 @@ GHC.Hs.Lit GHC.Hs.Pat GHC.Hs.Type GHC.Hs.Utils +GHC.HsToCore.Errors.Ppr +GHC.HsToCore.Errors.Types GHC.Iface.Ext.Fields GHC.Iface.Recomp.Binary GHC.Iface.Syntax @@ -113,6 +117,8 @@ GHC.Parser GHC.Parser.Annotation GHC.Parser.CharClass GHC.Parser.Errors +GHC.Parser.Errors.Ppr +GHC.Parser.Errors.Types GHC.Parser.Lexer GHC.Parser.PostProcess GHC.Parser.PostProcess.Haddock @@ -146,6 +152,8 @@ GHC.StgToCmm.Types GHC.SysTools.BaseDir GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes +GHC.Tc.Errors.Ppr +GHC.Tc.Errors.Types GHC.Tc.Types GHC.Tc.Types.Constraint GHC.Tc.Types.Evidence diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index b956f2579a..4e84261264 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -124,7 +124,7 @@ compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do errorMsgs = fmap mkParserErr errors -- print parser errors or warnings - mapM_ (printBagOfErrors logger dflags) [warningMsgs, errorMsgs] + mapM_ (printMessages logger dflags . mkMessages) [warningMsgs, errorMsgs] let initTopSRT = emptySRT thisMod cmmGroup <- fmap snd $ cmmPipeline hscEnv initTopSRT $ fst $ fromJust parsedCmm diff --git a/testsuite/tests/safeHaskell/check/Check05.stderr b/testsuite/tests/safeHaskell/check/Check05.stderr index 9db0875f44..c14f8c02b2 100644 --- a/testsuite/tests/safeHaskell/check/Check05.stderr +++ b/testsuite/tests/safeHaskell/check/Check05.stderr @@ -1,3 +1,3 @@ -Check05.hs:1:16: +Check05.hs:1:17: Warning: -fpackage-trust ignored; must be specified with a Safe Haskell flag diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags18.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags18.stderr index 2766f41512..603cb636a7 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags18.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags18.stderr @@ -1,3 +1,3 @@ -SafeFlags18.hs:1:16: error: [-Werror] +SafeFlags18.hs:1:17: error: [-Werror] -fpackage-trust ignored; must be specified with a Safe Haskell flag diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags19.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags19.stderr index adbc757494..e47c40a558 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags19.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags19.stderr @@ -1,3 +1,3 @@ -SafeFlags19.hs:1:16: +SafeFlags19.hs:1:17: unknown flag in {-# OPTIONS_GHC #-} pragma: -fno-package-trust diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags22.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags22.stderr index 9d93e5e332..cc4d8b7ae1 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags22.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags22.stderr @@ -1,5 +1,5 @@ -SafeFlags22.hs:2:16: warning: [-Wunsafe] +SafeFlags22.hs:2:17: warning: [-Wunsafe] ‘SafeFlags22’ has been inferred as unsafe! Reason: SafeFlags22.hs:8:1: error: diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags23.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags23.stderr index 6fef7a3e4c..3bb3d3b02a 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags23.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags23.stderr @@ -1,5 +1,5 @@ -SafeFlags23.hs:2:16: error: [-Wunsafe, -Werror=unsafe] +SafeFlags23.hs:2:17: error: [-Wunsafe, -Werror=unsafe] ‘SafeFlags22’ has been inferred as unsafe! Reason: SafeFlags23.hs:8:1: error: diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags25.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags25.stderr index e26a813e83..57bcdaa192 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags25.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags25.stderr @@ -1,3 +1,3 @@ -SafeFlags25.hs:2:16: warning: [-Wsafe] +SafeFlags25.hs:2:17: warning: [-Wsafe] ‘SafeFlags25’ has been inferred as safe! diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags26.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags26.stderr index dabbd92c00..f4b084a9a5 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags26.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags26.stderr @@ -1,3 +1,3 @@ -SafeFlags26.hs:2:16: error: [-Wsafe, -Werror=safe] +SafeFlags26.hs:2:17: error: [-Wsafe, -Werror=safe] ‘SafeFlags26’ has been inferred as safe! diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags28.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags28.stderr index 46dcabb9fd..13fdaf0c1a 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags28.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags28.stderr @@ -1,12 +1,12 @@ -SafeFlags28.hs:1:16: +SafeFlags28.hs:1:17: error: unknown flag in {-# OPTIONS_GHC #-} pragma: -trust -SafeFlags28.hs:1:16: +SafeFlags28.hs:1:24: error: unknown flag in {-# OPTIONS_GHC #-} pragma: base, -SafeFlags28.hs:1:16: +SafeFlags28.hs:1:30: error: unknown flag in {-# OPTIONS_GHC #-} pragma: -trust -SafeFlags28.hs:1:16: +SafeFlags28.hs:1:37: error: unknown flag in {-# OPTIONS_GHC #-} pragma: bytestring diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags29.stderr b/testsuite/tests/safeHaskell/flags/SafeFlags29.stderr index ee0d13b957..2c32e70254 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags29.stderr +++ b/testsuite/tests/safeHaskell/flags/SafeFlags29.stderr @@ -1,12 +1,12 @@ -SafeFlags29.hs:2:16: +SafeFlags29.hs:2:17: error: unknown flag in {-# OPTIONS_GHC #-} pragma: -trust -SafeFlags29.hs:2:16: +SafeFlags29.hs:2:24: error: unknown flag in {-# OPTIONS_GHC #-} pragma: base -SafeFlags29.hs:2:16: +SafeFlags29.hs:2:29: error: unknown flag in {-# OPTIONS_GHC #-} pragma: -trust -SafeFlags29.hs:2:16: +SafeFlags29.hs:2:36: error: unknown flag in {-# OPTIONS_GHC #-} pragma: bytestring diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr index 9eb029951f..0e990b4f97 100644 --- a/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr @@ -2,7 +2,7 @@ [2 of 3] Compiling SH_Overlap11_A ( SH_Overlap11_A.hs, SH_Overlap11_A.o ) [3 of 3] Compiling SH_Overlap11 ( SH_Overlap11.hs, SH_Overlap11.o ) -SH_Overlap11.hs:2:16: warning: [-Wunsafe] +SH_Overlap11.hs:2:17: warning: [-Wunsafe] ‘SH_Overlap11’ has been inferred as unsafe! Reason: SH_Overlap11.hs:18:8: warning: diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr index 4a4fb3779c..dda1490ce0 100644 --- a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr @@ -2,7 +2,7 @@ [2 of 3] Compiling SH_Overlap7_A ( SH_Overlap7_A.hs, SH_Overlap7_A.o ) [3 of 3] Compiling SH_Overlap7 ( SH_Overlap7.hs, SH_Overlap7.o ) -SH_Overlap7.hs:2:16: error: [-Wunsafe, -Werror=unsafe] +SH_Overlap7.hs:2:17: error: [-Wunsafe, -Werror=unsafe] ‘SH_Overlap7’ has been inferred as unsafe! Reason: SH_Overlap7.hs:15:8: diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr index 2e9e92a696..664d3fa298 100644 --- a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr @@ -3,6 +3,6 @@ SafeInfered05.hs:3:14: warning: [-Wdeprecated-flags (in -Wdefault)] -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS [1 of 2] Compiling SafeInfered05_A ( SafeInfered05_A.hs, SafeInfered05_A.o ) -SafeInfered05_A.hs:3:16: warning: [-Wsafe] +SafeInfered05_A.hs:3:17: warning: [-Wsafe] ‘SafeInfered05_A’ has been inferred as safe! [2 of 2] Compiling SafeInfered05 ( SafeInfered05.hs, SafeInfered05.o ) diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.stderr b/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.stderr index 7efaba3490..13155f3043 100644 --- a/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.stderr @@ -1,3 +1,3 @@ -SafeWarn01.hs:3:16: warning: [-Wsafe] +SafeWarn01.hs:3:17: warning: [-Wsafe] ‘SafeWarn01’ has been inferred as safe! diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered11.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered11.stderr index 919eec4e6b..31a8488b74 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered11.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered11.stderr @@ -1,6 +1,6 @@ [1 of 2] Compiling UnsafeInfered11_A ( UnsafeInfered11_A.hs, UnsafeInfered11_A.o ) -UnsafeInfered11_A.hs:2:16: warning: [-Wunsafe] +UnsafeInfered11_A.hs:2:17: warning: [-Wunsafe] ‘UnsafeInfered11_A’ has been inferred as unsafe! Reason: UnsafeInfered11_A.hs:18:11: warning: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered12.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered12.stderr index e3529474bd..22a07d9f96 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered12.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered12.stderr @@ -1,5 +1,5 @@ -UnsafeInfered12.hs:3:16: error: [-Wunsafe, -Werror=unsafe] +UnsafeInfered12.hs:3:17: error: [-Wunsafe, -Werror=unsafe] ‘UnsafeInfered12’ has been inferred as unsafe! Reason: UnsafeInfered12.hs:2:14: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.stderr index 5424c5f2a2..1bced3b94a 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.stderr @@ -1,5 +1,5 @@ -UnsafeWarn01.hs:3:16: warning: [-Wunsafe] +UnsafeWarn01.hs:3:17: warning: [-Wunsafe] ‘UnsafeWarn01’ has been inferred as unsafe! Reason: UnsafeWarn01.hs:8:1: error: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.stderr index 881db587d5..0061ed3e1d 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.stderr @@ -1,5 +1,5 @@ -UnsafeWarn02.hs:3:16: warning: [-Wunsafe] +UnsafeWarn02.hs:3:17: warning: [-Wunsafe] ‘UnsafeWarn02’ has been inferred as unsafe! Reason: UnsafeWarn02.hs:5:14: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.stderr index ba23b72ee1..c48a136f74 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.stderr @@ -1,5 +1,5 @@ -UnsafeWarn03.hs:4:16: warning: [-Wunsafe] +UnsafeWarn03.hs:4:17: warning: [-Wunsafe] ‘UnsafeWarn03’ has been inferred as unsafe! Reason: UnsafeWarn03.hs:9:1: error: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.stderr index 90e6d5b6f1..94f0203f46 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.stderr @@ -1,5 +1,5 @@ -UnsafeWarn04.hs:4:16: warning: [-Wunsafe] +UnsafeWarn04.hs:4:17: warning: [-Wunsafe] ‘UnsafeWarn04’ has been inferred as unsafe! Reason: UnsafeWarn04.hs:9:1: error: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.stderr index 2977504457..471443ea12 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.stderr @@ -1,12 +1,12 @@ -UnsafeWarn05.hs:5:16: warning: [-Wunsafe] +UnsafeWarn05.hs:5:17: warning: [-Wunsafe] ‘UnsafeWarn05’ has been inferred as unsafe! Reason: UnsafeWarn05.hs:11:1: error: System.IO.Unsafe: Can't be safely imported! The module itself isn't safe. -UnsafeWarn05.hs:5:16: warning: [-Wunsafe] +UnsafeWarn05.hs:5:17: warning: [-Wunsafe] ‘UnsafeWarn05’ has been inferred as unsafe! Reason: UnsafeWarn05.hs:16:11: warning: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.stderr index 98b1360202..b494f02eec 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.stderr @@ -1,5 +1,5 @@ -UnsafeWarn06.hs:4:16: warning: [-Wunsafe] +UnsafeWarn06.hs:4:17: warning: [-Wunsafe] ‘UnsafeWarn06’ has been inferred as unsafe! Reason: UnsafeWarn06.hs:9:11: warning: diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.stderr index 91a4ec3547..0b3370cb59 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.stderr @@ -1,5 +1,5 @@ -UnsafeWarn07.hs:5:16: warning: [-Wunsafe] +UnsafeWarn07.hs:5:17: warning: [-Wunsafe] ‘UnsafeWarn07’ has been inferred as unsafe! Reason: UnsafeWarn07.hs:10:11: warning: diff --git a/testsuite/tests/th/T19709a.hs b/testsuite/tests/th/T19709a.hs new file mode 100644 index 0000000000..8c0e5fd665 --- /dev/null +++ b/testsuite/tests/th/T19709a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell, ExplicitForAll, PolyKinds #-} + +module T19709a where + +import GHC.Exts + +$( let levid :: forall (r :: RuntimeRep) (a :: TYPE r). a -> a + levid x = x + in return [] ) diff --git a/testsuite/tests/th/T19709a.stderr b/testsuite/tests/th/T19709a.stderr new file mode 100644 index 0000000000..4cb72aeed7 --- /dev/null +++ b/testsuite/tests/th/T19709a.stderr @@ -0,0 +1,6 @@ + +T19709a.hs:8:14: error: + A levity-polymorphic type is not allowed here: + Type: a + Kind: TYPE r + In the type of binder ‘x’ diff --git a/testsuite/tests/th/T19709b.hs b/testsuite/tests/th/T19709b.hs new file mode 100644 index 0000000000..afc9ed5769 --- /dev/null +++ b/testsuite/tests/th/T19709b.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell, ExplicitForAll, PolyKinds, TypeApplications #-} + +module T19709b where + +import GHC.Exts +import Language.Haskell.TH + +$( let levfun :: forall (r :: RuntimeRep) (a :: TYPE r). a -> () + levfun = error "e1" -- NB: this, so far, is OK: no levity-polymorphic binder + + in levfun (error @Any "e2") -- but this is very naughty: levity-polymorphic argument + `seq` return [] ) diff --git a/testsuite/tests/th/T19709b.stderr b/testsuite/tests/th/T19709b.stderr new file mode 100644 index 0000000000..78405ebaea --- /dev/null +++ b/testsuite/tests/th/T19709b.stderr @@ -0,0 +1,6 @@ + +T19709b.hs:11:14: error: + A levity-polymorphic type is not allowed here: + Type: Any + Kind: TYPE Any + In the type of expression: (error @Any "e2") diff --git a/testsuite/tests/th/T19709c.hs b/testsuite/tests/th/T19709c.hs new file mode 100644 index 0000000000..588b269fc3 --- /dev/null +++ b/testsuite/tests/th/T19709c.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror #-} + +module T19709c where + +import Language.Haskell.TH + +$( do runIO $ putStrLn "compiling the splice" + case tail "hello" of "hello" -> return [] ) diff --git a/testsuite/tests/th/T19709c.stderr b/testsuite/tests/th/T19709c.stderr new file mode 100644 index 0000000000..3bedc08dc9 --- /dev/null +++ b/testsuite/tests/th/T19709c.stderr @@ -0,0 +1,10 @@ + +T19709c.hs:9:7: error: [-Wincomplete-patterns (in -Wextra), -Werror=incomplete-patterns] + Pattern match(es) are non-exhaustive + In a case alternative: + Patterns of type ‘String’ not matched: + [] + [p] where p is not one of {'h'} + (p:_:_) where p is not one of {'h'} + ['h'] + ... diff --git a/testsuite/tests/th/T19709d.hs b/testsuite/tests/th/T19709d.hs new file mode 100644 index 0000000000..81985e80db --- /dev/null +++ b/testsuite/tests/th/T19709d.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wincomplete-patterns #-} + +module T19709d where + +$( case tail "hello" of "hello" -> return [] ) diff --git a/testsuite/tests/th/T19709d.stderr b/testsuite/tests/th/T19709d.stderr new file mode 100644 index 0000000000..4adadd09ba --- /dev/null +++ b/testsuite/tests/th/T19709d.stderr @@ -0,0 +1,16 @@ + +T19709d.hs:6:4: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In a case alternative: + Patterns of type ‘String’ not matched: + [] + [p] where p is not one of {'h'} + (p:_:_) where p is not one of {'h'} + ['h'] + ... + +T19709d.hs:1:1: error: + Exception when trying to run compile-time code: + T19709d.hs:6:4-44: Non-exhaustive patterns in case + + Code: (case tail "hello" of "hello" -> return []) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index fb3bc7fb49..c34b92977a 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -514,6 +514,10 @@ test('TH_BytesShowEqOrd', normal, compile_and_run, ['']) test('T18102', normal, compile_fail, ['']) test('T18102b', extra_files(['T18102b_aux.hs']), compile_and_run, ['']) test('T18121', normal, compile, ['']) +test('T19709a', normal, compile_fail, ['']) +test('T19709b', normal, compile_fail, ['']) +test('T19709c', normal, compile_fail, ['']) +test('T19709d', normal, compile_fail, ['']) test('T18123', normal, compile, ['']) test('T18388', normal, compile, ['']) test('T18612', normal, compile, ['']) diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs index 03616f846a..93ddfd4f07 100644 --- a/utils/check-exact/Parsers.hs +++ b/utils/check-exact/Parsers.hs @@ -54,6 +54,7 @@ import qualified Control.Monad.IO.Class as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.Parser as GHC import qualified GHC.Parser.Header as GHC @@ -61,7 +62,6 @@ import qualified GHC.Parser.Lexer as GHC import qualified GHC.Parser.PostProcess as GHC import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Utils.Error as GHC import qualified GHC.LanguageExtensions as LangExt @@ -79,8 +79,10 @@ parseWith :: GHC.DynFlags -> ParseResult w parseWith dflags fileName parser s = case runParser parser dflags fileName s of - GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> Right pmod + GHC.PFailed pst + -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + GHC.POk _ pmod + -> Right pmod parseWithECP :: (GHC.DisambECP w) @@ -91,8 +93,10 @@ parseWithECP :: (GHC.DisambECP w) -> ParseResult (GHC.LocatedA w) parseWithECP dflags fileName parser s = case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of - GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> Right pmod + GHC.PFailed pst + -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + GHC.POk _ pmod + -> Right pmod -- --------------------------------------------------------------------- @@ -182,8 +186,10 @@ parseModuleFromStringInternal :: Parser GHC.ParsedSource parseModuleFromStringInternal dflags fileName str = let (str1, lp) = stripLinePragmas str res = case runParser GHC.parseModule dflags fileName str1 of - GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> Right (lp, dflags, pmod) + GHC.PFailed pst + -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + GHC.POk _ pmod + -> Right (lp, dflags, pmod) in postParseTransform res parseModuleWithOptions :: FilePath -- ^ GHC libdir @@ -253,9 +259,10 @@ parseModuleEpAnnsWithCppInternal cppOptions dflags file = do return (contents1,lp,dflags) return $ case parseFile dflags' file fileContents of - GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> - Right $ (injectedComments, dflags', pmod) + GHC.PFailed pst + -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + GHC.POk _ pmod + -> Right $ (injectedComments, dflags', pmod) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs index 58cb6d028c..a2d3b53f49 100644 --- a/utils/check-exact/Preprocess.hs +++ b/utils/check-exact/Preprocess.hs @@ -16,26 +16,28 @@ module Preprocess import qualified GHC as GHC hiding (parseModule) import qualified Control.Monad.IO.Class as GHC -import qualified GHC.Data.Bag as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC import qualified GHC.Driver.Config as GHC import qualified GHC.Driver.Env as GHC +import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC import qualified GHC.Fingerprint.Type as GHC import qualified GHC.Parser.Errors.Ppr as GHC -import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Parser.Lexer as GHC hiding (getMessages) import qualified GHC.Settings as GHC +import qualified GHC.Types.Error as GHC (getMessages) import qualified GHC.Types.SourceError as GHC import qualified GHC.Types.SourceFile as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Error as GHC import qualified GHC.Utils.Fingerprint as GHC +import qualified GHC.Utils.Outputable as GHC import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) import GHC.Data.FastString (mkFastString) -import Data.List (isPrefixOf, intercalate) +import Data.List (isPrefixOf) import Data.Maybe import Types import Utils @@ -221,8 +223,13 @@ getPreprocessedSrcDirectPrim cppOptions src_fn = do txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') -showErrorMessages :: GHC.ErrorMessages -> String -showErrorMessages msgs = intercalate "\n" $ map show $ GHC.bagToList msgs +showErrorMessages :: GHC.Messages GHC.DriverMessage -> String +showErrorMessages msgs = + GHC.renderWithContext GHC.defaultSDocContext + $ GHC.vcat + $ GHC.pprMsgEnvelopeBagWithLoc + $ GHC.getMessages + $ msgs injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags injectCppOptions CppOptions{..} dflags = @@ -276,7 +283,8 @@ parseError pst = do let -- (warns,errs) = GHC.getMessages pst dflags -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) - GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst)) + GHC.throwErrors $ + (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) -- --------------------------------------------------------------------- |