diff options
32 files changed, 247 insertions, 122 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 1711e1c802..26f870a5bc 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -929,7 +929,8 @@ checkNewDynFlags logger dflags = do -- See Note [DynFlags consistency] let (dflags', warnings) = makeDynFlagsConsistent dflags let diag_opts = initDiagOpts dflags - liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings) + print_config = initPrintConfig dflags + liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings) return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags @@ -939,7 +940,8 @@ checkNewInteractiveDynFlags logger dflags0 = do if xopt LangExt.StaticPointers dflags0 then do let diag_opts = initDiagOpts dflags0 - liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage + print_config = initPrintConfig dflags0 + liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ singleMessage $ fmap GhcDriverMessage $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported return $ xopt_unset dflags0 LangExt.StaticPointers diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index e961b3a242..93422e4161 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -106,8 +106,9 @@ doBackpack [src_filename] = do -- Not doing so caused #20396. -- Cribbed from: preprocessFile / GHC.Driver.Pipeline liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns) - liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns + let print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns) + liftIO $ handleFlagWarnings logger print_config (initDiagOpts dflags) warns -- TODO: Preprocessing not implemented buf <- liftIO $ hGetStringBuffer src_filename diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs index 00fa9695c3..e8bf0f5926 100644 --- a/compiler/GHC/Driver/Config/Diagnostic.hs +++ b/compiler/GHC/Driver/Config/Diagnostic.hs @@ -1,5 +1,13 @@ +{-# LANGUAGE TypeApplications #-} +-- | Functions for initialising error message printing configuration from the +-- GHC session flags. module GHC.Driver.Config.Diagnostic ( initDiagOpts + , initPrintConfig + , initPsMessageOpts + , initDsMessageOpts + , initTcMessageOpts + , initDriverMessageOpts ) where @@ -8,7 +16,15 @@ import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..)) +import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..)) +import GHC.Driver.Errors.Ppr () +import GHC.Tc.Errors.Types +import GHC.HsToCore.Errors.Types +import GHC.Types.Error +-- | Initialise the general configuration for printing diagnostic messages +-- For example, this configuration controls things like whether warnings are +-- treated like errors. initDiagOpts :: DynFlags -> DiagOpts initDiagOpts dflags = DiagOpts { diag_warning_flags = warningFlags dflags @@ -19,3 +35,23 @@ initDiagOpts dflags = DiagOpts , diag_ppr_ctx = initSDocContext dflags defaultErrStyle } +-- | Initialise the configuration for printing specific diagnostic messages +initPrintConfig :: DynFlags -> DiagnosticOpts GhcMessage +initPrintConfig dflags = + GhcMessageOpts { psMessageOpts = initPsMessageOpts dflags + , tcMessageOpts = initTcMessageOpts dflags + , dsMessageOpts = initDsMessageOpts dflags + , driverMessageOpts= initDriverMessageOpts dflags } + +initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage +initPsMessageOpts _ = NoDiagnosticOpts + +initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage +initTcMessageOpts _ = NoDiagnosticOpts + +initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage +initDsMessageOpts _ = NoDiagnosticOpts + +initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage +initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) + diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index f6b7f415a0..edca007608 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -46,7 +46,7 @@ import GHC.Driver.Session import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Driver.Errors.Types ( GhcMessage ) import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.Diagnostic (initDiagOpts) +import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) import GHC.Runtime.Context @@ -95,7 +95,8 @@ runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyMessages let dflags = hsc_dflags hsc_env let !diag_opts = initDiagOpts dflags - printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w + !print_config = initPrintConfig dflags + printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w return a runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage) diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 5467f2ad14..024820202d 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module GHC.Driver.Errors ( printOrThrowDiagnostics , printMessages @@ -16,8 +17,8 @@ import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext, text, withPprStyle, import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine -printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO () -printMessages logger opts msgs +printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () +printMessages logger msg_opts opts msgs = sequence_ [ let style = mkErrStyle unqual ctx = (diag_ppr_ctx opts) { sdocStyle = style } in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $ @@ -30,15 +31,15 @@ printMessages logger opts msgs where messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc messageWithHints ctx e = - let main_msg = formatBulleted ctx $ diagnosticMessage e + let main_msg = formatBulleted ctx $ diagnosticMessage msg_opts e in case diagnosticHints e of [] -> main_msg [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted ctx . mkDecorated . map ppr $ hs) -handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO () -handleFlagWarnings logger opts warns = do +handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO () +handleFlagWarnings logger print_config opts warns = do let -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. bag = listToBag [ mkPlainMsgEnvelope opts loc $ @@ -48,16 +49,16 @@ handleFlagWarnings logger opts warns = do mkPlainDiagnostic reason noHints $ text warn | CmdLine.Warn reason (L loc warn) <- warns ] - printOrThrowDiagnostics logger opts (mkMessages bag) + printOrThrowDiagnostics logger print_config opts (mkMessages bag) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. -printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO () -printOrThrowDiagnostics logger opts msgs +printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO () +printOrThrowDiagnostics logger print_config opts msgs | errorsOrFatalWarningsFound msgs = throwErrors msgs | otherwise - = printMessages logger opts msgs + = printMessages logger print_config opts msgs -- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it -- for dealing with parse errors when the driver is doing dependency analysis. diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs index 8f0ffa4a4d..69e3c28740 100644 --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} module GHC.Driver.Errors.Ppr ( @@ -26,6 +28,8 @@ import GHC.Types.SrcLoc import Data.Version import Language.Haskell.Syntax.Decls (RuleDecl(..)) +import GHC.Tc.Errors.Types (TcRnMessage) +import GHC.HsToCore.Errors.Types (DsMessage) -- -- Suggestions @@ -36,19 +40,23 @@ suggestInstantiatedWith :: ModuleName -> GenInstantiations UnitId -> [Instantiat suggestInstantiatedWith pi_mod_name insts = [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ] - instance Diagnostic GhcMessage where - diagnosticMessage = \case + type DiagnosticOpts GhcMessage = GhcMessageOpts + defaultDiagnosticOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage) + (defaultDiagnosticOpts @TcRnMessage) + (defaultDiagnosticOpts @DsMessage) + (defaultDiagnosticOpts @DriverMessage) + diagnosticMessage opts = \case GhcPsMessage m - -> diagnosticMessage m + -> diagnosticMessage (psMessageOpts opts) m GhcTcRnMessage m - -> diagnosticMessage m + -> diagnosticMessage (tcMessageOpts opts) m GhcDsMessage m - -> diagnosticMessage m + -> diagnosticMessage (dsMessageOpts opts) m GhcDriverMessage m - -> diagnosticMessage m - GhcUnknownMessage m - -> diagnosticMessage m + -> diagnosticMessage (driverMessageOpts opts) m + GhcUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m diagnosticReason = \case GhcPsMessage m @@ -77,11 +85,13 @@ instance Diagnostic GhcMessage where diagnosticCode = constructorCode instance Diagnostic DriverMessage where - diagnosticMessage = \case - DriverUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts DriverMessage = DriverMessageOpts + defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) + diagnosticMessage opts = \case + DriverUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m DriverPsHeaderMessage m - -> diagnosticMessage m + -> diagnosticMessage (psDiagnosticOpts opts) m DriverMissingHomeModules missing buildingCabalPackage -> let msg | buildingCabalPackage == YesBuildingCabalPackage = hang diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs index 988f533205..cb7625ca09 100644 --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -4,7 +4,10 @@ module GHC.Driver.Errors.Types ( GhcMessage(..) - , DriverMessage(..), DriverMessages, PsMessage(PsHeaderMessage) + , GhcMessageOpts(..) + , DriverMessage(..) + , DriverMessageOpts(..) + , DriverMessages, PsMessage(PsHeaderMessage) , BuildingCabalPackage(..) , WarningMessages , ErrorMessages @@ -91,13 +94,20 @@ data GhcMessage where deriving Generic + +data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage + , tcMessageOpts :: DiagnosticOpts TcRnMessage + , dsMessageOpts :: DiagnosticOpts DsMessage + , driverMessageOpts :: DiagnosticOpts DriverMessage + } + -- | 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 :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage ghcUnknownMessage = GhcUnknownMessage . UnknownDiagnostic -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on @@ -117,6 +127,7 @@ type DriverMessages = Messages DriverMessage data DriverMessage where -- | Simply wraps a generic 'Diagnostic' message @a@. DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage + -- | A parse error in parsing a Haskell file header during dependency -- analysis DriverPsHeaderMessage :: !PsMessage -> DriverMessage @@ -359,6 +370,9 @@ data DriverMessage where deriving instance Generic DriverMessage +data DriverMessageOpts = + DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage } + -- | Pass to a 'DriverMessage' the information whether or not the -- '-fbuilding-cabal-package' flag is set. data BuildingCabalPackage diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index a16156143a..ab305d1ed5 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fprof-auto-top #-} @@ -381,9 +382,10 @@ getHscEnv = Hsc $ \e w -> return (e, w) handleWarnings :: Hsc () handleWarnings = do diag_opts <- initDiagOpts <$> getDynFlags + print_config <- initPrintConfig <$> getDynFlags logger <- getLogger w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger diag_opts w + liftIO $ printOrThrowDiagnostics logger print_config diag_opts w clearDiagnostics -- | log warning in the monad, and if there are errors then @@ -401,7 +403,7 @@ handleWarningsThrowErrors (warnings, errors) = do logDiagnostics (GhcPsMessage <$> warnings) logger <- getLogger let (wWarns, wErrs) = partitionMessages warnings - liftIO $ printMessages logger diag_opts wWarns + liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs -- | Deal with errors and warnings returned by a compilation step @@ -1067,6 +1069,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h let bcknd = backend dflags hsc_src = ms_hsc_src summary diag_opts = initDiagOpts dflags + print_config = initPrintConfig dflags -- Desugar, if appropriate -- @@ -1081,7 +1084,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h -- Report the warnings from both typechecking and desugar together w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w) + liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w) clearDiagnostics -- Simplify, if appropriate, and (whether we simplified or not) generate an @@ -1657,7 +1660,7 @@ 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 :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv +markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags @@ -1686,7 +1689,9 @@ 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 (getMessages whyUnsafe)) $+$ + -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these + -- unsafety error messages in an unstructured manner. + (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 8f8f644cdb..68a925f901 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -2407,7 +2408,8 @@ wrapAction :: HscEnv -> IO a -> IO (Maybe a) wrapAction hsc_env k = do let lcl_logger = hsc_logger hsc_env lcl_dynflags = hsc_dflags hsc_env - let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err) + print_config = initPrintConfig lcl_dynflags + let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (srcErrorMessages err) -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches` -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 3c2fbbac34..1ad0f4fac9 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -147,7 +147,8 @@ logDiagnostics warns = do dflags <- getSessionDynFlags logger <- getLogger let !diag_opts = initDiagOpts dflags - liftIO $ printOrThrowDiagnostics logger diag_opts warns + !print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config diag_opts warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, @@ -224,7 +225,8 @@ printException err = do dflags <- getDynFlags logger <- getLogger let !diag_opts = initDiagOpts dflags - liftIO $ printMessages logger diag_opts (srcErrorMessages err) + !print_config = initPrintConfig dflags + liftIO $ printMessages logger print_config diag_opts (srcErrorMessages err) -- | A function called to log warnings and errors. type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m () diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 8588dfdda8..246b00393a 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- @@ -162,7 +163,8 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = 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)) + -- MP: Default config is fine here as it's just in a panic. + (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs)) Just msgs' -> msgs' to_driver_message = \case @@ -690,8 +692,9 @@ preprocessPipeline pipe_env hsc_env input_fn = do -- Reparse with original hsc_env so that we don't get duplicated options use (T_FileArgs hsc_env pp_fn) - liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) - liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3) + let print_config = initPrintConfig dflags3 + liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) + liftIO (handleFlagWarnings (hsc_logger hsc_env) print_config (initDiagOpts dflags3) warns3) return (dflags3, pp_fn) diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs index 092a690b25..4566460a0e 100644 --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} - +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where @@ -23,9 +25,11 @@ import GHC.HsToCore.Pmc.Ppr instance Diagnostic DsMessage where - diagnosticMessage = \case - DsUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts DsMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = \case + DsUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m DsEmptyEnumeration -> mkSimpleDecorated $ text "Enumeration is empty" DsIdentitiesFound conv_fn type_of_conv @@ -235,7 +239,7 @@ instance Diagnostic DsMessage where DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing - diagnosticHints = \case + diagnosticHints = \case DsUnknownMessage m -> diagnosticHints m DsEmptyEnumeration -> noHints DsIdentitiesFound{} -> noHints diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs index 028a02544d..8f6586fb45 100644 --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} module GHC.HsToCore.Errors.Types where diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 9bd53fa341..8a0b600a66 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -317,7 +317,7 @@ initTcDsForSolver thing_inside thing_inside ; case mb_ret of Just ret -> pure ret - Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } + Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef (Messages DsMessage) -> IORef CostCentreState diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index b515d89541..f2f8bfd769 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -5,6 +5,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage @@ -36,9 +38,11 @@ import Data.List.NonEmpty (NonEmpty((:|))) instance Diagnostic PsMessage where - diagnosticMessage = \case - PsUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts PsMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = \case + PsUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m PsHeaderMessage m -> psHeaderMessageDiagnostic m @@ -509,7 +513,7 @@ instance Diagnostic PsMessage where , nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] , text "In the newtype declaration for" <+> quotes (ppr tycon) ] - diagnosticReason = \case + diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m PsHeaderMessage m -> psHeaderMessageReason m PsWarnBidirectionalFormatChars{} -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters @@ -627,7 +631,7 @@ instance Diagnostic PsMessage where PsErrInvalidCApiImport {} -> ErrorWithoutFlag PsErrMultipleConForNewtype {} -> ErrorWithoutFlag - diagnosticHints = \case + diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m PsHeaderMessage m -> psHeaderMessageHints m PsWarnBidirectionalFormatChars{} -> noHints diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index 1b16911700..19851babd1 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} module GHC.Parser.Errors.Types where diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 0eb7706434..7734a135f5 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1108,7 +1108,7 @@ mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msg = important, sr_supp (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" ; dflags <- getDynFlags - ; let err_msg = pprLocMsgEnvelope msg + ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg err_str = showSDoc dflags $ err_msg $$ text "(deferred type error)" @@ -1174,9 +1174,12 @@ mkErrorReport tcl_env msg mb_ctxt supplementary ErrInfo (fromMaybe empty mb_context) (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) + ; let detailed_msg = mkDetailedMessage err_info msg ; mkTcRnMessage (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) } + (TcRnMessageWithInfo unit_state $ detailed_msg) } + + -- | Pretty-print supplementary information, to add to an error report. pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 8dae970dee..993b62a7ea 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage @@ -95,15 +96,16 @@ import Data.Ord ( comparing ) import Data.Bifunctor import GHC.Types.Name.Env - instance Diagnostic TcRnMessage where - diagnosticMessage = \case - TcRnUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts TcRnMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage opts = \case + TcRnUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m TcRnMessageWithInfo unit_state msg_with_info -> case msg_with_info of TcRnMessageDetailed err_info msg - -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) + -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage opts msg) TcRnSolverReport msg _ _ -> mkSimpleDecorated $ pprSolverReportWithCtxt msg TcRnRedundantConstraints redundants (info, show_info) diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 854ebd3bf6..d0d40366d9 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -182,12 +182,13 @@ data TcRnMessageDetailed !TcRnMessage deriving Generic -mkTcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage +mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) + => a -> TcRnMessage mkTcRnUnknownMessage diag = TcRnUnknownMessage (UnknownDiagnostic diag) -- | An error which might arise during typechecking/renaming. data TcRnMessage where - {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins + {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins to provide custom diagnostic messages originated during typechecking/renaming. -} TcRnUnknownMessage :: UnknownDiagnostic -> TcRnMessage diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 6341aecf8d..b01c7ccb5d 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -1099,9 +1099,8 @@ tc_infer_id id_name hint_msg = vcat $ map ppr hints import_err_msg = vcat $ map ppr import_errs info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } - msg = TcRnMessageWithInfo unit_state - $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False) - failWithTc msg + failWithTc $ TcRnMessageWithInfo unit_state ( + mkDetailedMessage info (TcRnIncorrectNameSpace nm False)) get_suggestions ns = do let occ = mkOccNameFS ns (occNameFS (occName id_name)) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index e7a45a5be9..f4490244f8 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1219,7 +1219,8 @@ runMeta' show_code ppr_hs run_and_convert expr -- cases. ; logger <- getLogger ; diag_opts <- initDiagOpts <$> getDynFlags - ; liftIO $ printMessages logger diag_opts ds_msgs + ; print_config <- initDsMessageOpts <$> getDynFlags + ; liftIO $ printMessages logger print_config diag_opts ds_msgs ; ds_expr <- case mb_ds_expr of Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice] diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 346b1f4273..8319212147 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -70,7 +70,7 @@ module GHC.Tc.Utils.Monad( addErrAt, addErrs, checkErr, addMessages, - discardWarnings, + discardWarnings, mkDetailedMessage, -- * Usage environment tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, @@ -1068,7 +1068,12 @@ addErrAt :: SrcSpan -> TcRnMessage -> TcRn () addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- tcInitTidyEnv ; err_info <- mkErrInfo tidy_env ctxt - ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } + ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg + ; add_long_err_at loc detailed_msg } + +mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed +mkDetailedMessage err_info msg = + TcRnMessageDetailed err_info msg addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs @@ -1132,7 +1137,7 @@ reportDiagnostics = mapM_ reportDiagnostic reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg - = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ; + = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ; errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; writeTcRef errs_var (msg `addMessage` msgs) } @@ -1601,7 +1606,8 @@ addDiagnosticTcM (env0, msg) = do { ctxt <- getErrCtxt ; extra <- mkErrInfo env0 ctxt ; let err_info = ErrInfo extra Outputable.empty - ; add_diagnostic (TcRnMessageDetailed err_info msg) } + detailed_msg = mkDetailedMessage err_info msg + ; add_diagnostic detailed_msg } -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' -- given some additional context about the diagnostic. @@ -1623,14 +1629,14 @@ addTcRnDiagnostic msg = do -- | Display a diagnostic for the current source location, taken from -- the 'TcRn' monad. addDiagnostic :: TcRnMessage -> TcRn () -addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg) +addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg) -- | Display a diagnostic for a given source location. addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () addDiagnosticAt loc msg = do unit_state <- hsc_units <$> getTopEnv - let dia = TcRnMessageDetailed no_err_info msg - mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic + let detailed_msg = mkDetailedMessage no_err_info msg + mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic -- | Display a diagnostic, with an optional flag, for the current source -- location. @@ -1652,7 +1658,7 @@ add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan -> TcM () add_err_tcm tidy_env msg loc ctxt = do { err_info <- mkErrInfo tidy_env ctxt ; - add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } + add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) } mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 3c8ff8b4bb..3bc7937df0 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -4,6 +4,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} module GHC.Types.Error ( -- * Messages @@ -32,6 +35,8 @@ module GHC.Types.Error , mkDecoratedDiagnostic , mkDecoratedError + , NoDiagnosticOpts(..) + -- * Hints and refactoring actions , GhcHint (..) , AvailableBindings(..) @@ -211,11 +216,16 @@ mapDecoratedSDoc f (Decorated s1) = -- GHC's case, it can be an error or a warning) and the /reason/ why such -- message was generated in the first place. class Diagnostic a where + + -- | Type of configuration options for the diagnostic. + type DiagnosticOpts a + defaultDiagnosticOpts :: DiagnosticOpts a + -- | Extract the error message text from a 'Diagnostic'. - diagnosticMessage :: a -> DecoratedSDoc + diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc -- | Extract the reason for this diagnostic. For warnings, - -- a 'DiagnosticReason' includes the warning flag + -- a 'DiagnosticReason' includes the warning flag. diagnosticReason :: a -> DiagnosticReason -- | Extract any hints a user might use to repair their @@ -238,17 +248,25 @@ class Diagnostic a where -- | An existential wrapper around an unknown diagnostic. data UnknownDiagnostic where - UnknownDiagnostic :: (Typeable diag, Diagnostic diag) => diag -> UnknownDiagnostic + UnknownDiagnostic :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) + => a -> UnknownDiagnostic instance Diagnostic UnknownDiagnostic where - diagnosticMessage (UnknownDiagnostic diag) = diagnosticMessage diag - diagnosticReason (UnknownDiagnostic diag) = diagnosticReason diag - diagnosticHints (UnknownDiagnostic diag) = diagnosticHints diag - diagnosticCode (UnknownDiagnostic diag) = diagnosticCode diag - -pprDiagnostic :: Diagnostic e => e -> SDoc + type DiagnosticOpts UnknownDiagnostic = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ (UnknownDiagnostic diag) = diagnosticMessage NoDiagnosticOpts diag + diagnosticReason (UnknownDiagnostic diag) = diagnosticReason diag + diagnosticHints (UnknownDiagnostic diag) = diagnosticHints diag + diagnosticCode (UnknownDiagnostic diag) = diagnosticCode diag + +-- A fallback 'DiagnosticOpts' which can be used when there are no options +-- for a particular diagnostic. +data NoDiagnosticOpts = NoDiagnosticOpts + +pprDiagnostic :: forall e . Diagnostic e => e -> SDoc pprDiagnostic e = vcat [ ppr (diagnosticReason e) - , nest 2 (vcat (unDecorated (diagnosticMessage e))) ] + , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ] + where opts = defaultDiagnosticOpts @e -- | A generic 'Hint' message, to be used with 'DiagnosticMessage'. data DiagnosticHint = DiagnosticHint !SDoc @@ -268,7 +286,9 @@ data DiagnosticMessage = DiagnosticMessage } instance Diagnostic DiagnosticMessage where - diagnosticMessage = diagMessage + type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = diagMessage diagnosticReason = diagReason diagnosticHints = diagHints diagnosticCode _ = Nothing @@ -429,10 +449,10 @@ instance ToJson MessageClass where instance Show (MsgEnvelope DiagnosticMessage) where show = showMsgEnvelope --- | Shows an 'MsgEnvelope'. -showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String +-- | Shows an 'MsgEnvelope'. Only use this for debugging. +showMsgEnvelope :: forall a . Diagnostic a => MsgEnvelope a -> String showMsgEnvelope err = - renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err)) + renderWithContext defaultSDocContext (vcat (unDecorated . (diagnosticMessage (defaultDiagnosticOpts @a)) $ errMsgDiagnostic err)) pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs index 4979d9188b..5ce389fd4e 100644 --- a/compiler/GHC/Types/SourceError.hs +++ b/compiler/GHC/Types/SourceError.hs @@ -14,7 +14,7 @@ import GHC.Types.Error import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Exception -import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc) +import GHC.Utils.Error (pprMsgEnvelopeBagWithLocDefault) import GHC.Utils.Outputable import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage @@ -59,7 +59,7 @@ instance Show SourceError where show (SourceError msgs) = renderWithContext defaultSDocContext . vcat - . pprMsgEnvelopeBagWithLoc + . pprMsgEnvelopeBagWithLocDefault . getMessages $ msgs diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index d696ddd2be..def40ea728 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} {- (c) The AQUA Project, Glasgow University, 1994-1998 @@ -25,9 +26,9 @@ module GHC.Utils.Error ( errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprMsgEnvelopeBagWithLoc, + pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault, pprMessages, - pprLocMsgEnvelope, + pprLocMsgEnvelope, pprLocMsgEnvelopeDefault, formatBulleted, -- ** Construction @@ -228,14 +229,22 @@ formatBulleted ctx (unDecorated -> docs) msgs = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) -pprMessages :: Diagnostic e => Messages e -> SDoc -pprMessages = vcat . pprMsgEnvelopeBagWithLoc . getMessages +pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc +pprMessages e = vcat . pprMsgEnvelopeBagWithLoc e . getMessages -pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] -pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] +pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLoc e bag = [ pprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ] -pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc -pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s +-- | Print the messages with the suitable default configuration, usually not what you want but sometimes you don't really +-- care about what the configuration is (for example, if the message is in a panic). +pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLocDefault bag = [ pprLocMsgEnvelopeDefault item | item <- sortMsgBag Nothing bag ] + +pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc +pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e) + +pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev , errMsgContext = unqual }) @@ -244,7 +253,7 @@ pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s mkLocMessage (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) s - (formatBulleted ctx $ diagnosticMessage e) + (formatBulleted ctx $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 6cbf4dffb9..4efb35f35e 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -3136,7 +3136,7 @@ newDynFlags interactive_only minus_opts = do idflags0 <- GHC.getInteractiveDynFlags (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts - liftIO $ handleFlagWarnings logger (initDiagOpts idflags1) warns + liftIO $ handleFlagWarnings logger (initPrintConfig idflags1) (initDiagOpts idflags1) warns when (not $ null leftovers) (throwGhcException . CmdLineError $ "Some flags have not been recognized: " diff --git a/ghc/Main.hs b/ghc/Main.hs index 16075284c0..ae862a7014 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -247,7 +247,7 @@ main' postLoadMode units dflags0 args flagWarnings = do handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do - liftIO $ handleFlagWarnings logger4 (initDiagOpts dflags4) flagWarnings' + liftIO $ handleFlagWarnings logger4 (initPrintConfig dflags4) (initDiagOpts dflags4) flagWarnings' liftIO $ showBanner postLoadMode dflags4 @@ -779,7 +779,7 @@ initMulti unitArgsFiles = do handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do - liftIO $ handleFlagWarnings logger (initDiagOpts dflags2) warns + liftIO $ handleFlagWarnings logger (initPrintConfig dflags2) (initDiagOpts dflags2) warns let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args) dflags4 = offsetDynFlags dflags3 diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs index 8e89a63cc6..32bad7c8e0 100644 --- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs +++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs @@ -51,7 +51,8 @@ main = do case mres of Nothing -> do let diag_opts = initDiagOpts dflags - printMessages logger diag_opts warnings - printMessages logger diag_opts errors + print_config = initTcMessageOpts dflags + printMessages logger print_config diag_opts warnings + printMessages logger print_config diag_opts errors Just (t, _) -> do putStrLn $ showSDoc dflags (debugPprType t) diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index 0238b5d03c..f3294bfd35 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -140,7 +140,8 @@ compileCmmForRegAllocStats logger home_unit dflags cmmFile ncgImplF us = do -- print parser errors or warnings let !diag_opts = initDiagOpts dflags - mapM_ (printMessages logger diag_opts) [warnings, errors] + !print_config = initPsMessageOpts dflags + mapM_ (printMessages logger print_config diag_opts) [warnings, errors] let initTopSRT = emptySRT thisMod cmmGroup <- fmap snd $ cmmPipeline logger cmm_config initTopSRT $ fst $ fromJust parsedCmm diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 8023549c22..87921ac3e8 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -358,7 +358,7 @@ showErrorMessages :: Messages GhcMessage -> String showErrorMessages msgs = renderWithContext defaultSDocContext $ vcat - $ pprMsgEnvelopeBagWithLoc + $ pprMsgEnvelopeBagWithLocDefault $ getMessages $ msgs diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs index b238b2baa7..756dc18984 100644 --- a/utils/check-exact/Preprocess.hs +++ b/utils/check-exact/Preprocess.hs @@ -17,7 +17,6 @@ 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.Parser as GHC @@ -28,16 +27,17 @@ import qualified GHC.Driver.Pipeline as GHC import qualified GHC.Fingerprint.Type as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Settings as GHC -import qualified GHC.Types.Error as GHC (getErrorMessages, DiagnosticMessage(..)) +import qualified GHC.Types.Error as GHC 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 @@ -218,25 +218,19 @@ getPreprocessedSrcDirectPrim cppOptions src_fn = do new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) case r of - Left err -> error $ showErrorMessages $ fmap GHC.GhcDriverMessage err + Left err -> error $ showErrorMessages err Right (dflags', hspp_fn) -> do buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') -showErrorMessages :: GHC.ErrorMessages -> String -showErrorMessages msgs = intercalate "\n" - $ map (show @(GHC.MsgEnvelope GHC.DiagnosticMessage) . fmap toDiagnosticMessage) - $ GHC.bagToList - $ GHC.getErrorMessages msgs - --- | Show Error Messages relies on show instance for MsgEnvelope DiagnosticMessage --- We convert a known Diagnostic into this generic version -toDiagnosticMessage :: GHC.Diagnostic e => e -> GHC.DiagnosticMessage -toDiagnosticMessage msg = GHC.DiagnosticMessage { diagMessage = GHC.diagnosticMessage msg - , diagReason = GHC.diagnosticReason msg - , diagHints = GHC.diagnosticHints msg - } +showErrorMessages :: GHC.Messages GHC.DriverMessage -> String +showErrorMessages msgs = + GHC.renderWithContext GHC.defaultSDocContext + $ GHC.vcat + $ GHC.pprMsgEnvelopeBagWithLocDefault + $ GHC.getMessages + $ msgs injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags injectCppOptions CppOptions{..} dflags = diff --git a/utils/haddock b/utils/haddock -Subproject e5b41a9f92de608f3605ef54da5709074e189ad +Subproject 57b7493ba60bc4f4cf6b57b900b0c46fe8d8666 |