From b1a17507229b00820b9552a423342f8c354267d4 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Mon, 18 Jan 2021 16:12:28 +0100 Subject: Rename ErrMsg into MsgEnvelope Updates Haddock submodule --- compiler/GHC/Driver/Backpack.hs | 2 +- compiler/GHC/Driver/Errors.hs | 22 +++++----- compiler/GHC/Driver/Main.hs | 18 ++++---- compiler/GHC/Driver/Make.hs | 22 +++++----- compiler/GHC/Driver/MakeFile.hs | 2 +- compiler/GHC/Driver/Pipeline.hs | 2 +- compiler/GHC/HsToCore/Monad.hs | 2 +- compiler/GHC/HsToCore/Pmc/Solver.hs | 4 +- compiler/GHC/Iface/Rename.hs | 2 +- compiler/GHC/Parser/Errors/Ppr.hs | 12 +++--- compiler/GHC/Parser/Header.hs | 6 +-- compiler/GHC/Rename/Env.hs | 1 - compiler/GHC/Tc/Errors.hs | 48 ++++++++++----------- compiler/GHC/Tc/Module.hs | 2 +- compiler/GHC/Tc/Utils/Monad.hs | 18 ++++---- compiler/GHC/Types/Error.hs | 83 ++++++++++++++++++++++--------------- compiler/GHC/Types/SourceError.hs | 2 +- compiler/GHC/Utils/Error.hs | 24 +++++------ utils/haddock | 2 +- 19 files changed, 144 insertions(+), 130 deletions(-) diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index e5f1844474..0a1a2b8bf7 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -786,7 +786,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing Nothing -- GHC API buffer support not supported [] -- No exclusions case r of - Nothing -> throwOneError (mkPlainErrMsg loc (text "module" <+> ppr modname <+> text "was not found")) + Nothing -> throwOneError (mkPlainMsgEnvelope loc (text "module" <+> ppr modname <+> text "was not found")) Just (Left err) -> throwErrors err Just (Right summary) -> return summary diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 191d3b8248..a76df66291 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -28,24 +28,24 @@ warningsToMessages dflags = Right warn{ errMsgSeverity = SevError , errMsgReason = ErrReason err_reason } -printBagOfErrors :: RenderableDiagnostic a => DynFlags -> Bag (ErrMsg a) -> IO () +printBagOfErrors :: RenderableDiagnostic a => DynFlags -> Bag (MsgEnvelope a) -> IO () printBagOfErrors dflags bag_of_errors = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style - in putLogMsg dflags reason sev s - $ withPprStyle style (formatErrDoc ctx (renderDiagnostic doc)) - | ErrMsg { errMsgSpan = s, - errMsgDiagnostic = doc, - errMsgSeverity = sev, - errMsgReason = reason, - errMsgContext = unqual } <- sortMsgBag (Just dflags) - bag_of_errors ] + in putLogMsg dflags reason sev s $ + withPprStyle style (formatErrDoc ctx (renderDiagnostic doc)) + | MsgEnvelope { errMsgSpan = s, + errMsgDiagnostic = doc, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = unqual } <- sortMsgBag (Just dflags) + bag_of_errors ] handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO () handleFlagWarnings dflags warns = do let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns - -- It would be nicer if warns :: [Located MsgDoc], but that + -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. bag = listToBag [ mkPlainWarnMsg loc (text warn) | CmdLine.Warn _ (L loc warn) <- warns' ] @@ -54,7 +54,7 @@ handleFlagWarnings dflags warns = do -- | Checks if given 'WarnMsg' is a fatal warning. isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) -isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} +isWarnMsgFatal dflags MsgEnvelope{errMsgReason = Reason wflag} = if wopt_fatal wflag dflags then Just (Just wflag) else Nothing diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 25a405a383..faa46b4850 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1134,7 +1134,7 @@ hscCheckSafeImports tcg_env = do warns rules = listToBag $ map warnRules rules - warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg [SDoc] + warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> MsgEnvelope [SDoc] warnRules (L loc (HsRule { rd_name = n })) = mkPlainWarnMsg loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ @@ -1212,7 +1212,7 @@ checkSafeImports tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = throwOneError $ mkPlainErrMsg (imv_span v1) + = throwOneError $ mkPlainMsgEnvelope (imv_span v1) (text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1280,7 +1280,7 @@ hscCheckSafe' m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainErrMsg l + Nothing -> throwOneError $ mkPlainMsgEnvelope l $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1320,14 +1320,14 @@ hscCheckSafe' m l = do <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag $ mkErrMsg l (pkgQual state) $ + pkgTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ 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 $ mkErrMsg l (pkgQual state) $ + modTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1373,7 +1373,7 @@ checkPkgTrust pkgs = do | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkErrMsg noSrcSpan (pkgQual state) + = (:acc) $ mkMsgEnvelope noSrcSpan (pkgQual state) $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1414,7 +1414,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 $ pprErrMsgBagWithLoc whyUnsafe) $+$ + (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer @@ -1924,7 +1924,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do case is of [L _ i] -> return i _ -> liftIO $ throwOneError $ - mkPlainErrMsg noSrcSpan $ + mkPlainMsgEnvelope noSrcSpan $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -1953,7 +1953,7 @@ hscParseExpr expr = do maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainErrMsg noSrcSpan + _ -> throwOneError $ mkPlainMsgEnvelope noSrcSpan (text "not an expression:" <+> quotes (text expr)) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index b009c6829a..e6dcfe9a29 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -316,7 +316,7 @@ warnMissingHomeModules hsc_env mod_graph = (sep (map ppr missing)) warn = makeIntoWarning (Reason Opt_WarnMissingHomeModules) - (mkPlainErrMsg noSrcSpan msg) + (mkPlainMsgEnvelope noSrcSpan msg) -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -383,7 +383,7 @@ warnUnusedPackages = do let warn = makeIntoWarning (Reason Opt_WarnUnusedPackages) - (mkPlainErrMsg noSrcSpan msg) + (mkPlainMsgEnvelope noSrcSpan msg) msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" @@ -2209,7 +2209,7 @@ warnUnnecessarySourceImports sccs = do warn :: Located ModuleName -> WarnMsg warn (L loc mod) = - mkPlainErrMsg loc + mkPlainMsgEnvelope loc (text "Warning: {-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2278,7 +2278,7 @@ 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 $ mkPlainErrMsg noSrcSpan $ + else return $ Left $ unitBag $ mkPlainMsgEnvelope noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot @@ -2718,7 +2718,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainErrMsg pi_mod_name_loc $ + throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -2730,7 +2730,7 @@ 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 $ mkPlainErrMsg pi_mod_name_loc $ + in throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags then parens (text "Try adding" <+> quotes (ppr pi_mod_name) @@ -2886,24 +2886,24 @@ withDeferredDiagnostics f = do (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) (\_ -> f) -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg [SDoc] +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope [SDoc] -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrMsg loc $ cannotFindModule hsc_env wanted_mod err + = mkPlainMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err noHsFileErr :: SrcSpan -> String -> ErrorMessages noHsFileErr loc path - = unitBag $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = unitBag $ mkPlainMsgEnvelope loc $ text "Can't find" <+> text path moduleNotFoundErr :: ModuleName -> ErrorMessages moduleNotFoundErr mod - = unitBag $ mkPlainErrMsg noSrcSpan $ + = unitBag $ mkPlainMsgEnvelope noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainMsgEnvelope noSrcSpan $ 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 d513728036..817556ee3e 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -297,7 +297,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps -> return Nothing fail -> - throwOneError $ mkPlainErrMsg srcloc $ + throwOneError $ mkPlainMsgEnvelope srcloc $ cannotFindModule hsc_env imp fail } diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 7adde31d73..760442bc19 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -150,7 +150,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainErrMsg srcspan $ text msg + mkPlainMsgEnvelope srcspan $ text msg handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index a4b4e325dd..c989a29987 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -467,7 +467,7 @@ errDs :: SDoc -> DsM () errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkErrMsg loc (ds_unqual env) err + ; let msg = mkMsgEnvelope loc (ds_unqual env) 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/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index 0ea659e471..7635d0bb25 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -44,7 +44,7 @@ import GHC.HsToCore.Pmc.Utils ( tracePm, mkPmId ) import GHC.Driver.Session import GHC.Driver.Config import GHC.Utils.Outputable -import GHC.Utils.Error ( pprErrMsgBagWithLoc ) +import GHC.Utils.Error ( pprMsgEnvelopeBagWithLoc ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.Bag @@ -684,7 +684,7 @@ tyOracle ty_st@(TySt n inert) cts ; case res of -- return the new inert set and increment the sequence number n Just mb_new_inert -> return (TySt (n+1) <$> mb_new_inert) - Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc (getErrorMessages msgs)) } + Nothing -> pprPanic "tyOracle" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } -- | Allocates a fresh 'EvVar' name for 'PredTy's. nameTyCt :: PredType -> DsM EvVar diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index a5bf8b6253..f523d24625 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -76,7 +76,7 @@ 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` mkPlainErrMsg noSrcSpan doc) + writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope noSrcSpan doc) failM -- | What we have is a generalized ModIface, which corresponds to diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index e40087302f..a923db2898 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -24,8 +24,8 @@ import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) -mkParserErr :: SrcSpan -> SDoc -> ErrMsg [SDoc] -mkParserErr span doc = ErrMsg +mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope [SDoc] +mkParserErr span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify , errMsgDiagnostic = [doc] @@ -33,8 +33,8 @@ mkParserErr span doc = ErrMsg , errMsgReason = NoReason } -mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg [SDoc] -mkParserWarn flag span doc = ErrMsg +mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope [SDoc] +mkParserWarn flag span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify , errMsgDiagnostic = [doc] @@ -42,7 +42,7 @@ mkParserWarn flag span doc = ErrMsg , errMsgReason = Reason flag } -pprWarning :: PsWarning -> ErrMsg [SDoc] +pprWarning :: PsWarning -> MsgEnvelope [SDoc] pprWarning = \case PsWarnTab loc tc -> mkParserWarn Opt_WarnTabs loc $ @@ -128,7 +128,7 @@ pprWarning = \case OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: PsError -> ErrMsg [SDoc] +pprError :: PsError -> MsgEnvelope [SDoc] pprError err = mkParserErr (errLoc err) $ vcat (pp_err (errDesc err) : map pp_hint (errHints err)) diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index e4af48a15a..0af7a555d5 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -313,7 +313,7 @@ checkProcessArgsResult flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) - = mkPlainErrMsg loc $ + = mkPlainMsgEnvelope loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -357,7 +357,7 @@ optionsErrorMsgs unhandled_flags flags_lines _filename , L l f' <- flags_lines , f == f' ] mkMsg (L flagSpan flag) = - mkPlainErrMsg flagSpan $ + mkPlainMsgEnvelope flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag optionsParseError :: String -> SrcSpan -> a -- #15053 @@ -370,4 +370,4 @@ optionsParseError str loc = throwErr :: SrcSpan -> SDoc -> a -- #15053 throwErr loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainErrMsg loc doc + throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope loc doc diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 972e6706de..6e0c19f190 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -71,7 +71,6 @@ import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Utils.Error import GHC.Builtin.Names( rOOT_MAIN ) import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 43f6505d7b..8d8676bef2 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -50,7 +50,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Set import GHC.Data.Bag -import GHC.Utils.Error ( pprLocErrMsg ) +import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Types.Basic import GHC.Types.Error import GHC.Core.ConLike ( ConLike(..)) @@ -750,7 +750,7 @@ mkUserTypeErrorReporter ctxt ; maybeReportError ctxt err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (ErrMsg [SDoc]) +mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope [SDoc]) mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct $ important $ pprUserTypeErrorTy @@ -826,7 +826,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc])) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -835,7 +835,7 @@ mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) -> Reporter +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc])) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -853,7 +853,7 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2 -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) -> Reporter +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc])) -> Reporter reportGroup mk_err ctxt cts = ASSERT( not (null cts)) do { err <- mk_err ctxt cts @@ -872,13 +872,13 @@ reportGroup mk_err ctxt cts = -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc])) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg [SDoc] -> TcM () +maybeReportHoleError :: ReportErrCtxt -> Hole -> MsgEnvelope [SDoc] -> TcM () maybeReportHoleError ctxt hole err | isOutOfScopeHole hole -- Always report an error for out-of-scope variables @@ -920,7 +920,7 @@ maybeReportHoleError ctxt hole err HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err HoleDefer -> return () -maybeReportError :: ReportErrCtxt -> ErrMsg [SDoc] -> TcM () +maybeReportError :: ReportErrCtxt -> MsgEnvelope [SDoc] -> TcM () -- Report the error and/or make a deferred binding for it maybeReportError ctxt err | cec_suppress ctxt -- Some worse error has occurred; @@ -932,7 +932,7 @@ maybeReportError ctxt err TypeWarn reason -> reportWarning reason err TypeError -> reportError err -addDeferredBinding :: ReportErrCtxt -> ErrMsg [SDoc] -> Ct -> TcM () +addDeferredBinding :: ReportErrCtxt -> MsgEnvelope [SDoc] -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -955,14 +955,14 @@ addDeferredBinding ctxt err ct = return () mkErrorTerm :: DynFlags -> Type -- of the error term - -> ErrMsg [SDoc] -> EvTerm + -> MsgEnvelope [SDoc] -> EvTerm mkErrorTerm dflags ty err = evDelayedError ty err_fs where - err_msg = pprLocErrMsg err + err_msg = pprLocMsgEnvelope err err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg [SDoc] -> Hole -> TcM () +maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope [SDoc] -> Hole -> TcM () maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) }) -- Only add bindings for holes in expressions -- not for holes in partial type signatures @@ -1048,11 +1048,11 @@ pprWithArising (ct:cts) ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (ErrMsg [SDoc]) +mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope [SDoc]) mkErrorMsgFromCt ctxt ct report = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (ErrMsg [SDoc]) +mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope [SDoc]) mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) @@ -1153,7 +1153,7 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc]) mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1164,7 +1164,7 @@ mkIrredErr ctxt cts (ct1:_) = cts ---------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (ErrMsg [SDoc]) +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope [SDoc]) mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) @@ -1305,7 +1305,7 @@ givenConstraintsMsg ctxt = 2 (vcat $ map pprConstraint constraints) ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc]) mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1382,11 +1382,11 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc]) mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (ErrMsg [SDoc]) +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope [SDoc]) mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct @@ -1452,7 +1452,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (ErrMsg [SDoc]) + -> TcType -> TcType -> TcM (MsgEnvelope [SDoc]) mkEqErr_help dflags ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct tv1 ty2 @@ -1463,7 +1463,7 @@ mkEqErr_help dflags ctxt report ct ty1 ty2 reportEqErr :: ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (ErrMsg [SDoc]) + -> TcType -> TcType -> TcM (MsgEnvelope [SDoc]) reportEqErr ctxt report ct ty1 ty2 = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) where @@ -1472,7 +1472,7 @@ reportEqErr ctxt report ct ty1 ty2 mkTyVarEqErr, mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM (ErrMsg [SDoc]) + -> TcTyVar -> TcType -> TcM (MsgEnvelope [SDoc]) -- tv1 and ty2 are already tidied mkTyVarEqErr dflags ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) @@ -1672,7 +1672,7 @@ pp_givens givens -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc]) mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report where report = important msg @@ -2279,7 +2279,7 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc]) mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index bdcc85ef64..5f55d3a45a 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -208,7 +208,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax hsc_src = ms_hsc_src mod_sum dflags = hsc_dflags hsc_env home_unit = hsc_home_unit hsc_env - err_msg = mkPlainErrMsg loc $ + err_msg = mkPlainMsgEnvelope loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 76856d7439..ead974bdcf 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -992,14 +992,14 @@ discardWarnings thing_inside ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (ErrMsg [SDoc]) +mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope [SDoc]) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongErrMsg loc printer msg' extra } + return $ mkLongMsgEnvelope loc printer msg' extra } -mkErrDocAt :: SrcSpan -> [SDoc] -> TcRn (ErrMsg [SDoc]) +mkErrDocAt :: SrcSpan -> [SDoc] -> TcRn (MsgEnvelope [SDoc]) mkErrDocAt loc errDoc = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; @@ -1011,24 +1011,24 @@ mkErrDocAt loc errDoc addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError -reportErrors :: [ErrMsg [SDoc]] -> TcM () +reportErrors :: [MsgEnvelope [SDoc]] -> TcM () reportErrors = mapM_ reportError -reportError :: ErrMsg [SDoc] -> TcRn () +reportError :: MsgEnvelope [SDoc] -> TcRn () reportError err - = do { traceTc "Adding error:" (pprLocErrMsg err) ; + = do { traceTc "Adding error:" (pprLocMsgEnvelope err) ; errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; writeTcRef errs_var (err `addMessage` msgs) } -reportWarning :: WarnReason -> ErrMsg [SDoc] -> TcRn () +reportWarning :: WarnReason -> MsgEnvelope [SDoc] -> TcRn () reportWarning reason err = do { let warn = makeIntoWarning reason err - -- 'err' was built by mkLongErrMsg or something like that, + -- 'err' was built by mkLongMsgEnvelope or something like that, -- so it's of error severity. For a warning we downgrade -- its severity to SevWarning - ; traceTc "Adding warning:" (pprLocErrMsg warn) + ; traceTc "Adding warning:" (pprLocMsgEnvelope warn) ; errs_var <- getErrsVar ; (warns, errs) <- partitionMessages <$> readTcRef errs_var ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) } diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 8b4f760cfc..75e7992348 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -12,7 +12,6 @@ module GHC.Types.Error , isEmptyMessages , addMessage , unionMessages - , ErrMsg (..) , MsgEnvelope (..) , WarnMsg , SDoc @@ -25,10 +24,10 @@ module GHC.Types.Error , getCaretDiagnostic , makeIntoWarning -- * Constructing individual errors - , mkErrMsg - , mkPlainErrMsg + , mkMsgEnvelope + , mkPlainMsgEnvelope , mkErr - , mkLongErrMsg + , mkLongMsgEnvelope , mkWarnMsg , mkPlainWarnMsg , mkLongWarnMsg @@ -66,7 +65,7 @@ The reason behind that is that there is a fluid relationship between errors and be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably -shouldn't belong to an 'ErrMsg' to begin with, as it might potentially lead to the construction of +shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of "impossible states" (e.g. a waning with 'SevInfo', for example). 'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but @@ -76,7 +75,7 @@ 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]. -newtype Messages e = Messages (Bag (ErrMsg e)) +newtype Messages e = Messages (Bag (MsgEnvelope e)) instance Functor Messages where fmap f (Messages xs) = Messages (mapBag (fmap f) xs) @@ -84,23 +83,34 @@ instance Functor Messages where emptyMessages :: Messages e emptyMessages = Messages emptyBag -mkMessages :: Bag (ErrMsg e) -> Messages e +mkMessages :: Bag (MsgEnvelope e) -> Messages e mkMessages = Messages isEmptyMessages :: Messages e -> Bool isEmptyMessages (Messages msgs) = isEmptyBag msgs -addMessage :: ErrMsg e -> Messages e -> Messages e +addMessage :: MsgEnvelope e -> Messages e -> Messages e addMessage x (Messages xs) = Messages (x `consBag` xs) -- | Joins two collections of messages together. unionMessages :: Messages e -> Messages e -> Messages e unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2) -type WarningMessages = Bag (ErrMsg [SDoc]) -type ErrorMessages = Bag (ErrMsg [SDoc]) +type WarningMessages = Bag (MsgEnvelope DecoratedSDoc) +type ErrorMessages = Bag (MsgEnvelope DecoratedSDoc) -type WarnMsg = ErrMsg [SDoc] +type WarnMsg = MsgEnvelope DecoratedSDoc + +-- | 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 {- Note [Rendering Messages] @@ -134,8 +144,13 @@ knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint. class RenderableDiagnostic a where renderDiagnostic :: a -> [SDoc] --- | The main 'GHC' error type, parameterised over the /domain-specific/ message. -data ErrMsg e = ErrMsg +-- | 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, its severity, 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 @@ -173,12 +188,12 @@ data Severity instance ToJson Severity where json s = JSString (show s) -instance Show (ErrMsg [SDoc]) where - show = showErrMsg +instance Show (MsgEnvelope [SDoc]) where + show = showMsgEnvelope --- | Shows an 'ErrMsg'. -showErrMsg :: RenderableDiagnostic a => ErrMsg a -> String -showErrMsg err = +-- | Shows an 'MsgEnvelope'. +showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String +showMsgEnvelope err = renderWithContext defaultSDocContext (vcat (renderDiagnostic $ errMsgDiagnostic err)) pprMessageBag :: Bag SDoc -> SDoc @@ -310,37 +325,37 @@ getCaretDiagnostic severity (RealSrcSpan span _) = | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -makeIntoWarning :: WarnReason -> ErrMsg e -> ErrMsg e +makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e makeIntoWarning reason err = err { errMsgSeverity = SevWarning , errMsgReason = reason } -- --- Creating ErrMsg(s) +-- Creating MsgEnvelope(s) -- mk_err_msg - :: Severity -> SrcSpan -> PrintUnqualified -> e -> ErrMsg e + :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e mk_err_msg sev locn print_unqual err - = ErrMsg { errMsgSpan = locn + = MsgEnvelope { errMsgSpan = locn , errMsgContext = print_unqual , errMsgDiagnostic = err , errMsgSeverity = sev , errMsgReason = NoReason } -mkErr :: SrcSpan -> PrintUnqualified -> e -> ErrMsg e +mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e mkErr = mk_err_msg SevError -mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> ErrMsg [SDoc] +mkLongMsgEnvelope, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope [SDoc] -- ^ A long (multi-line) error message -mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg [SDoc] +mkMsgEnvelope, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope [SDoc] -- ^ A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> SDoc -> ErrMsg [SDoc] +mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope [SDoc] -- ^ Variant that doesn't care about qualified/unqualified names -mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual [msg,extra] -mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual [msg] -mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify [msg] +mkLongMsgEnvelope locn unqual msg extra = mk_err_msg SevError locn unqual [msg,extra] +mkMsgEnvelope locn unqual msg = mk_err_msg SevError locn unqual [msg] +mkPlainMsgEnvelope locn msg = mk_err_msg SevError locn alwaysQualify [msg] mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual [msg,extra] mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual [msg] mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify [msg] @@ -349,22 +364,22 @@ mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify -- Queries -- -isErrorMessage :: ErrMsg e -> Bool +isErrorMessage :: MsgEnvelope e -> Bool isErrorMessage = (== SevError) . errMsgSeverity -isWarningMessage :: ErrMsg e -> Bool +isWarningMessage :: MsgEnvelope e -> Bool isWarningMessage = not . isErrorMessage errorsFound :: Messages e -> Bool errorsFound (Messages msgs) = any isErrorMessage msgs -getWarningMessages :: Messages e -> Bag (ErrMsg e) +getWarningMessages :: Messages e -> Bag (MsgEnvelope e) getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs -getErrorMessages :: Messages e -> Bag (ErrMsg e) +getErrorMessages :: Messages e -> Bag (MsgEnvelope e) getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs -- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the -- second the errors. -partitionMessages :: Messages e -> (Bag (ErrMsg e), Bag (ErrMsg e)) +partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) partitionMessages (Messages xs) = partitionBag isWarningMessage xs diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs index 640bae3dfc..6733f6665d 100644 --- a/compiler/GHC/Types/SourceError.hs +++ b/compiler/GHC/Types/SourceError.hs @@ -27,7 +27,7 @@ srcErrorMessages (SourceError msgs) = msgs throwErrors :: MonadIO io => ErrorMessages -> io a throwErrors = liftIO . throwIO . mkSrcErr -throwOneError :: MonadIO io => ErrMsg [SDoc] -> io a +throwOneError :: MonadIO io => MsgEnvelope [SDoc] -> io a throwOneError = throwErrors . unitBag -- | A source error is an error that is caused by one or more errors in the diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 05d98c9ed8..ed33c35551 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -14,21 +14,21 @@ module GHC.Utils.Error ( Severity(..), -- * Messages - ErrMsg(..), WarnMsg, + MsgEnvelope(..), SDoc, Messages, ErrorMessages, WarningMessages, unionMessages, errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprErrMsgBagWithLoc, - pprLocErrMsg, + pprMessageBag, pprMsgEnvelopeBagWithLoc, + pprLocMsgEnvelope, formatErrDoc, -- ** Construction emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, - mkErrMsg, mkPlainErrMsg, mkErr, mkLongErrMsg, mkWarnMsg, + mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg, mkPlainWarnMsg, mkLongWarnMsg, @@ -130,18 +130,18 @@ formatErrDoc ctx docs msgs = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) -pprErrMsgBagWithLoc :: Bag (ErrMsg [SDoc]) -> [SDoc] -pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] +pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope [SDoc]) -> [SDoc] +pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] -pprLocErrMsg :: RenderableDiagnostic e => ErrMsg e -> SDoc -pprLocErrMsg (ErrMsg { errMsgSpan = s - , errMsgDiagnostic = e - , errMsgSeverity = sev - , errMsgContext = unqual }) +pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc +pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s + , errMsgDiagnostic = e + , errMsgSeverity = sev + , errMsgContext = unqual }) = sdocWithContext $ \ctx -> withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx $ renderDiagnostic e) -sortMsgBag :: Maybe DynFlags -> Bag (ErrMsg e) -> [ErrMsg e] +sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList where cmp | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest diff --git a/utils/haddock b/utils/haddock index 1bdbf284b4..a917dfd29f 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit 1bdbf284b4ba20ee1738b13c4e3414384955f6f3 +Subproject commit a917dfd29f3103b69378138477514cbfa38558a9 -- cgit v1.2.1