summaryrefslogtreecommitdiff
path: root/compiler/GHC/Rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Rename')
-rw-r--r--compiler/GHC/Rename/Bind.hs52
-rw-r--r--compiler/GHC/Rename/Env.hs51
-rw-r--r--compiler/GHC/Rename/Expr.hs46
-rw-r--r--compiler/GHC/Rename/HsType.hs67
-rw-r--r--compiler/GHC/Rename/Module.hs136
-rw-r--r--compiler/GHC/Rename/Names.hs87
-rw-r--r--compiler/GHC/Rename/Pat.hs44
-rw-r--r--compiler/GHC/Rename/Splice.hs33
-rw-r--r--compiler/GHC/Rename/Unbound.hs6
-rw-r--r--compiler/GHC/Rename/Utils.hs68
10 files changed, 361 insertions, 229 deletions
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 609ab180f9..79b0a5661a 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -49,6 +49,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Driver.Session
import GHC.Unit.Module
+import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Name
import GHC.Types.Name.Env
@@ -453,9 +454,10 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
; name <- applyNameMaker name_maker rdrname
; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
where
- localPatternSynonymErr :: SDoc
+ localPatternSynonymErr :: TcRnMessage
localPatternSynonymErr
- = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))
2 (text "Pattern synonym declarations are only valid at top level")
rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
@@ -663,9 +665,10 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
; return env}
}
-dupFixityDecl :: SrcSpan -> RdrName -> SDoc
+dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage
dupFixityDecl loc rdr_name
- = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),
text "also at " <+> ppr loc]
@@ -753,9 +756,10 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
-- See Note [Renaming pattern synonym variables]
lookupPatSynBndr = wrapLocMA lookupLocalOccRn
- patternSynonymErr :: SDoc
+ patternSynonymErr :: TcRnMessage
patternSynonymErr
- = hang (text "Illegal pattern synonym declaration")
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal pattern synonym declaration")
2 (text "Use -XPatternSynonyms to enable this extension")
{-
@@ -910,7 +914,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
-- Report error for all other forms of bindings
-- This is why we use a fold rather than map
rnMethodBindLHS is_cls_decl _ (L loc bind) rest
- = do { addErrAt (locA loc) $
+ = do { addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
vcat [ what <+> text "not allowed in" <+> decl_sort
, nest 2 (ppr bind) ]
; return rest }
@@ -1056,8 +1060,8 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs)
where
- orphanError :: SDoc
- orphanError =
+ orphanError :: TcRnMessage
+ orphanError = TcRnUnknownMessage $ mkPlainError noHints $
text "Orphan COMPLETE pragmas not supported" $$
text "A COMPLETE pragma must mention at least one data constructor" $$
text "or pattern synonym defined in the same module."
@@ -1217,9 +1221,10 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats'
, m_grhss = grhss'}, grhss_fvs ) }
-emptyCaseErr :: HsMatchContext GhcRn -> SDoc
-emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
- 2 (text "Use EmptyCase to allow this")
+emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage
+emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Empty list of alternatives in" <+> pp_ctxt)
+ 2 (text "Use EmptyCase to allow this")
where
pp_ctxt = case ctxt of
CaseAlt -> text "case expression"
@@ -1260,8 +1265,10 @@ rnGRHS' ctxt rnBody (GRHS _ guards rhs)
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ ->
rnBody rhs
- ; unless (pattern_guards_allowed || is_standard_guard guards')
- (addDiagnostic WarningWithoutFlag (nonStdGuardErr guards'))
+ ; unless (pattern_guards_allowed || is_standard_guard guards') $
+ let diag = TcRnUnknownMessage $
+ mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards')
+ in addDiagnostic diag
; return (GRHS noAnn guards' rhs', fvs) }
where
@@ -1314,7 +1321,7 @@ rnSrcFixityDecl sig_ctxt = rn_decl
dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM ()
dupSigDeclErr pairs@((L loc name, sig) :| _)
- = addErrAt (locA loc) $
+ = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
vcat [ text "Duplicate" <+> what_it_is
<> text "s for" <+> quotes (ppr name)
, text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest
@@ -1326,17 +1333,18 @@ dupSigDeclErr pairs@((L loc name, sig) :| _)
misplacedSigErr :: LSig GhcRn -> RnM ()
misplacedSigErr (L loc sig)
- = addErrAt (locA loc) $
+ = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
-defaultSigErr :: Sig GhcPs -> SDoc
-defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")
- 2 (ppr sig)
- , text "Use DefaultSignatures to enable default signatures" ]
+defaultSigErr :: Sig GhcPs -> TcRnMessage
+defaultSigErr sig = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [ hang (text "Unexpected default signature:")
+ 2 (ppr sig)
+ , text "Use DefaultSignatures to enable default signatures" ]
bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM ()
bindInHsBootFileErr (L loc _)
- = addErrAt (locA loc) $
+ = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
vcat [ text "Bindings in hs-boot files are not allowed" ]
nonStdGuardErr :: (Outputable body,
@@ -1348,7 +1356,7 @@ nonStdGuardErr guards
dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
dupMinimalSigErr sigs@(L loc _ : _)
- = addErrAt (locA loc) $
+ = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
vcat [ text "Multiple minimal complete definitions"
, text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs)
, text "Combine alternative minimal complete definitions with `|'" ]
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index ba9a851171..f742e60311 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -64,6 +64,7 @@ import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe )
import GHC.Iface.Env
import GHC.Hs
import GHC.Types.Name.Reader
+import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Parser.PostProcess ( setRdrNameSpace )
@@ -72,6 +73,7 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Avail
+import GHC.Types.Error
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg )
@@ -389,7 +391,8 @@ lookupInstDeclBndr cls what rdr
-- when it's used
cls doc rdr
; case mb_name of
- Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }
+ Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err)
+ ; return (mkUnboundNameRdr rdr) }
Right nm -> return nm }
where
doc = what <+> text "of class" <+> quotes (ppr cls)
@@ -436,7 +439,7 @@ lookupExactOrOrig rdr_name res k
; case men of
FoundExactOrOrig n -> return (res n)
ExactOrOrigError e ->
- do { addErr e
+ do { addErr (TcRnUnknownMessage $ mkPlainError noHints e)
; return (res (mkUnboundNameRdr rdr_name)) }
NotExactOrOrig -> k }
@@ -1088,9 +1091,11 @@ lookup_demoted rdr_name
; case mb_demoted_name of
Nothing -> unboundNameX looking_for rdr_name star_info
Just demoted_name ->
- do { addDiagnostic
- (WarningWithFlag Opt_WarnUntickedPromotedConstructors)
- (untickedPromConstrWarn demoted_name)
+ do { let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnUntickedPromotedConstructors)
+ noHints
+ (untickedPromConstrWarn demoted_name)
+ ; addDiagnostic msg
; return demoted_name } }
else do { -- We need to check if a data constructor of this name is
-- in scope to give good error messages. However, we do
@@ -1129,8 +1134,9 @@ lookup_promoted rdr_name
badVarInType :: RdrName -> RnM Name
badVarInType rdr_name
- = do { addErr (text "Illegal promoted term variable in a type:"
- <+> ppr rdr_name)
+ = do { addErr (TcRnUnknownMessage $ mkPlainError noHints
+ (text "Illegal promoted term variable in a type:"
+ <+> ppr rdr_name))
; return (mkUnboundNameRdr rdr_name) }
{- Note [Promoted variables in types]
@@ -1570,8 +1576,13 @@ warnIfDeprecated gre@(GRE { gre_imp = iss })
-- See Note [Handling of deprecations]
do { iface <- loadInterfaceForName doc name
; case lookupImpDeprec iface gre of
- Just txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
- (mk_msg imp_spec txt)
+ Just txt -> do
+ let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
+ noHints
+ (mk_msg imp_spec txt)
+
+ addDiagnostic msg
Nothing -> return () } }
| otherwise
= return ()
@@ -1809,7 +1820,8 @@ lookupSigCtxtOccRnN ctxt what
= wrapLocMA $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
; case mb_name of
- Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
+ Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err)
+ ; return (mkUnboundNameRdr rdr_name) }
Right name -> return name }
-- | Lookup a name in relation to the names in a 'HsSigCtxt'
@@ -1821,7 +1833,8 @@ lookupSigCtxtOccRn ctxt what
= wrapLocMA $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
; case mb_name of
- Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
+ Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err)
+ ; return (mkUnboundNameRdr rdr_name) }
Right name -> return name }
lookupBindGroupOcc :: HsSigCtxt
@@ -1923,7 +1936,8 @@ lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
lookupLocalTcNames ctxt what rdr_name
= do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
; let (errs, names) = partitionEithers mb_gres
- ; when (null names) $ addErr (head errs) -- Bleat about one only
+ ; when (null names) $
+ addErr (TcRnUnknownMessage $ mkPlainError noHints (head errs)) -- Bleat about one only
; return names }
where
lookup rdr = do { this_mod <- getModule
@@ -2115,19 +2129,20 @@ lookupQualifiedDoName ctxt std_name
-- Error messages
-opDeclErr :: RdrName -> SDoc
+opDeclErr :: RdrName -> TcRnMessage
opDeclErr n
- = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
2 (text "Use TypeOperators to declare operators in type and declarations")
-badOrigBinding :: RdrName -> SDoc
+badOrigBinding :: RdrName -> TcRnMessage
badOrigBinding name
| Just _ <- isBuiltInOcc_maybe occ
- = text "Illegal binding of built-in syntax:" <+> ppr occ
+ = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal binding of built-in syntax:" <+> ppr occ
-- Use an OccName here because we don't want to print Prelude.(,)
| otherwise
- = text "Cannot redefine a Name retrieved by a Template Haskell quote:"
- <+> ppr name
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name
-- This can happen when one tries to use a Template Haskell splice to
-- define a top-level identifier with an already existing name, e.g.,
--
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index d6805c2b05..ee81957015 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -30,6 +30,7 @@ import GHC.Prelude
import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
, rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import GHC.Hs
+import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env ( isBrackStage )
import GHC.Tc.Utils.Monad
import GHC.Unit.Module ( getModule )
@@ -437,11 +438,13 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
}
Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.
do { ; unlessXOptM LangExt.RebindableSyntax $
- addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."
; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]
; punsEnabled <-xoptM LangExt.RecordPuns
; unless (null punnedFields || punsEnabled) $
- addErr $ text "For this to work enable NamedFieldPuns."
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ text "For this to work enable NamedFieldPuns."
; (getField, fv_getField) <- lookupSyntaxName getFieldName
; (setField, fv_setField) <- lookupSyntaxName setFieldName
; (e, fv_e) <- rnLExpr expr
@@ -516,12 +519,13 @@ rnExpr e@(HsStatic _ expr) = do
-- absolutely prepared to cope with static forms, we check for
-- -XStaticPointers here as well.
unlessXOptM LangExt.StaticPointers $
- addErr $ hang (text "Illegal static expression:" <+> ppr e)
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal static expression:" <+> ppr e)
2 (text "Use StaticPointers to enable this extension")
(expr',fvExpr) <- rnLExpr expr
stage <- getStage
case stage of
- Splice _ -> addErr $ sep
+ Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep
[ text "static forms cannot be used in splices:"
, nest 2 $ ppr e
]
@@ -1264,7 +1268,8 @@ rnParallelStmts ctxt return_op segs thing_inside
; return ((seg':segs', thing), fvs) }
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
- dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
+ dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (text "Duplicate binding in parallel list comprehension for:"
<+> quotes (ppr (NE.head vs)))
lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
@@ -2315,10 +2320,13 @@ okEmpty :: HsStmtContext a -> Bool
okEmpty (PatGuard {}) = True
okEmpty _ = False
-emptyErr :: HsStmtContext GhcRn -> SDoc
-emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension"
-emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
-emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
+emptyErr :: HsStmtContext GhcRn -> TcRnMessage
+emptyErr (ParStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Empty statement group in parallel comprehension"
+emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Empty statement group preceding 'group' or 'then'"
+emptyErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Empty" <+> pprStmtContext ctxt
----------------------
checkLastStmt :: AnnoBody body => HsStmtContext GhcRn
@@ -2338,7 +2346,9 @@ checkLastStmt ctxt lstmt@(L loc stmt)
BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
-- LastStmt directly (unlike the parser)
- _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
+ _ -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (hang last_error 2 (ppr stmt))
+ ; return lstmt }
last_error = (text "The last statement in" <+> pprAStmtContext ctxt
<+> text "must be an expression")
@@ -2358,7 +2368,7 @@ checkStmt ctxt (L _ stmt)
= do { dflags <- getDynFlags
; case okStmt dflags ctxt stmt of
IsValid -> return ()
- NotValid extra -> addErr (msg $$ extra) }
+ NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) }
where
msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"
, text "in" <+> pprAStmtContext ctxt ]
@@ -2444,17 +2454,21 @@ checkTupleSection args
= do { tuple_section <- xoptM LangExt.TupleSections
; checkErr (all tupArgPresent args || tuple_section) msg }
where
- msg = text "Illegal tuple section: use TupleSections"
+ msg :: TcRnMessage
+ msg = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Illegal tuple section: use TupleSections"
---------
-sectionErr :: HsExpr GhcPs -> SDoc
+sectionErr :: HsExpr GhcPs -> TcRnMessage
sectionErr expr
- = hang (text "A section must be enclosed in parentheses")
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "A section must be enclosed in parentheses")
2 (text "thus:" <+> (parens (ppr expr)))
-badIpBinds :: Outputable a => SDoc -> a -> SDoc
+badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage
badIpBinds what binds
- = hang (text "Implicit-parameter bindings illegal in" <+> what)
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Implicit-parameter bindings illegal in" <+> what)
2 (ppr binds)
---------
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index d26a886d11..674cfe6198 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -55,6 +55,7 @@ import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext
import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
, lookupTyFixityRn )
import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
+import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Types.Name.Reader
import GHC.Builtin.Names
@@ -62,6 +63,7 @@ import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Name.Set
import GHC.Types.FieldLabel
+import GHC.Types.Error
import GHC.Utils.Misc
import GHC.Types.Fixity ( compareFixity, negateFixity
@@ -208,7 +210,7 @@ rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of
-- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided,
-- so we currently reject.
when (not (null varsInScope)) $
- addErr $
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
vcat
[ text "Type variable" <> plural varsInScope
<+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope))
@@ -444,8 +446,11 @@ rnImplicitTvBndrs :: HsDocContext
rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside
= do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case
(x :| []) -> return x
- (x :| _) -> do addErr $ text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."
- return x
+ (x :| _) -> do
+ let msg = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."
+ addErr msg
+ return x
; traceRn "rnImplicitTvBndrs" $
vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]
@@ -618,7 +623,7 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
= do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
- unlessXOptM LangExt.PolyKinds $ addErr $
+ unlessXOptM LangExt.PolyKinds $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
withHsDocContext (rtke_ctxt env) $
vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
, text "Perhaps you intended to use PolyKinds" ]
@@ -653,8 +658,8 @@ rnHsTyKi env ty@(HsRecTy _ flds)
get_fields (ConDeclCtx names)
= concatMapM (lookupConstructorFields . unLoc) names
get_fields _
- = do { addErr (hang (text "Record syntax is illegal here:")
- 2 (ppr ty))
+ = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (hang (text "Record syntax is illegal here:") 2 (ppr ty))
; return [] }
rnHsTyKi env (HsFunTy u mult ty1 ty2)
@@ -704,7 +709,9 @@ rnHsTyKi env tyLit@(HsTyLit _ t)
negLit (HsStrTy _ _) = False
negLit (HsNumTy _ i) = i < 0
negLit (HsCharTy _ _) = False
- negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
+ negLitErr :: TcRnMessage
+ negLitErr = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
rnHsTyKi env (HsAppTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
@@ -745,8 +752,9 @@ rnHsTyKi env (XHsType ty)
check_in_scope rdr_name = do
mb_name <- lookupLocalOccRn_maybe rdr_name
when (isNothing mb_name) $
- addErr $ withHsDocContext (rtke_ctxt env) $
- notInScopeErr WL_LocalOnly rdr_name
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ withHsDocContext (rtke_ctxt env) $
+ notInScopeErr WL_LocalOnly rdr_name
rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { data_kinds <- xoptM LangExt.DataKinds
@@ -825,7 +833,7 @@ rnHsTyOp env overall_ty (L loc op)
= do { ops_ok <- xoptM LangExt.TypeOperators
; op' <- rnTyVar env op
; unless (ops_ok || op' `hasKey` eqTyConKey) $
- addErr (opTyErr op overall_ty)
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints (opTyErr op overall_ty)
; let l_op' = L loc op'
; return (l_op', unitFV op') }
@@ -836,7 +844,8 @@ notAllowed doc
checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
checkWildCard env (Just doc)
- = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
checkWildCard _ Nothing
= return ()
@@ -907,8 +916,9 @@ checkPolyKinds env ty
| isRnKindLevel env
= do { polykinds <- xoptM LangExt.PolyKinds
; unless polykinds $
- addErr (text "Illegal kind:" <+> ppr ty $$
- text "Did you mean to enable PolyKinds?") }
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (text "Illegal kind:" <+> ppr ty $$
+ text "Did you mean to enable PolyKinds?") }
checkPolyKinds _ _ = return ()
notInKinds :: Outputable ty
@@ -917,7 +927,8 @@ notInKinds :: Outputable ty
-> RnM ()
notInKinds env ty
| isRnKindLevel env
- = addErr (text "Illegal kind:" <+> ppr ty)
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ text "Illegal kind:" <+> ppr ty
notInKinds _ _ = return ()
{- *****************************************************
@@ -1593,7 +1604,8 @@ precParseErr op1@(n1,_) op2@(n2,_)
| is_unbound n1 || is_unbound n2
= return () -- Avoid error cascade
| otherwise
- = addErr $ hang (text "Precedence parsing error")
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Precedence parsing error")
4 (hsep [text "cannot mix", ppr_opfix op1, text "and",
ppr_opfix op2,
text "in the same infix expression"])
@@ -1603,7 +1615,8 @@ sectionPrecErr op@(n1,_) arg_op@(n2,_) section
| is_unbound n1 || is_unbound n2
= return () -- Avoid error cascade
| otherwise
- = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> text "of a section",
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [text "The operator" <+> ppr_opfix op <+> text "of a section",
nest 4 (sep [text "must have lower precedence than that of the operand,",
nest 2 (text "namely" <+> ppr_opfix arg_op)]),
nest 4 (text "in the section:" <+> quotes (ppr section))]
@@ -1626,21 +1639,23 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
* *
***************************************************** -}
-unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc
+unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage
unexpectedPatSigTypeErr ty
- = hang (text "Illegal type signature:" <+> quotes (ppr ty))
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal type signature:" <+> quotes (ppr ty))
2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
badKindSigErr doc (L loc ty)
- = setSrcSpanA loc $ addErr $
+ = setSrcSpanA loc $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
withHsDocContext doc $
hang (text "Illegal kind signature:" <+> quotes (ppr ty))
2 (text "Perhaps you intended to use KindSignatures")
-dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
+dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage
dataKindsErr env thing
- = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
2 (text "Perhaps you intended to use DataKinds")
where
pp_what | isRnKindLevel env = text "kind"
@@ -1649,10 +1664,12 @@ dataKindsErr env thing
warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll doc (L loc tv) used_names
- = unless (hsTyVarName tv `elemNameSet` used_names) $
- addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $
- vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
- , inHsDocContext doc ]
+ = unless (hsTyVarName tv `elemNameSet` used_names) $ do
+ let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $
+ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
+ , inHsDocContext doc ]
+ addDiagnosticAt (locA loc) msg
opTyErr :: Outputable a => RdrName -> a -> SDoc
opTyErr op overall_ty
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 55cc83456e..ef9769c5a7 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -22,6 +22,7 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
import GHC.Hs
+import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Rename.HsType
@@ -35,6 +36,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
import GHC.Rename.Names
+import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Annotation ( annCtxt )
import GHC.Tc.Utils.Monad
@@ -295,10 +297,11 @@ findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements
-dupWarnDecl :: LocatedN RdrName -> RdrName -> SDoc
+dupWarnDecl :: LocatedN RdrName -> RdrName -> TcRnMessage
-- Located RdrName -> DeprecDecl RdrName -> SDoc
dupWarnDecl d rdr_name
- = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
text "also at " <+> ppr (getLocA d)]
{-
@@ -541,36 +544,40 @@ checkCanonicalInstances cls poly_ty mbinds = do
isAliasMG _ = Nothing
-- got "lhs = rhs" but expected something different
- addWarnNonCanonicalMethod1 refURL flag lhs rhs =
- addDiagnostic (WarningWithFlag flag) $ vcat
- [ text "Noncanonical" <+>
- quotes (text (lhs ++ " = " ++ rhs)) <+>
- text "definition detected"
- , instDeclCtxt1 poly_ty
- , text "Move definition from" <+>
- quotes (text rhs) <+>
- text "to" <+> quotes (text lhs)
- , text "See also:" <+>
- text refURL
- ]
+ addWarnNonCanonicalMethod1 refURL flag lhs rhs = do
+ let dia = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag flag) noHints $
+ vcat [ text "Noncanonical" <+>
+ quotes (text (lhs ++ " = " ++ rhs)) <+>
+ text "definition detected"
+ , instDeclCtxt1 poly_ty
+ , text "Move definition from" <+>
+ quotes (text rhs) <+>
+ text "to" <+> quotes (text lhs)
+ , text "See also:" <+>
+ text refURL
+ ]
+ addDiagnostic dia
-- expected "lhs = rhs" but got something else
- addWarnNonCanonicalMethod2 refURL flag lhs rhs =
- addDiagnostic (WarningWithFlag flag) $ vcat
- [ text "Noncanonical" <+>
- quotes (text lhs) <+>
- text "definition detected"
- , instDeclCtxt1 poly_ty
- , quotes (text lhs) <+>
- text "will eventually be removed in favour of" <+>
- quotes (text rhs)
- , text "Either remove definition for" <+>
- quotes (text lhs) <+> text "(recommended)" <+>
- text "or define as" <+>
- quotes (text (lhs ++ " = " ++ rhs))
- , text "See also:" <+>
- text refURL
- ]
+ addWarnNonCanonicalMethod2 refURL flag lhs rhs = do
+ let dia = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag flag) noHints $
+ vcat [ text "Noncanonical" <+>
+ quotes (text lhs) <+>
+ text "definition detected"
+ , instDeclCtxt1 poly_ty
+ , quotes (text lhs) <+>
+ text "will eventually be removed in favour of" <+>
+ quotes (text rhs)
+ , text "Either remove definition for" <+>
+ quotes (text lhs) <+> text "(recommended)" <+>
+ text "or define as" <+>
+ quotes (text (lhs ++ " = " ++ rhs))
+ , text "See also:" <+>
+ text refURL
+ ]
+ addDiagnostic dia
-- stolen from GHC.Tc.TyCl.Instance
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
@@ -665,7 +672,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- reach the typechecker, lest we encounter different errors that are
-- hopelessly confusing (such as the one in #16114).
bail_out (l, err_msg) = do
- addErrAt l $ withHsDocContext ctxt err_msg
+ addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)
pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
rnFamEqn :: HsDocContext
@@ -829,7 +836,8 @@ rnFamEqn doc atfi extra_kvars
badAssocRhs :: [Name] -> RnM ()
badAssocRhs ns
- = addErr (hang (text "The RHS of an associated type declaration mentions"
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (hang (text "The RHS of an associated type declaration mentions"
<+> text "out-of-scope variable" <> plural ns
<+> pprWithCommas (quotes . ppr) ns)
2 (text "All such variables must be bound on the LHS"))
@@ -1189,9 +1197,10 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
loc = getLocA nowc_ty
nowc_ty = dropWildCards ty
-standaloneDerivErr :: SDoc
+standaloneDerivErr :: TcRnMessage
standaloneDerivErr
- = hang (text "Illegal standalone deriving declaration")
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal standalone deriving declaration")
2 (text "Use StandaloneDeriving to enable this extension")
{-
@@ -1332,15 +1341,17 @@ validRuleLhs foralls lhs
checkl_es es = foldr (mplus . checkl_e) Nothing es
-}
-badRuleVar :: FastString -> Name -> SDoc
+badRuleVar :: FastString -> Name -> TcRnMessage
badRuleVar name var
- = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
text "Forall'd variable" <+> quotes (ppr var) <+>
text "does not appear on left hand side"]
-badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
+badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage
badRuleLhsErr name lhs bad_e
- = sep [text "Rule" <+> pprRuleName name <> colon,
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ sep [text "Rule" <+> pprRuleName name <> colon,
nest 2 (vcat [err,
text "in left-hand side:" <+> ppr lhs])]
$$
@@ -1600,8 +1611,8 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
; return (StandaloneKindSig noExtField new_v new_ki, fvs)
}
where
- standaloneKiSigErr :: SDoc
- standaloneKiSigErr =
+ standaloneKiSigErr :: TcRnMessage
+ standaloneKiSigErr = TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Illegal standalone kind signature")
2 (text "Did you mean to enable StandaloneKindSignatures?")
@@ -1674,7 +1685,7 @@ rnRoleAnnots tc_names role_annots
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr list
- = addErrAt (locA loc) $
+ = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Duplicate role annotations for" <+>
quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
@@ -1689,7 +1700,7 @@ dupRoleAnnotErr list
dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
dupKindSig_Err list
- = addErrAt (locA loc) $
+ = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Duplicate standalone kind signatures for" <+>
quotes (ppr $ standaloneKindSigName first_decl) <> colon)
2 (vcat $ map pp_kisig $ NE.toList sorted_list)
@@ -1966,13 +1977,14 @@ warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
warnNoDerivStrat mds loc
= do { dyn_flags <- getDynFlags
; case mds of
- Nothing -> addDiagnosticAt
- (WarningWithFlag Opt_WarnMissingDerivingStrategies)
- loc
- (if xopt LangExt.DerivingStrategies dyn_flags
- then no_strat_warning
- else no_strat_warning $+$ deriv_strat_nenabled
- )
+ Nothing ->
+ let dia = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $
+ (if xopt LangExt.DerivingStrategies dyn_flags
+ then no_strat_warning
+ else no_strat_warning $+$ deriv_strat_nenabled
+ )
+ in addDiagnosticAt loc dia
_ -> pure ()
}
where
@@ -2072,14 +2084,16 @@ rnLDerivStrategy doc mds thing_inside
(thing, fvs) <- thing_inside
pure (ds, thing, fvs)
-badGadtStupidTheta :: HsDocContext -> SDoc
+badGadtStupidTheta :: HsDocContext -> TcRnMessage
badGadtStupidTheta _
- = vcat [text "No context is allowed on a GADT-style data declaration",
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [text "No context is allowed on a GADT-style data declaration",
text "(You can put a context on each constructor, though.)"]
-illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
+illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage
illegalDerivStrategyErr ds
- = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
, text enableStrategy ]
where
@@ -2090,9 +2104,10 @@ illegalDerivStrategyErr ds
| otherwise
= "Use DerivingStrategies to enable this extension"
-multipleDerivClausesErr :: SDoc
+multipleDerivClausesErr :: TcRnMessage
multipleDerivClausesErr
- = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [ text "Illegal use of multiple, consecutive deriving clauses"
, text "Use DerivingStrategies to allow this" ]
rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
@@ -2157,7 +2172,7 @@ rnFamResultSig doc (TyVarSig _ tvbndr)
rdr_env <- getLocalRdrEnv
; let resName = hsLTyVarName tvbndr
; when (resName `elemLocalRdrEnv` rdr_env) $
- addErrAt (getLocA tvbndr) $
+ addErrAt (getLocA tvbndr) $ TcRnUnknownMessage $ mkPlainError noHints $
(hsep [ text "Type variable", quotes (ppr resName) <> comma
, text "naming a type family result,"
] $$
@@ -2229,7 +2244,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
-- not-in-scope variables) don't check the validity of injectivity
-- annotation. This gives better error messages.
; when (noRnErrors && not lhsValid) $
- addErrAt (getLocA injFrom)
+ addErrAt (getLocA injFrom) $ TcRnUnknownMessage $ mkPlainError noHints $
( vcat [ text $ "Incorrect type variable on the LHS of "
++ "injectivity condition"
, nest 5
@@ -2238,7 +2253,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
; when (noRnErrors && not (Set.null rhsValid)) $
do { let errorVars = Set.toList rhsValid
- ; addErrAt srcSpan $ ( hsep
+ ; addErrAt srcSpan $ TcRnUnknownMessage $ mkPlainError noHints $
+ ( hsep
[ text "Unknown type variable" <> plural errorVars
, text "on the RHS of injectivity condition:"
, interpp'SP errorVars ] ) }
@@ -2516,7 +2532,9 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
; return (gp, Just (splice, ds)) }
where
- badImplicitSplice = text "Parse error: module header, import declaration"
+ badImplicitSplice :: TcRnMessage
+ badImplicitSplice = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Parse error: module header, import declaration"
$$ text "or top-level declaration expected."
-- The compiler should suggest the above, and not using
-- TemplateHaskell since the former suggestion is more
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 4a8e80dca2..b205fc4580 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -72,6 +72,7 @@ import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.HpcInfo
import GHC.Types.Unique.FM
+import GHC.Types.Error
import GHC.Unit
import GHC.Unit.Module.Warnings
@@ -340,7 +341,8 @@ rnImportDecl this_mod
Nothing -> True
Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" ||
fsToUnit pkg_fs == moduleUnit this_mod))
- (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))
+ (addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (text "A module cannot import itself:" <+> ppr imp_mod_name))
-- Check for a missing import list (Opt_WarnMissingImportList also
-- checks for T(..) items but that is done in checkDodgyImport below)
@@ -348,9 +350,13 @@ rnImportDecl this_mod
Just (False, _) -> return () -- Explicit import list
_ | implicit -> return () -- Do not bleat for implicit imports
| qual_only -> return ()
- | otherwise -> whenWOptM Opt_WarnMissingImportList $
- addDiagnostic (WarningWithFlag Opt_WarnMissingImportList)
- (missingImportListWarn imp_mod_name)
+ | otherwise -> whenWOptM Opt_WarnMissingImportList $ do
+ let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList)
+ noHints
+ (missingImportListWarn imp_mod_name)
+ addDiagnostic msg
+
iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)
@@ -370,7 +376,8 @@ rnImportDecl this_mod
warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags))
(warnRedundantSourceImport imp_mod_name)
when (mod_safe && not (safeImportsOn dflags)) $
- addErr (text "safe import can't be used as Safe Haskell isn't on!"
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (text "safe import can't be used as Safe Haskell isn't on!"
$+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe"))
let
@@ -409,8 +416,12 @@ rnImportDecl this_mod
-- Complain if we import a deprecated module
case mi_warns iface of
- WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
- (moduleWarn imp_mod_name txt)
+ WarnAll txt -> do
+ let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
+ noHints
+ (moduleWarn imp_mod_name txt)
+ addDiagnostic msg
_ -> return ()
-- Complain about -Wcompat-unqualified-imports violations.
@@ -543,8 +554,12 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by =
-- Currently not used for anything.
warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM ()
warnUnqualifiedImport decl iface =
- when bad_import
- $ addDiagnosticAt (WarningWithFlag Opt_WarnCompatUnqualifiedImports) loc warning
+ when bad_import $ do
+ let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports)
+ noHints
+ warning
+ addDiagnosticAt loc msg
where
mod = mi_module iface
loc = getLoc $ ideclName decl
@@ -572,10 +587,10 @@ warnUnqualifiedImport decl iface =
qualifiedMods = mkModuleSet []
-warnRedundantSourceImport :: ModuleName -> SDoc
+warnRedundantSourceImport :: ModuleName -> TcRnMessage
warnRedundantSourceImport mod_name
- = text "Unnecessary {-# SOURCE #-} in the import of module"
- <+> quotes (ppr mod_name)
+ = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $
+ text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name)
{-
************************************************************************
@@ -1191,12 +1206,18 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
addTcRnDiagnostic (TcRnDodgyImports n)
emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
addTcRnDiagnostic (TcRnMissingImportList ieRdr)
- emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $
- addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))
+ emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do
+ let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports)
+ noHints
+ (lookup_err_msg (BadImport ie))
+ addDiagnostic msg
run_lookup :: IELookupM a -> TcRn (Maybe a)
run_lookup m = case m of
- Failed err -> addErr (lookup_err_msg err) >> return Nothing
+ Failed err -> do
+ addErr $ TcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err)
+ return Nothing
Succeeded a -> return (Just a)
lookup_err_msg err = case err of
@@ -1568,8 +1589,10 @@ warnMissingSignatures gbl_env
= Opt_WarnMissingExportedSignatures
add_warn name flag msg
- = when not_ghc_generated
- (addDiagnosticAt (WarningWithFlag flag) (getSrcSpan name) msg)
+ = when not_ghc_generated $ do
+ let dia = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag flag) noHints msg
+ addDiagnosticAt (getSrcSpan name) dia
where
not_ghc_generated
= name `elemNameSet` sig_ns
@@ -1590,9 +1613,11 @@ warnMissingKindSignatures gbl_env
ksig_ns = tcg_ksigs gbl_env
add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()
- add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $
- addDiagnosticAt (WarningWithFlag Opt_WarnMissingKindSignatures) (getSrcSpan name) $
- hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)
+ add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $ do
+ let dia = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingKindSignatures) noHints $
+ hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)
+ addDiagnosticAt (getSrcSpan name) dia
where
msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:"
| otherwise = text "Top-level type constructor with no standalone kind signature:"
@@ -1758,7 +1783,9 @@ warnUnusedImport flag fld_env (L loc decl, used, unused)
-- Nothing used; drop entire declaration
| null used
- = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg1
+ = let dia = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag flag) noHints msg1
+ in addDiagnosticAt (locA loc) dia
-- Everything imported is used; nop
| null unused
@@ -1769,11 +1796,13 @@ warnUnusedImport flag fld_env (L loc decl, used, unused)
| Just (_, L _ imports) <- ideclHiding decl
, length unused == 1
, Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports
- = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg2
+ = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2
+ in addDiagnosticAt (locA loc) dia
-- Some imports are unused
| otherwise
- = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg2
+ = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2
+ in addDiagnosticAt (locA loc) dia
where
msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant
@@ -2064,7 +2093,7 @@ illegalImportItemErr = text "Illegal import item"
addDupDeclErr :: [GlobalRdrElt] -> TcRn ()
addDupDeclErr [] = panic "addDupDeclErr: empty list"
addDupDeclErr gres@(gre : _)
- = addErrAt (getSrcSpan (last sorted_names)) $
+ = addErrAt (getSrcSpan (last sorted_names)) $ TcRnUnknownMessage $ mkPlainError noHints $
-- Report the error at the later location
vcat [text "Multiple declarations of" <+>
quotes (ppr (greOccName gre)),
@@ -2093,9 +2122,10 @@ moduleWarn mod (DeprecatedTxt _ txt)
<+> text "is deprecated:",
nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
-packageImportErr :: SDoc
+packageImportErr :: TcRnMessage
packageImportErr
- = text "Package-qualified imports are not enabled; use PackageImports"
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Package-qualified imports are not enabled; use PackageImports"
-- This data decl will parse OK
-- data T = a Int
@@ -2110,6 +2140,7 @@ packageImportErr
checkConName :: RdrName -> TcRn ()
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
-badDataCon :: RdrName -> SDoc
+badDataCon :: RdrName -> TcRnMessage
badDataCon name
- = hsep [text "Illegal data constructor name", quotes (ppr name)]
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hsep [text "Illegal data constructor name", quotes (ppr name)]
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 7a63d73fee..524b63c49f 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -49,6 +49,7 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat )
import GHC.Hs
+import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( hsOverLitName )
import GHC.Rename.Env
@@ -60,6 +61,7 @@ import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
import GHC.Rename.HsType
import GHC.Builtin.Names
import GHC.Types.Avail ( greNameMangledName )
+import GHC.Types.Error
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
@@ -547,7 +549,7 @@ rnConPatAndThen mk con (PrefixCon tyargs pats)
unless (scoped_tyvars && type_app) $
case listToMaybe tyargs of
Nothing -> pure ()
- Just tyarg -> addErr $
+ Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Illegal visible type application in a pattern:"
<+> quotes (char '@' <> ppr tyarg))
2 (text "Both ScopedTypeVariables and TypeApplications are"
@@ -809,25 +811,29 @@ getFieldLbls flds
getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds
-needFlagDotDot :: HsRecFieldContext -> SDoc
-needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
- text "Use RecordWildCards to permit this"]
+needFlagDotDot :: HsRecFieldContext -> TcRnMessage
+needFlagDotDot ctxt = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
+ text "Use RecordWildCards to permit this"]
-badDotDotCon :: Name -> SDoc
+badDotDotCon :: Name -> TcRnMessage
badDotDotCon con
- = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
, nest 2 (text "The constructor has no labelled fields") ]
-emptyUpdateErr :: SDoc
-emptyUpdateErr = text "Empty record update"
+emptyUpdateErr :: TcRnMessage
+emptyUpdateErr = TcRnUnknownMessage $ mkPlainError noHints $ text "Empty record update"
-badPun :: Located RdrName -> SDoc
-badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
- text "Use NamedFieldPuns to permit this"]
+badPun :: Located RdrName -> TcRnMessage
+badPun fld = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
+ text "Use NamedFieldPuns to permit this"]
-dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
+dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage
dupFieldErr ctxt dups
- = hsep [text "duplicate field name",
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hsep [text "duplicate field name",
quotes (ppr (NE.head dups)),
text "in record", pprRFC ctxt]
@@ -917,10 +923,12 @@ patSigErr ty
= (text "Illegal signature in pattern:" <+> ppr ty)
$$ nest 4 (text "Use ScopedTypeVariables to permit it")
-bogusCharError :: Char -> SDoc
+bogusCharError :: Char -> TcRnMessage
bogusCharError c
- = text "character literal out of range: '\\" <> char c <> char '\''
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ text "character literal out of range: '\\" <> char c <> char '\''
-badViewPat :: Pat GhcPs -> SDoc
-badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
- text "Use ViewPatterns to enable view patterns"]
+badViewPat :: Pat GhcPs -> TcRnMessage
+badViewPat pat = TcRnUnknownMessage $ mkPlainError noHints $
+ vcat [text "Illegal view pattern: " <+> ppr pat,
+ text "Use ViewPatterns to enable view patterns"]
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 5cba042415..3c2b332ece 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -26,6 +26,7 @@ import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn )
import GHC.Rename.Unbound ( isUnboundName )
import GHC.Rename.Module ( rnSrcDecls, findSplice )
import GHC.Rename.Pat ( rnPat )
+import GHC.Types.Error
import GHC.Types.Basic ( TopLevelFlag, isTopLevel )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Utils.Outputable
@@ -78,7 +79,7 @@ rnBracket e br_body
do { -- Check that -XTemplateHaskellQuotes is enabled and available
thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
; unless thQuotesEnabled $
- failWith ( vcat
+ failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat
[ text "Syntax error on" <+> ppr e
, text ("Perhaps you intended to use TemplateHaskell"
++ " or TemplateHaskellQuotes") ] )
@@ -189,22 +190,23 @@ quotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
2 (ppr br_body)
-illegalBracket :: SDoc
-illegalBracket =
+illegalBracket :: TcRnMessage
+illegalBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Template Haskell brackets cannot be nested" <+>
text "(without intervening splices)"
-illegalTypedBracket :: SDoc
-illegalTypedBracket =
+illegalTypedBracket :: TcRnMessage
+illegalTypedBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Typed brackets may only appear in typed splices."
-illegalUntypedBracket :: SDoc
-illegalUntypedBracket =
+illegalUntypedBracket :: TcRnMessage
+illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Untyped brackets may only appear in untyped splices."
-quotedNameStageErr :: HsBracket GhcPs -> SDoc
+quotedNameStageErr :: HsBracket GhcPs -> TcRnMessage
quotedNameStageErr br
- = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
, text "must be used at the same stage at which it is bound" ]
@@ -293,7 +295,8 @@ checkTopSpliceAllowed splice = do
let (herald, ext) = spliceExtension splice
extEnabled <- xoptM ext
unless extEnabled
- (failWith $ text herald <+> text "are not permitted without" <+> ppr ext)
+ (failWith $ TcRnUnknownMessage $ mkPlainError noHints $
+ text herald <+> text "are not permitted without" <+> ppr ext)
where
spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension)
spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)
@@ -836,11 +839,13 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
= vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
, gen ]
-illegalTypedSplice :: SDoc
-illegalTypedSplice = text "Typed splices may not appear in untyped brackets"
+illegalTypedSplice :: TcRnMessage
+illegalTypedSplice = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Typed splices may not appear in untyped brackets"
-illegalUntypedSplice :: SDoc
-illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"
+illegalUntypedSplice :: TcRnMessage
+illegalUntypedSplice = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Untyped splices may not appear in typed brackets"
checkThLocalName :: Name -> RnM ()
checkThLocalName name
diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs
index 0d666528c9..7f62c11fce 100644
--- a/compiler/GHC/Rename/Unbound.hs
+++ b/compiler/GHC/Rename/Unbound.hs
@@ -27,6 +27,7 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
+import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)
import GHC.Utils.Outputable as Outputable
@@ -37,6 +38,7 @@ import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Types.Error
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -101,7 +103,7 @@ unboundNameX looking_for rdr_name extra
; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
err = notInScopeErr (lf_where looking_for) rdr_name $$ extra
; if not show_helpful_errors
- then addErr err
+ then addErr (TcRnUnknownMessage $ mkPlainError noHints err)
else do { local_env <- getLocalRdrEnv
; global_env <- getGlobalRdrEnv
; impInfo <- getImports
@@ -110,7 +112,7 @@ unboundNameX looking_for rdr_name extra
; let suggestions = unknownNameSuggestions_ looking_for
dflags hpt currmod global_env local_env impInfo
rdr_name
- ; addErr (err $$ suggestions) }
+ ; addErr (TcRnUnknownMessage $ mkPlainError noHints (err $$ suggestions)) }
; return (mkUnboundNameRdr rdr_name) }
notInScopeErr :: WhereLooking -> RdrName -> SDoc
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index e87721edaf..a97d215b8b 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -39,8 +39,10 @@ import GHC.Prelude
import GHC.Core.Type
import GHC.Hs
import GHC.Types.Name.Reader
+import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
+import GHC.Types.Error
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
@@ -169,9 +171,11 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
-- we don't find any GREs that are in scope qualified-only
complain [] = return ()
- complain pp_locs = addDiagnosticAt (WarningWithFlag Opt_WarnNameShadowing)
- loc
- (shadowedNameWarn occ pp_locs)
+ complain pp_locs = do
+ let msg = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnNameShadowing)
+ noHints
+ (shadowedNameWarn occ pp_locs)
+ addDiagnosticAt loc msg
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
-- Returns False for record selectors that are shadowed, when
@@ -199,7 +203,7 @@ checkInferredVars ctxt (Just msg) ty =
let bndrs = sig_ty_bndrs ty
in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of
Nothing -> return ()
- Just _ -> addErr $ withHsDocContext ctxt msg
+ Just _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg)
where
sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))
@@ -308,7 +312,7 @@ noNestedForallsContextsErr what lty =
addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM ()
addNoNestedForallsContextsErr ctxt what lty =
whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->
- addErrAt l $ withHsDocContext ctxt err_msg
+ addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)
{-
************************************************************************
@@ -385,9 +389,12 @@ checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
-- The `..` here doesn't bind any variables as `x` is already bound.
warnRedundantRecordWildcard :: RnM ()
warnRedundantRecordWildcard =
- whenWOptM Opt_WarnRedundantRecordWildcards
- (addDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards)
- redundantWildcardWarning)
+ whenWOptM Opt_WarnRedundantRecordWildcards $
+ let msg = TcRnUnknownMessage $
+ mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards)
+ noHints
+ redundantWildcardWarning
+ in addDiagnostic msg
-- | Produce a warning when no variables bound by a `..` pattern are used.
@@ -404,7 +411,7 @@ warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
warnUnusedRecordWildcard ns used_names = do
let used = filter (`elemNameSet` used_names) ns
traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
- warnIfFlag Opt_WarnUnusedRecordWildcards (null used)
+ warnIf (null used)
unusedRecordWildcardWarning
@@ -474,15 +481,17 @@ reportable child
| otherwise = not (startsWithUnderscore (occName child))
addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
-addUnusedWarning flag occ span msg
- = addDiagnosticAt (WarningWithFlag flag) span $
- sep [msg <> colon,
- nest 2 $ pprNonVarNameSpace (occNameSpace occ)
- <+> quotes (ppr occ)]
-
-unusedRecordWildcardWarning :: SDoc
+addUnusedWarning flag occ span msg = do
+ let diag = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $
+ sep [msg <> colon,
+ nest 2 $ pprNonVarNameSpace (occNameSpace occ)
+ <+> quotes (ppr occ)]
+ addDiagnosticAt span diag
+
+unusedRecordWildcardWarning :: TcRnMessage
unusedRecordWildcardWarning =
- wildcardDoc $ text "No variables bound in the record wildcard match are used"
+ TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $
+ wildcardDoc $ text "No variables bound in the record wildcard match are used"
redundantWildcardWarning :: SDoc
redundantWildcardWarning =
@@ -531,7 +540,8 @@ addNameClashErrRn rdr_name gres
-- already, and we don't want an error cascade.
= return ()
| otherwise
- = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
, text "It could refer to"
, nest 3 (vcat (msg1 : msgs)) ])
where
@@ -593,7 +603,7 @@ unknownSubordinateErr doc op -- Doc is "method of class" or
dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
dupNamesErr get_loc names
- = addErrAt big_loc $
+ = addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $
vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
locations]
where
@@ -601,13 +611,15 @@ dupNamesErr get_loc names
big_loc = foldr1 combineSrcSpans locs
locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs))
-badQualBndrErr :: RdrName -> SDoc
+badQualBndrErr :: RdrName -> TcRnMessage
badQualBndrErr rdr_name
- = text "Qualified name in binding position:" <+> ppr rdr_name
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ text "Qualified name in binding position:" <+> ppr rdr_name
-typeAppErr :: String -> LHsType GhcPs -> SDoc
+typeAppErr :: String -> LHsType GhcPs -> TcRnMessage
typeAppErr what (L _ k)
- = hang (text "Illegal visible" <+> text what <+> text "application"
+ = TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal visible" <+> text what <+> text "application"
<+> quotes (char '@' <> ppr k))
2 (text "Perhaps you intended to use TypeApplications")
@@ -618,9 +630,10 @@ checkTupSize tup_size
| tup_size <= mAX_TUPLE_SIZE
= return ()
| otherwise
- = addErr (sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",
nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
- nest 2 (text "Workaround: use nested tuples or define a data type")])
+ nest 2 (text "Workaround: use nested tuples or define a data type")]
-- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'.
checkCTupSize :: Int -> TcM ()
@@ -628,9 +641,10 @@ checkCTupSize tup_size
| tup_size <= mAX_CTUPLE_SIZE
= return ()
| otherwise
- = addErr (hang (text "Constraint tuple arity too large:" <+> int tup_size
+ = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Constraint tuple arity too large:" <+> int tup_size
<+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
- 2 (text "Instead, use a nested tuple"))
+ 2 (text "Instead, use a nested tuple")
{-
View Lorry Controller Status