summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC.hs2
-rw-r--r--compiler/GHC/Driver/Errors.hs4
-rw-r--r--compiler/GHC/Driver/Main.hs6
-rw-r--r--compiler/GHC/Driver/Make.hs2
-rw-r--r--compiler/GHC/HsToCore.hs4
-rw-r--r--compiler/GHC/HsToCore/Monad.hs12
-rw-r--r--compiler/GHC/HsToCore/Types.hs2
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs12
-rw-r--r--compiler/GHC/Parser/Header.hs2
-rw-r--r--compiler/GHC/Tc/Errors.hs60
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs2
-rw-r--r--compiler/GHC/Tc/Module.hs24
-rw-r--r--compiler/GHC/Tc/Types.hs2
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs6
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs40
-rw-r--r--compiler/GHC/Types/Error.hs40
-rw-r--r--compiler/GHC/Types/SourceError.hs2
-rw-r--r--compiler/GHC/Utils/Error.hs14
18 files changed, 125 insertions, 111 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 15257be0d1..5d8b295b95 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1474,7 +1474,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 [SDoc], Maybe (NameEnv ([ClsInst], [FamInst])))
+ -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex visible_mods mods_to_load = do
hsc_env <- getSession
liftIO $ runTcInteractive hsc_env $
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index a76df66291..43f3dc859b 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -9,7 +9,7 @@ module GHC.Driver.Errors (
import GHC.Driver.Session
import GHC.Data.Bag
import GHC.Utils.Exception
-import GHC.Utils.Error ( formatErrDoc, sortMsgBag )
+import GHC.Utils.Error ( formatBulleted, sortMsgBag )
import GHC.Types.SourceError ( mkSrcErr )
import GHC.Prelude
import GHC.Types.SrcLoc
@@ -33,7 +33,7 @@ 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))
+ withPprStyle style (formatBulleted ctx (renderDiagnostic doc))
| MsgEnvelope { errMsgSpan = s,
errMsgDiagnostic = doc,
errMsgSeverity = sev,
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index faa46b4850..4f7dcbcaea 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -321,7 +321,7 @@ 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 [SDoc], Maybe a) -> Hsc a
+ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe ioA = do
(msgs, mb_r) <- liftIO ioA
let (warns, errs) = partitionMessages msgs
@@ -332,7 +332,7 @@ ioMsgMaybe ioA = do
-- | like ioMsgMaybe, except that we ignore error messages and return
-- 'Nothing' instead.
-ioMsgMaybe' :: IO (Messages [SDoc], Maybe a) -> Hsc (Maybe a)
+ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' ioA = do
(msgs, mb_r) <- liftIO $ ioA
logWarnings (getWarningMessages msgs)
@@ -1134,7 +1134,7 @@ hscCheckSafeImports tcg_env = do
warns rules = listToBag $ map warnRules rules
- warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> MsgEnvelope [SDoc]
+ warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> MsgEnvelope DecoratedSDoc
warnRules (L loc (HsRule { rd_name = n })) =
mkPlainWarnMsg loc $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index e6dcfe9a29..571aada57f 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -2886,7 +2886,7 @@ withDeferredDiagnostics f = do
(\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)
(\_ -> f)
-noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope [SDoc]
+noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
-- ToDo: we don't have a proper line number for this error
noModError hsc_env loc wanted_mod err
= mkPlainMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 8f47cc1208..ba73a7bb59 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -100,7 +100,7 @@ import GHC.Driver.Plugins ( LoadedPlugin(..) )
-}
-- | Main entry point to the desugarer.
-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages [SDoc], Maybe ModGuts)
+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DecoratedSDoc, Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
deSugar hsc_env
@@ -283,7 +283,7 @@ So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.
-}
-deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages [SDoc], Maybe CoreExpr)
+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr)
deSugarExpr hsc_env tc_expr = do {
let dflags = hsc_dflags hsc_env
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index c989a29987..df4a377e39 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -213,7 +213,7 @@ initDsTc thing_inside
}
-- | Run a 'DsM' action inside the 'IO' monad.
-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages [SDoc], Maybe a)
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
initDs hsc_env tcg_env thing_inside
= do { msg_var <- newIORef emptyMessages
; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
@@ -222,7 +222,7 @@ initDs hsc_env tcg_env thing_inside
-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
mkDsEnvsFromTcGbl :: MonadIO m
- => HscEnv -> IORef (Messages [SDoc]) -> TcGblEnv
+ => HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
= do { cc_st_var <- liftIO $ newIORef newCostCentreState
@@ -239,7 +239,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
msg_var cc_st_var complete_matches
}
-runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages [SDoc], Maybe a)
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
runDs hsc_env (ds_gbl, ds_lcl) thing_inside
= do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
(tryM thing_inside)
@@ -252,7 +252,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 [SDoc], Maybe a)
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, 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
@@ -278,7 +278,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; runDs hsc_env envs thing_inside
}
-initTcDsForSolver :: TcM a -> DsM (Messages [SDoc], Maybe a)
+initTcDsForSolver :: TcM a -> DsM (Messages DecoratedSDoc, Maybe a)
-- Spin up a TcM context so that we can run the constraint solver
-- Returns any error messages generated by the constraint solver
-- and (Just res) if no error happened; Nothing if an error happened
@@ -309,7 +309,7 @@ initTcDsForSolver thing_inside
thing_inside }
mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
- -> IORef (Messages [SDoc]) -> IORef CostCentreState -> CompleteMatches
+ -> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
complete_matches
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index c971f927cf..60417e48a9 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -47,7 +47,7 @@ data DsGblEnv
-- constructors are in scope during
-- pattern-match satisfiability checking
, ds_unqual :: PrintUnqualified
- , ds_msgs :: IORef (Messages [SDoc]) -- Warning messages
+ , ds_msgs :: IORef (Messages DecoratedSDoc) -- Warning messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
, ds_complete_matches :: CompleteMatches
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index a923db2898..22103fa08b 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -24,25 +24,25 @@ import GHC.Hs.Type (pprLHsContext)
import GHC.Builtin.Names (allNameStrings)
import GHC.Builtin.Types (filterCTuple)
-mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope [SDoc]
+mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkParserErr span doc = MsgEnvelope
{ errMsgSpan = span
, errMsgContext = alwaysQualify
- , errMsgDiagnostic = [doc]
+ , errMsgDiagnostic = mkDecorated [doc]
, errMsgSeverity = SevError
, errMsgReason = NoReason
}
-mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope [SDoc]
+mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkParserWarn flag span doc = MsgEnvelope
{ errMsgSpan = span
, errMsgContext = alwaysQualify
- , errMsgDiagnostic = [doc]
+ , errMsgDiagnostic = mkDecorated [doc]
, errMsgSeverity = SevWarning
, errMsgReason = Reason flag
}
-pprWarning :: PsWarning -> MsgEnvelope [SDoc]
+pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc
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 -> MsgEnvelope [SDoc]
+pprError :: PsError -> MsgEnvelope DecoratedSDoc
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 0af7a555d5..5d911a0b56 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -348,7 +348,7 @@ unsupportedExtnError dflags loc unsup =
suggestions = fuzzyMatch unsup supported
-optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages [SDoc]
+optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc
optionsErrorMsgs unhandled_flags flags_lines _filename
= mkMessages $ listToBag (map mkMsg unhandled_flags_lines)
where unhandled_flags_lines :: [Located String]
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 8d8676bef2..0e687040e0 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -56,7 +56,7 @@ import GHC.Types.Error
import GHC.Core.ConLike ( ConLike(..))
import GHC.Utils.Misc
import GHC.Data.FastString
-import GHC.Utils.Outputable
+import GHC.Utils.Outputable as O
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Driver.Session
@@ -750,7 +750,7 @@ mkUserTypeErrorReporter ctxt
; maybeReportError ctxt err
; addDeferredBinding ctxt err ct }
-mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope [SDoc])
+mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc)
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 (MsgEnvelope [SDoc]))
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc))
-- 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 (MsgEnvelope [SDoc])) -> Reporter
+mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> 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 (MsgEnvelope [SDoc])) -> Reporter
+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> 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 (MsgEnvelope [SDoc])) -> Reporter
+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> 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 -> MsgEnvelope [SDoc] -> TcM ()
+maybeReportHoleError :: ReportErrCtxt -> Hole -> MsgEnvelope DecoratedSDoc -> 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 -> MsgEnvelope [SDoc] -> TcM ()
+maybeReportError :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> 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 -> MsgEnvelope [SDoc] -> Ct -> TcM ()
+addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> 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
- -> MsgEnvelope [SDoc] -> EvTerm
+ -> MsgEnvelope DecoratedSDoc -> EvTerm
mkErrorTerm dflags ty err = evDelayedError ty err_fs
where
err_msg = pprLocMsgEnvelope err
err_fs = mkFastString $ showSDoc dflags $
err_msg $$ text "(deferred type error)"
-maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope [SDoc] -> Hole -> TcM ()
+maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> 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,15 +1048,17 @@ pprWithArising (ct:cts)
ppr_one ct' = hang (parens (pprType (ctPred ct')))
2 (pprCtLoc (ctLoc ct'))
-mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope [SDoc])
+mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DecoratedSDoc)
mkErrorMsgFromCt ctxt ct report
= mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report
-mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope [SDoc])
+mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope DecoratedSDoc)
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)
- [vcat important, context, vcat (relevant_bindings ++ valid_subs)]
+ ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing)
+ (vcat important)
+ context
+ (vcat $ relevant_bindings ++ valid_subs)
}
type UserGiven = Implication
@@ -1153,7 +1155,7 @@ solve it.
************************************************************************
-}
-mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc])
+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)
mkIrredErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
@@ -1164,7 +1166,7 @@ mkIrredErr ctxt cts
(ct1:_) = cts
----------------
-mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope [SDoc])
+mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc)
mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ
, hole_ty = hole_ty
, hole_loc = ct_loc })
@@ -1174,10 +1176,10 @@ mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ
; imp_info <- getImports
; curr_mod <- getModule
; hpt <- getHpt
- ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $
- [out_of_scope_msg,
- (unknownNameSuggestions dflags hpt curr_mod rdr_env
- (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))] }
+ ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing)
+ out_of_scope_msg O.empty
+ (unknownNameSuggestions dflags hpt curr_mod rdr_env
+ (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) }
where
herald | isDataOcc occ = text "Data constructor not in scope:"
| otherwise = text "Variable not in scope:"
@@ -1305,7 +1307,7 @@ givenConstraintsMsg ctxt =
2 (vcat $ map pprConstraint constraints)
----------------
-mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc])
+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)
mkIPErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
@@ -1382,11 +1384,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 (MsgEnvelope [SDoc])
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)
mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
mkEqErr _ [] = panic "mkEqErr"
-mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope [SDoc])
+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc)
mkEqErr1 ctxt ct -- Wanted or derived;
-- givens handled in mkGivenErrorReporter
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
@@ -1452,7 +1454,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
-> Ct
- -> TcType -> TcType -> TcM (MsgEnvelope [SDoc])
+ -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc)
mkEqErr_help dflags ctxt report ct ty1 ty2
| Just (tv1, _) <- tcGetCastedTyVar_maybe ty1
= mkTyVarEqErr dflags ctxt report ct tv1 ty2
@@ -1463,7 +1465,7 @@ mkEqErr_help dflags ctxt report ct ty1 ty2
reportEqErr :: ReportErrCtxt -> Report
-> Ct
- -> TcType -> TcType -> TcM (MsgEnvelope [SDoc])
+ -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc)
reportEqErr ctxt report ct ty1 ty2
= mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])
where
@@ -1472,7 +1474,7 @@ reportEqErr ctxt report ct ty1 ty2
mkTyVarEqErr, mkTyVarEqErr'
:: DynFlags -> ReportErrCtxt -> Report -> Ct
- -> TcTyVar -> TcType -> TcM (MsgEnvelope [SDoc])
+ -> TcTyVar -> TcType -> TcM (MsgEnvelope DecoratedSDoc)
-- tv1 and ty2 are already tidied
mkTyVarEqErr dflags ctxt report ct tv1 ty2
= do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
@@ -1672,7 +1674,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 (MsgEnvelope [SDoc])
+mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)
mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report
where
report = important msg
@@ -2279,7 +2281,7 @@ Warn of loopy local equalities that were dropped.
************************************************************************
-}
-mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope [SDoc])
+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)
mkDictErr ctxt cts
= ASSERT( not (null cts) )
do { inst_envs <- tcGetInstEnvs
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 346000975a..4e26509606 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1285,7 +1285,7 @@ runTH ty fhv = do
-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
runRemoteTH
:: IServInstance
- -> [Messages [SDoc]] -- saved from nested calls to qRecover
+ -> [Messages DecoratedSDoc] -- 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 5f55d3a45a..75a5bda5fe 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -188,7 +188,7 @@ tcRnModule :: HscEnv
-> ModSummary
-> Bool -- True <=> save renamed syntax
-> HsParsedModule
- -> IO (Messages [SDoc], Maybe TcGblEnv)
+ -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)
tcRnModule hsc_env mod_sum save_rn_syntax
parsedModule@HsParsedModule {hpm_module= L loc this_module}
@@ -1986,7 +1986,7 @@ this Note.
*********************************************************
-}
-runTcInteractive :: HscEnv -> TcRn a -> IO (Messages [SDoc], Maybe a)
+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, 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
@@ -2102,7 +2102,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 [SDoc], Maybe ([Id], LHsExpr GhcTc, FixityEnv))
+ -> IO (Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt hsc_env rdr_stmt
= runTcInteractive hsc_env $ do {
@@ -2482,7 +2482,7 @@ getGhciStepIO = do
return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
-isGHCiMonad :: HscEnv -> String -> IO (Messages [SDoc], Maybe Name)
+isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name)
isGHCiMonad hsc_env ty
= runTcInteractive hsc_env $ do
rdrEnv <- getGlobalRdrEnv
@@ -2509,7 +2509,7 @@ data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:typ
tcRnExpr :: HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
- -> IO (Messages [SDoc], Maybe Type)
+ -> IO (Messages DecoratedSDoc, Maybe Type)
tcRnExpr hsc_env mode rdr_expr
= runTcInteractive hsc_env $
do {
@@ -2578,7 +2578,7 @@ has a special case for application chains.
--------------------------
tcRnImportDecls :: HscEnv
-> [LImportDecl GhcPs]
- -> IO (Messages [SDoc], Maybe GlobalRdrEnv)
+ -> IO (Messages DecoratedSDoc, 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
@@ -2594,7 +2594,7 @@ tcRnType :: HscEnv
-> ZonkFlexi
-> Bool -- Normalise the returned type
-> LHsType GhcPs
- -> IO (Messages [SDoc], Maybe (Type, Kind))
+ -> IO (Messages DecoratedSDoc, Maybe (Type, Kind))
tcRnType hsc_env flexi normalise rdr_type
= runTcInteractive hsc_env $
setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType]
@@ -2728,7 +2728,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
tcRnDeclsi :: HscEnv
-> [LHsDecl GhcPs]
- -> IO (Messages [SDoc], Maybe TcGblEnv)
+ -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)
tcRnDeclsi hsc_env local_decls
= runTcInteractive hsc_env $
tcRnSrcDecls False local_decls Nothing
@@ -2753,13 +2753,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 [SDoc], Maybe ModIface)
+getModuleInterface :: HscEnv -> Module -> IO (Messages DecoratedSDoc, Maybe ModIface)
getModuleInterface hsc_env mod
= runTcInteractive hsc_env $
loadModuleInterface (text "getModuleInterface") mod
tcRnLookupRdrName :: HscEnv -> Located RdrName
- -> IO (Messages [SDoc], Maybe [Name])
+ -> IO (Messages DecoratedSDoc, Maybe [Name])
-- ^ Find all the Names that this RdrName could mean, in GHCi
tcRnLookupRdrName hsc_env (L loc rdr_name)
= runTcInteractive hsc_env $
@@ -2773,7 +2773,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 [SDoc], Maybe TyThing)
+tcRnLookupName :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe TyThing)
tcRnLookupName hsc_env name
= runTcInteractive hsc_env $
tcRnLookupName' name
@@ -2792,7 +2792,7 @@ tcRnLookupName' name = do
tcRnGetInfo :: HscEnv
-> Name
- -> IO ( Messages [SDoc]
+ -> IO ( Messages DecoratedSDoc
, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-- Used to implement :info in GHCi
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 4995e6702e..c7a78901f4 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -748,7 +748,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 [SDoc]) -- Place to accumulate errors
+ tcl_errs :: TcRef (Messages DecoratedSDoc) -- Place to accumulate errors
}
setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 9e9f01aa0b..9a38a9c5be 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -361,7 +361,7 @@ checkUnit (VirtUnit indef) = do
-- an @hsig@ file.)
tcRnCheckUnit ::
HscEnv -> Unit ->
- IO (Messages [SDoc], Maybe ())
+ IO (Messages DecoratedSDoc, Maybe ())
tcRnCheckUnit hsc_env uid =
withTiming dflags
(text "Check unit id" <+> ppr uid)
@@ -381,7 +381,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 [SDoc], Maybe TcGblEnv)
+ -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)
tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
withTiming dflags
(text "Signature merging" <+> brackets (ppr this_mod))
@@ -912,7 +912,7 @@ mergeSignatures
-- an @hsig@ file.)
tcRnInstantiateSignature ::
HscEnv -> Module -> RealSrcSpan ->
- IO (Messages [SDoc], Maybe TcGblEnv)
+ IO (Messages DecoratedSDoc, Maybe TcGblEnv)
tcRnInstantiateSignature hsc_env this_mod real_loc =
withTiming 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 ead974bdcf..c92da610fb 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -75,7 +75,7 @@ module GHC.Tc.Utils.Monad(
tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
-- * Shared error message stuff: renamer and typechecker
- mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
+ mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError,
reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
attemptM, tryTc,
askNoErrs, discardErrs, tryTcDiscardingErrs,
@@ -231,7 +231,7 @@ initTc :: HscEnv
-> Module
-> RealSrcSpan
-> TcM r
- -> IO (Messages [SDoc], Maybe r)
+ -> IO (Messages DecoratedSDoc, Maybe r)
-- Nothing => error thrown by the thing inside
-- (error messages should have been printed already)
@@ -353,7 +353,7 @@ initTcWithGbl :: HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
- -> IO (Messages [SDoc], Maybe r)
+ -> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl hsc_env gbl_env loc do_this
= do { lie_var <- newIORef emptyWC
; errs_var <- newIORef emptyMessages
@@ -399,7 +399,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
; return (msgs, final_res)
}
-initTcInteractive :: HscEnv -> TcM a -> IO (Messages [SDoc], Maybe a)
+initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
-- Initialise the type checker monad for use in GHCi
initTcInteractive hsc_env thing_inside
= initTc hsc_env HsSrcFile False
@@ -930,10 +930,10 @@ wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)
-- Reporting errors
-getErrsVar :: TcRn (TcRef (Messages [SDoc]))
+getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc))
getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
-setErrsVar :: TcRef (Messages [SDoc]) -> TcRn a -> TcRn a
+setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
addErr :: SDoc -> TcRn ()
@@ -963,7 +963,7 @@ checkErr :: Bool -> SDoc -> TcRn ()
-- Add the error if the bool is False
checkErr ok msg = unless ok (addErr msg)
-addMessages :: Messages [SDoc] -> TcRn ()
+addMessages :: Messages DecoratedSDoc -> TcRn ()
addMessages msgs1
= do { errs_var <- getErrsVar ;
msgs0 <- readTcRef errs_var ;
@@ -992,36 +992,44 @@ discardWarnings thing_inside
************************************************************************
-}
-mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope [SDoc])
+mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)
mkLongErrAt loc msg extra
= do { printer <- getPrintUnqualified ;
unit_state <- hsc_units <$> getTopEnv ;
let msg' = pprWithUnitState unit_state msg in
return $ mkLongMsgEnvelope loc printer msg' extra }
-mkErrDocAt :: SrcSpan -> [SDoc] -> TcRn (MsgEnvelope [SDoc])
-mkErrDocAt loc errDoc
+mkDecoratedSDocAt :: SrcSpan
+ -> SDoc
+ -- ^ The important part of the message
+ -> SDoc
+ -- ^ The context of the message
+ -> SDoc
+ -- ^ Any supplementary information.
+ -> TcRn (MsgEnvelope DecoratedSDoc)
+mkDecoratedSDocAt loc important context extra
= do { printer <- getPrintUnqualified ;
unit_state <- hsc_units <$> getTopEnv ;
let f = pprWithUnitState unit_state
- errDoc' = map f errDoc
+ errDoc = [important, context, extra]
+ errDoc' = mkDecorated $ map f errDoc
in
return $ mkErr loc printer errDoc' }
addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
-reportErrors :: [MsgEnvelope [SDoc]] -> TcM ()
+reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM ()
reportErrors = mapM_ reportError
-reportError :: MsgEnvelope [SDoc] -> TcRn ()
+reportError :: MsgEnvelope DecoratedSDoc -> TcRn ()
reportError err
= do { traceTc "Adding error:" (pprLocMsgEnvelope err) ;
errs_var <- getErrsVar ;
msgs <- readTcRef errs_var ;
writeTcRef errs_var (err `addMessage` msgs) }
-reportWarning :: WarnReason -> MsgEnvelope [SDoc] -> TcRn ()
+reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn ()
reportWarning reason err
= do { let warn = makeIntoWarning reason err
-- 'err' was built by mkLongMsgEnvelope or something like that,
@@ -1191,7 +1199,7 @@ capture_constraints thing_inside
; lie <- readTcRef lie_var
; return (res, lie) }
-capture_messages :: TcM r -> TcM (r, Messages [SDoc])
+capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc)
-- capture_messages simply captures and returns the
-- errors arnd warnings generated by thing_inside
-- Precondition: thing_inside must not throw an exception!
@@ -1361,7 +1369,7 @@ foldAndRecoverM f acc (x:xs) =
Just acc' -> foldAndRecoverM f acc' xs }
-----------------------
-tryTc :: TcRn a -> TcRn (Maybe a, Messages [SDoc])
+tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)
-- (tryTc m) executes m, and returns
-- Just r, if m succeeds (returning r)
-- Nothing, if m fails
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 75e7992348..84d4e892c3 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -15,9 +15,11 @@ module GHC.Types.Error
, MsgEnvelope (..)
, WarnMsg
, SDoc
+ , DecoratedSDoc (unDecorated)
, Severity (..)
, RenderableDiagnostic (..)
, pprMessageBag
+ , mkDecorated
, mkLocMessage
, mkLocMessageAnn
, getSeverityColour
@@ -131,7 +133,7 @@ We could then define how a 'TcRnMessage' is displayed to the user. Rather than s
instance RenderableDiagnostic TcRnMessage where
renderDiagnostic = \case
- TcRnOutOfScope .. -> ErrDoc [text "Out of scope error ..."] [] []
+ 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
@@ -139,10 +141,10 @@ knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint.
-}
--- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'ErrDoc'.
+-- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'.
-- For more information, see Note [Rendering Messages].
class RenderableDiagnostic a where
- renderDiagnostic :: a -> [SDoc]
+ renderDiagnostic :: a -> DecoratedSDoc
-- | An envelope for GHC's facts about a running program, parameterised over the
-- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.
@@ -159,7 +161,7 @@ data MsgEnvelope e = MsgEnvelope
, errMsgReason :: WarnReason
} deriving Functor
-instance RenderableDiagnostic [SDoc] where
+instance RenderableDiagnostic DecoratedSDoc where
renderDiagnostic = id
data Severity
@@ -188,13 +190,13 @@ data Severity
instance ToJson Severity where
json s = JSString (show s)
-instance Show (MsgEnvelope [SDoc]) where
+instance Show (MsgEnvelope DecoratedSDoc) where
show = showMsgEnvelope
-- | Shows an 'MsgEnvelope'.
showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope err =
- renderWithContext defaultSDocContext (vcat (renderDiagnostic $ errMsgDiagnostic err))
+ renderWithContext defaultSDocContext (vcat (unDecorated . renderDiagnostic $ errMsgDiagnostic err))
pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
@@ -338,27 +340,27 @@ mk_err_msg
:: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg sev locn print_unqual err
= MsgEnvelope { errMsgSpan = locn
- , errMsgContext = print_unqual
- , errMsgDiagnostic = err
- , errMsgSeverity = sev
- , errMsgReason = NoReason }
+ , errMsgContext = print_unqual
+ , errMsgDiagnostic = err
+ , errMsgSeverity = sev
+ , errMsgReason = NoReason }
mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErr = mk_err_msg SevError
-mkLongMsgEnvelope, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope [SDoc]
+mkLongMsgEnvelope, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
-- ^ A long (multi-line) error message
-mkMsgEnvelope, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope [SDoc]
+mkMsgEnvelope, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
-- ^ A short (one-line) error message
-mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope [SDoc]
+mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
-- ^ Variant that doesn't care about qualified/unqualified names
-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]
+mkLongMsgEnvelope locn unqual msg extra = mk_err_msg SevError locn unqual (mkDecorated [msg,extra])
+mkMsgEnvelope locn unqual msg = mk_err_msg SevError locn unqual (mkDecorated [msg])
+mkPlainMsgEnvelope locn msg = mk_err_msg SevError locn alwaysQualify (mkDecorated [msg])
+mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (mkDecorated [msg,extra])
+mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (mkDecorated [msg])
+mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (mkDecorated [msg])
--
-- Queries
diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs
index 6733f6665d..a8c4733420 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 => MsgEnvelope [SDoc] -> io a
+throwOneError :: MonadIO io => MsgEnvelope DecoratedSDoc -> 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 ed33c35551..d81577cb0b 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
{-
(c) The AQUA Project, Glasgow University, 1994-1998
@@ -17,6 +18,7 @@ module GHC.Utils.Error (
WarnMsg,
MsgEnvelope(..),
SDoc,
+ DecoratedSDoc(unDecorated),
Messages, ErrorMessages, WarningMessages,
unionMessages,
errorsFound, isEmptyMessages,
@@ -24,10 +26,10 @@ module GHC.Utils.Error (
-- ** Formatting
pprMessageBag, pprMsgEnvelopeBagWithLoc,
pprLocMsgEnvelope,
- formatErrDoc,
+ formatBulleted,
-- ** Construction
- emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
+ emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg,
mkPlainWarnMsg,
mkLongWarnMsg,
@@ -120,8 +122,8 @@ orValid _ v = v
----------------
-- | Formats the input list of structured document, where each element of the list gets a bullet.
-formatErrDoc :: SDocContext -> [SDoc] -> SDoc
-formatErrDoc ctx docs
+formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc
+formatBulleted ctx (unDecorated -> docs)
= case msgs of
[] -> Outputable.empty
[msg] -> msg
@@ -130,7 +132,7 @@ formatErrDoc ctx docs
msgs = filter (not . Outputable.isEmpty ctx) docs
starred = (bullet<+>)
-pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope [SDoc]) -> [SDoc]
+pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ]
pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc
@@ -139,7 +141,7 @@ pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s
, errMsgSeverity = sev
, errMsgContext = unqual })
= sdocWithContext $ \ctx ->
- withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx $ renderDiagnostic e)
+ withErrStyle unqual $ mkLocMessage sev s (formatBulleted ctx $ renderDiagnostic e)
sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
View Lorry Controller Status