diff options
48 files changed, 1259 insertions, 788 deletions
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index cc7a154b2a..89a8ee6e20 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -57,6 +57,7 @@ import GHC.Iface.Rename import GHC.Iface.Env import GHC.Iface.Errors as Iface_Errors +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Utils.Binary ( BinData(..) ) @@ -298,7 +299,7 @@ loadSrcInterface :: SDoc loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc err + Failed err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Succeeded iface -> return iface } -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index b275c74713..bbb1fb52c3 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -38,6 +38,7 @@ import GHC.Iface.Env import GHC.StgToCmm.Types +import GHC.Tc.Errors.Types import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType @@ -102,6 +103,7 @@ import GHC.Types.Id.Make import GHC.Types.Id.Info import GHC.Types.Tickish import GHC.Types.TyThing +import GHC.Types.Error import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF @@ -573,9 +575,9 @@ tcHiBootIface hsc_src mod Nothing -> return NoSelfBoot -- error cases Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of - IsBoot -> failWithTc (elaborate err) + IsBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints (elaborate err)) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc moduleLoop + NotBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints moduleLoop) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} 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") {- diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 58ce967690..184edf021d 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -18,6 +18,7 @@ import GHC.Prelude import GHC.Hs import GHC.Driver.Session +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin @@ -46,6 +47,7 @@ import GHC.Core.Type import GHC.Utils.Error import GHC.Core.DataCon import GHC.Data.Maybe +import GHC.Types.Hint import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet @@ -738,9 +740,10 @@ tcStandaloneDerivInstType ctxt warnUselessTypeable :: TcM () warnUselessTypeable - = do { addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable) - $ text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } + = do { addDiagnosticTc $ TcRnUnknownMessage + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingTypeable) noHints $ + text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" } ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance @@ -1609,7 +1612,10 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys -- DeriveAnyClass, but emitting a warning about the choice. -- See Note [Deriving strategies] when (newtype_deriving && deriveAnyClass) $ - lift $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep + lift $ addDiagnosticTc + $ TcRnUnknownMessage + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingDefaults) noHints + $ sep [ text "Both DeriveAnyClass and" <+> text "GeneralizedNewtypeDeriving are enabled" , text "Defaulting to the DeriveAnyClass strategy" @@ -1998,9 +2004,8 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism ; case wildcard of Nothing -> pure () Just span -> setSrcSpan span $ do - checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) - diagnosticTc (WarningWithFlag Opt_WarnPartialTypeSignatures) - wpartial_sigs partial_sig_msg + checkTc xpartial_sigs (partial_sig_msg [pts_suggestion]) + diagnosticTc wpartial_sigs (partial_sig_msg noHints) -- Check for Generic instances that are derived with an exotic -- deriving strategy like DAC @@ -2011,14 +2016,21 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism where exotic_mechanism = not $ isDerivSpecStock mechanism - partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) + partial_sig_msg :: [GhcHint] -> TcRnMessage + partial_sig_msg hints = TcRnUnknownMessage + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialTypeSignatures) hints $ + text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + pts_suggestion :: GhcHint pts_suggestion - = text "To use the inferred type, enable PartialTypeSignatures" + = UnknownHint (text "To use the inferred type, enable PartialTypeSignatures") - gen_inst_err = text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." + gen_inst_err :: TcRnMessage + gen_inst_err = TcRnUnknownMessage + $ mkPlainError noHints $ + text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." derivingThingFailWith :: Bool -- If True, add a snippet about how not even -- GeneralizedNewtypeDeriving would make this @@ -2206,8 +2218,9 @@ What con2tag/tag2con functions are available? ************************************************************************ -} -nonUnaryErr :: LHsSigType GhcRn -> SDoc -nonUnaryErr ct = quotes (ppr ct) +nonUnaryErr :: LHsSigType GhcRn -> TcRnMessage +nonUnaryErr ct = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr ct) <+> text "is not a unary constraint, as expected by a deriving clause" nonStdErr :: Class -> SDoc @@ -2222,9 +2235,10 @@ gndNonNewtypeErr = derivingNullaryErr :: SDoc derivingNullaryErr = text "Cannot derive instances for nullary classes" -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> TcRnMessage derivingKindErr tc cls cls_tys cls_kind enough_args - = sep [ hang (text "Cannot derive well-kinded instance of form" + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ hang (text "Cannot derive well-kinded instance of form" <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> text "..."))) 2 gen1_suggestion @@ -2237,35 +2251,37 @@ derivingKindErr tc cls cls_tys cls_kind enough_args = text "(Perhaps you intended to use PolyKinds)" | otherwise = Outputable.empty -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> SDoc +derivingViaKindErr :: Class -> Kind -> Type -> Kind -> TcRnMessage derivingViaKindErr cls cls_kind via_ty via_kind - = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - -derivingEtaErr :: Class -> [Type] -> Type -> SDoc + = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ + hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + +derivingEtaErr :: Class -> [Type] -> Type -> TcRnMessage derivingEtaErr cls cls_tys inst_ty - = sep [text "Cannot eta-reduce to an instance of form", + = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ + sep [text "Cannot eta-reduce to an instance of form", nest 2 (text "instance (...) =>" <+> pprClassPred cls (cls_tys ++ [inst_ty]))] derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> TcRnMessage derivingThingErr newtype_deriving cls cls_args mb_strat why = derivingThingErr' newtype_deriving cls cls_args mb_strat (maybe empty derivStrategyName mb_strat) why -derivingThingErrM :: Bool -> SDoc -> DerivM SDoc +derivingThingErrM :: Bool -> SDoc -> DerivM TcRnMessage derivingThingErrM newtype_deriving why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why -derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc +derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM TcRnMessage derivingThingErrMechanism mechanism why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args @@ -2274,9 +2290,10 @@ derivingThingErrMechanism mechanism why (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> TcRnMessage derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why - = sep [(hang (text "Can't make a derived instance of") + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred) <+> via_mechanism) $$ nest 2 extra) <> colon, nest 2 why] diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index e45d051e50..2f6702bfc8 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -30,6 +30,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) import GHC.Core.Unify ( tcMatchTys, flattenTys ) import GHC.Unit.Module +import GHC.Tc.Errors.Types import GHC.Tc.Instance.Family import GHC.Tc.Utils.Instantiate import GHC.Core.InstEnv @@ -60,6 +61,7 @@ import GHC.Utils.Outputable as O import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc +import GHC.Driver.Env (hsc_units) import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.List.SetOps ( equivClasses ) @@ -1033,11 +1035,12 @@ mkErrorReport :: DiagnosticReason -> TcM (MsgEnvelope TcRnMessage) mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkTcRnMessage rea + ; unit_state <- hsc_units <$> getTopEnv ; + ; let err_info = ErrInfo context (vcat $ relevant_bindings ++ valid_subs) + ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) + ; mkTcRnMessage (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (vcat important) - context - (vcat $ relevant_bindings ++ valid_subs) + (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) } -- This version does not include the context @@ -1046,10 +1049,13 @@ mkErrorReportNC :: DiagnosticReason -> Report -> TcM (MsgEnvelope TcRnMessage) mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs) - = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (vcat important) - O.empty - (vcat $ relevant_bindings ++ valid_subs) + = do { unit_state <- hsc_units <$> getTopEnv ; + ; let err_info = ErrInfo O.empty (vcat $ relevant_bindings ++ valid_subs) + ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) + ; mkTcRnMessage + (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) + (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) + } type UserGiven = Implication @@ -3129,7 +3135,9 @@ warnDefaulting wanteds default_ty , quotes (ppr default_ty) ]) 2 ppr_wanteds - ; setCtLocM loc $ diagnosticTc (WarningWithFlag Opt_WarnTypeDefaults) warn_default warn_msg } + ; let diag = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnTypeDefaults) noHints warn_msg + ; setCtLocM loc $ diagnosticTc warn_default diag } {- Note [Runtime skolems] @@ -3153,8 +3161,8 @@ solverDepthErrorTcS loc ty ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) tidy_ty = tidyType tidy_env ty - msg - = vcat [ text "Reduction stack overflow; size =" <+> ppr depth + msg = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Reduction stack overflow; size =" <+> ppr depth , hang (text "When simplifying the following type:") 2 (ppr tidy_ty) , note ] diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 578c182a7d..837672c4d1 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE RecordWildCards #-} module GHC.Tc.Errors.Ppr ( formatLevPolyErr @@ -16,18 +17,24 @@ import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Driver.Flags import GHC.Hs import GHC.Utils.Outputable +import GHC.Unit.State (pprWithUnitState, UnitState) + instance Diagnostic TcRnMessage where diagnosticMessage = \case TcRnUnknownMessage m -> diagnosticMessage m - TcLevityPolyInType ty prov (ErrInfo extra) - -> mkDecorated [pprLevityPolyInType ty prov, extra] - TcRnImplicitLift id_or_name errInfo - -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+> - text "is implicitly lifted in the TH quotation" - , getErrInfo errInfo - ] + TcLevityPolyInType ty prov (ErrInfo extra supplementary) + -> mkDecorated [pprLevityPolyInType ty prov, extra, supplementary] + TcRnMessageWithInfo unit_state msg_with_info + -> case msg_with_info of + TcRnMessageDetailed err_info msg + -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) + TcRnImplicitLift id_or_name ErrInfo{..} + -> mkDecorated $ + ( text "The variable" <+> quotes (ppr id_or_name) <+> + text "is implicitly lifted in the TH quotation" + ) : [errInfoContext, errInfoSupplementary] TcRnUnusedPatternBinds bind -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] TcRnDodgyImports name @@ -48,6 +55,9 @@ instance Diagnostic TcRnMessage where -> diagnosticReason m TcLevityPolyInType{} -> ErrorWithoutFlag + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticReason m TcRnImplicitLift{} -> WarningWithFlag Opt_WarnImplicitLift TcRnUnusedPatternBinds{} @@ -68,6 +78,9 @@ instance Diagnostic TcRnMessage where -> diagnosticHints m TcLevityPolyInType{} -> noHints + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticHints m TcRnImplicitLift{} -> noHints TcRnUnusedPatternBinds{} @@ -83,6 +96,15 @@ instance Diagnostic TcRnMessage where TcRnModMissingRealSrcSpan{} -> noHints +messageWithInfoDiagnosticMessage :: UnitState + -> ErrInfo + -> DecoratedSDoc + -> DecoratedSDoc +messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important = + let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary] + in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` + mkDecorated err_info' + dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc dodgy_msg kind tc ie = sep [ text "The" <+> kind <+> text "item" diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 4e9d233a67..dfaf43df5b 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -3,6 +3,7 @@ module GHC.Tc.Errors.Types ( -- * Main types TcRnMessage(..) + , TcRnMessageDetailed(..) , ErrInfo(..) , LevityCheckProvenance(..) ) where @@ -15,10 +16,61 @@ import GHC.Unit.Types (Module) import GHC.Utils.Outputable import Data.Typeable import GHC.Core.Type (Type, Var) +import GHC.Unit.State (UnitState) + +{- +Note [Migrating TcM Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As part of #18516, we are slowly migrating the diagnostic messages emitted +and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted +some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions +that accepted 3 SDocs an input: one for the important part of the message, +one for the context and one for any supplementary information. Consider the following: + + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the expression: x4 + In a stmt of a 'do' block: return (x2, x4) + In the expression: + +Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match" +as the important part, "In the expression" as the context and "In a stmt..In the expression" +as the supplementary, with the context and supplementary usually smashed together so that +the final message would be composed only by two SDoc (which would then be bulletted like in +the example). + +In order for us to smooth out the migration to the new diagnostic infrastructure, we +introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose +of bridging the two worlds together without breaking the external API or the existing +format of messages reported by GHC. + +Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden +diagnostic API inside Tc.Utils.Monad, enabling further refactorings. + +In the future, once the conversion will be complete and we will successfully eradicate +any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and +existence of these two types, which for now remain a "necessary evil". + +-} + -- The majority of TcRn messages come with extra context about the error, --- and this newtype captures it. -newtype ErrInfo = ErrInfo { getErrInfo :: SDoc } +-- and this newtype captures it. See Note [Migrating TcM messages]. +data ErrInfo = ErrInfo { + errInfoContext :: !SDoc + -- ^ Extra context associated to the error. + , errInfoSupplementary :: !SDoc + -- ^ Extra supplementary info associated to the error. + } + + +-- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside +-- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing +-- any extra info needed to correctly pretty-print this diagnostic later on. +data TcRnMessageDetailed + = TcRnMessageDetailed !ErrInfo + -- ^ Extra info associated with the message + !TcRnMessage -- | An error which might arise during typechecking/renaming. data TcRnMessage where @@ -27,6 +79,18 @@ data TcRnMessage where -} TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage + {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed + to be provided in order to qualify a diagnostic and where it was originated (and why). + It carries an extra 'UnitState' which can be used to pretty-print some names + and it wraps a 'TcRnMessageDetailed', which includes any extra context associated + with this diagnostic. + -} + TcRnMessageWithInfo :: !UnitState + -- ^ The 'UnitState' will allow us to pretty-print + -- some diagnostics with more detail. + -> !TcRnMessageDetailed + -> TcRnMessage + {-| A levity polymorphism check happening during TcRn. -} TcLevityPolyInType :: !Type @@ -34,7 +98,6 @@ data TcRnMessage where -> !ErrInfo -- Extra info accumulated in the TcM monad -> TcRnMessage - {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when a Template Haskell quote implicitly uses 'lift'. diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index 9254f4b91b..fa4e96dbc3 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -15,6 +15,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Env +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) import GHC.Tc.Utils.Monad @@ -27,6 +28,7 @@ import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Annotations import GHC.Types.SrcLoc +import GHC.Types.Error import Control.Monad ( when ) @@ -43,9 +45,10 @@ warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _) - = do { setSrcSpanA loc $ addDiagnosticTc WarningWithoutFlag $ - (text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") + = do { let msg = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ + (text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") + ; setSrcSpanA loc $ addDiagnosticTc msg ; return [] } tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation @@ -61,8 +64,10 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do when (safeLanguageOn dflags) $ failWithTc safeHsErr runAnnotation target expr where - safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + safeHsErr :: TcRnMessage + safeHsErr = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] annProvenanceToTarget :: Module -> AnnProvenance GhcRn -> AnnTarget Name diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 7f337a7be3..326af87c69 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -24,6 +24,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) import GHC.Builtin.Types (multiplicityTy) import GHC.Tc.Gen.Head import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate @@ -39,6 +40,7 @@ import GHC.Core.TyCo.Subst (substTyWithInScope) import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType ) import GHC.Core.Type import GHC.Tc.Types.Evidence +import GHC.Types.Error import GHC.Types.Var.Set import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names @@ -693,7 +695,7 @@ tcVTA fun_ty hs_ty | otherwise = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty - ; failWith $ + ; failWith $ TcRnUnknownMessage $ mkPlainError noHints $ text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ text "to a visible type argument" <+> quotes (ppr hs_ty) } @@ -1175,7 +1177,8 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty ; return (mkHsWrap df_wrap tc_expr) }}}}} | otherwise - = failWithTc (text "tagToEnum# must appear applied to one value argument") + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "tagToEnum# must appear applied to one value argument") where vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args) @@ -1188,9 +1191,10 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty , text "e.g. (tagToEnum# x) :: Bool" ] doc2 = text "Result type must be an enumeration type" - mk_error :: TcType -> SDoc -> SDoc + mk_error :: TcType -> SDoc -> TcRnMessage mk_error ty what - = hang (text "Bad call to tagToEnum#" + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Bad call to tagToEnum#" <+> text "at type" <+> ppr ty) 2 what diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 2d957fd217..d04944661d 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -19,6 +19,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp import GHC.Hs import GHC.Hs.Syn.Type +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Match import GHC.Tc.Gen.Head( tcCheckId ) import GHC.Tc.Utils.TcType @@ -37,6 +38,7 @@ import GHC.Builtin.Types import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Types.Basic( Arity ) +import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -182,7 +184,7 @@ tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syn ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (text "Predicate type of `ifThenElse' depends on result type") + (TcRnUnknownMessage $ mkPlainError noHints $ text "Predicate type of `ifThenElse' depends on result type") ; (pred', fun') <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) (mkCheckExpType r_ty) $ \ _ _ -> @@ -336,8 +338,9 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ - = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), - text "was found where an arrow command was expected"]) + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "The expression", nest 2 (ppr cmd), + text "was found where an arrow command was expected"]) -- | Typechecking for case command alternatives. Used for both -- 'HsCmdCase' and 'HsCmdLamCase'. diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index a92a4320c7..8a83b5540f 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -33,6 +33,7 @@ import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session import GHC.Data.FastString import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin @@ -233,8 +234,9 @@ tcHsBootSigs binds sigs -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: SDoc -badBootDeclErr = text "Illegal declarations in an hs-boot file" +badBootDeclErr :: TcRnMessage +badBootDeclErr = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal declarations in an hs-boot file" ------------------------ tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing @@ -436,7 +438,7 @@ recursivePatSynErr :: -> LHsBinds (GhcPass p) -> TcM a recursivePatSynErr loc binds - = failAt loc $ + = failAt loc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Recursive pattern synonym definition with following bindings:") 2 (vcat $ map pprLBind . bagToList $ binds) where @@ -909,7 +911,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs where report_dup_tyvar_tv_err (n1,n2) | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Couldn't match" <+> quotes (ppr n1) <+> text "with" <+> quotes (ppr n2)) 2 (hang (text "both bound by the partial type signature:") 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) @@ -919,7 +922,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs report_mono_sig_tv_err n | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Can't quantify over" <+> quotes (ppr n)) 2 (hang (text "bound by the partial type signature:") 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) | otherwise -- Can't happen; by now we know it's a partial sig @@ -1011,7 +1015,9 @@ warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () warnMissingSignatures flag msg id = do { env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addDiagnosticTcM (WarningWithFlag flag) (env1, mk_msg tidy_ty) } + ; let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag flag) noHints (mk_msg tidy_ty) + ; addDiagnosticTcM (env1, dia) } where mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] @@ -1027,7 +1033,7 @@ checkOverloadedSig monomorphism_restriction_applies sig , monomorphism_restriction_applies , let orig_sig = sig_inst_sig sig = setSrcSpan (sig_loc orig_sig) $ - failWith $ + failWith $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Overloaded signature conflicts with monomorphism restriction") 2 (ppr orig_sig) | otherwise diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index 04bd4da157..1390c2bdad 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -14,6 +14,7 @@ import GHC.Hs import GHC.Core.Class import GHC.Core.Type ( typeKind ) import GHC.Types.Var( tyVarKind ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType @@ -22,6 +23,7 @@ import GHC.Tc.Solver import GHC.Tc.Validity import GHC.Tc.Utils.TcType import GHC.Builtin.Names +import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -101,9 +103,10 @@ check_instance ty cls defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc +dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) - = hang (text "Multiple default declarations") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) where pp :: LDefaultDecl GhcRn -> SDoc @@ -111,7 +114,8 @@ dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) = text "here was another default declaration" <+> ppr (locA locn) dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" -badDefaultTy :: Type -> [Class] -> SDoc +badDefaultTy :: Type -> [Class] -> TcRnMessage badDefaultTy ty deflt_clss - = hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 18924c39d5..e7fb4384f5 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -237,8 +237,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod -- so that's how we handle it, except we also export the data family -- when a data instance is exported. = do { - ; warnIfFlag Opt_WarnMissingExportList - True + ; addDiagnostic (missingModuleExportWarn $ moduleName _this_mod) ; let avails = map fix_faminst . gresToAvailInfo @@ -284,8 +283,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod exports_from_item (ExportAccum occs earlier_mods) (L loc ie@(IEModuleContents _ lmod@(L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { warnIfFlag Opt_WarnDuplicateExports True - (dupModuleExport mod) ; + = do { addDiagnostic (dupModuleExport mod) ; return Nothing } | otherwise @@ -300,9 +298,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod } ; checkErr exportValid (moduleNotImported mod) - ; warnIfFlag Opt_WarnDodgyExports - (exportValid && null gre_prs) - (nullModuleExport mod) + ; warnIf (exportValid && null gre_prs) (nullModuleExport mod) ; traceRn "efa" (ppr mod $$ ppr all_gres) ; addUsedGREs all_gres @@ -611,8 +607,9 @@ checkPatSynParent parent NoParent gname psErr = exportErrCtxt "pattern synonym" selErr = exportErrCtxt "pattern synonym record selector" - assocClassErr :: SDoc - assocClassErr = text "Pattern synonyms can be bundled only with datatypes." + assocClassErr :: TcRnMessage + assocClassErr = TcRnUnknownMessage $ mkPlainError noHints $ + text "Pattern synonyms can be bundled only with datatypes." handle_pat_syn :: SDoc -> TyCon -- ^ Parent TyCon @@ -641,8 +638,8 @@ checkPatSynParent parent NoParent gname expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) (_, _, _, _, _, res_ty) = patSynSig pat_syn mtycon = fst <$> tcSplitTyConApp_maybe res_ty - typeMismatchError :: SDoc - typeMismatchError = + typeMismatchError :: TcRnMessage + typeMismatchError = TcRnUnknownMessage $ mkPlainError noHints $ text "Pattern synonyms can only be bundled with matching type constructors" $$ text "Couldn't match expected type of" <+> quotes (ppr expected_res_ty) @@ -670,9 +667,7 @@ check_occs ie occs avails | greNameMangledName child == greNameMangledName child' -- Duplicate export -- But we don't want to warn if the same thing is exported -- by two different module exports. See ticket #4478. - -> do { warnIfFlag Opt_WarnDuplicateExports - (not (dupExport_ok child ie ie')) - (dupExportWarn child ie ie') + -> do { warnIf (not (dupExport_ok child ie ie')) (dupExportWarn child ie ie') ; return occs } | otherwise -- Same occ name but different names: an error @@ -734,27 +729,31 @@ dupExport_ok child ie1 ie2 single _ = False -dupModuleExport :: ModuleName -> SDoc +dupModuleExport :: ModuleName -> TcRnMessage dupModuleExport mod - = hsep [text "Duplicate", + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $ + hsep [text "Duplicate", quotes (text "Module" <+> ppr mod), text "in export list"] -moduleNotImported :: ModuleName -> SDoc +moduleNotImported :: ModuleName -> TcRnMessage moduleNotImported mod - = hsep [text "The export item", + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "The export item", quotes (text "module" <+> ppr mod), text "is not imported"] -nullModuleExport :: ModuleName -> SDoc +nullModuleExport :: ModuleName -> TcRnMessage nullModuleExport mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "exports nothing"] + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyExports) noHints $ + hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "exports nothing"] -missingModuleExportWarn :: ModuleName -> SDoc +missingModuleExportWarn :: ModuleName -> TcRnMessage missingModuleExportWarn mod - = hsep [text "The export item", + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingExportList) noHints $ + hsep [text "The export item", quotes (text "module" <+> ppr mod), text "is missing an export list"] @@ -770,20 +769,22 @@ addExportErrCtxt ie = addErrCtxt exportCtxt where exportCtxt = text "In the export:" <+> ppr ie -exportItemErr :: IE GhcPs -> SDoc +exportItemErr :: IE GhcPs -> TcRnMessage exportItemErr export_item - = sep [ text "The export item" <+> quotes (ppr export_item), + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ text "The export item" <+> quotes (ppr export_item), text "attempts to export constructors or class methods that are not visible here" ] -dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> SDoc +dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage dupExportWarn child ie1 ie2 - = hsep [quotes (ppr child), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $ + hsep [quotes (ppr child), + text "is exported by", quotes (ppr ie1), + text "and", quotes (ppr ie2)] -dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc -dcErrMsg ty_con what_is thing parents = +dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> TcRnMessage +dcErrMsg ty_con what_is thing parents = TcRnUnknownMessage $ mkPlainError noHints $ text "The type constructor" <+> quotes (ppr ty_con) <+> text "is not the parent of the" <+> text what_is <+> quotes thing <> char '.' @@ -809,9 +810,10 @@ failWithDcErr parent child parents = do exportClashErr :: GlobalRdrEnv -> GreName -> GreName -> IE GhcPs -> IE GhcPs - -> SDoc + -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2 - = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon , ppr_export child1' gre1' ie1' , ppr_export child2' gre2' ie2' ] diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 40c7052de5..083c7e68a2 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -36,8 +36,10 @@ import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic +import GHC.Types.Error import GHC.Core.Multiplicity import GHC.Core.UsageEnv +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head @@ -1289,7 +1291,8 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head reportAmbiguousField :: TyCon -> TcM () reportAmbiguousField parent_type = - setSrcSpan loc $ warnIfFlag Opt_WarnAmbiguousFields True $ + setSrcSpan loc $ addDiagnostic $ + TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnAmbiguousFields) noHints $ vcat [ text "The record update" <+> ppr rupd <+> text "with type" <+> ppr parent_type <+> text "is ambiguous." @@ -1405,9 +1408,12 @@ checkMissingFields con_like rbinds arg_tys -- Illegal if any arg is strict addErrTc (missingStrictFields con_like []) else do - when (notNull field_strs && null field_labels) - (diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True - (missingFields con_like [])) + when (notNull field_strs && null field_labels) $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) + noHints + (missingFields con_like []) + (diagnosticTc True msg) | otherwise = do -- A record unless (null missing_s_fields) $ do @@ -1422,8 +1428,11 @@ checkMissingFields con_like rbinds arg_tys -- It is not an error (though we may want) to omit a -- lazy field, because we can always use -- (error "Missing field f") instead. - diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True - (missingFields con_like fs) + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) + noHints + (missingFields con_like fs) + diagnosticTc True msg where -- we zonk the fields to get better types in error messages (#18869) @@ -1464,9 +1473,10 @@ fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" -badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc +badFieldTypes :: [(FieldLabelString,TcType)] -> TcRnMessage badFieldTypes prs - = hang (text "Record update for insufficiently polymorphic field" + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Record update for insufficiently polymorphic field" <> plural prs <> colon) 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) @@ -1474,9 +1484,10 @@ badFieldsUpd :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to - -> SDoc + -> TcRnMessage badFieldsUpd rbinds data_cons - = hang (text "No constructor has all these fields:") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "No constructor has all these fields:") 2 (pprQuotedList conflictingFields) -- See Note [Finding the conflicting fields] where @@ -1546,9 +1557,10 @@ Finding the smallest subset is hard, so the code here makes a decent stab, no more. See #7989. -} -mixedSelectors :: [Id] -> [Id] -> SDoc +mixedSelectors :: [Id] -> [Id] -> TcRnMessage mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = text "Cannot use a mixture of pattern synonym and record selectors" $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot use a mixture of pattern synonym and record selectors" $$ text "Record selectors defined by" <+> quotes (ppr (tyConName rep_dc)) <> colon @@ -1563,9 +1575,9 @@ mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" -missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc +missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage missingStrictFields con fields - = vcat [header, nest 2 rest] + = TcRnUnknownMessage $ mkPlainError noHints $ vcat [header, nest 2 rest] where pprField (f,ty) = ppr f <+> dcolon <+> ppr ty rest | null fields = Outputable.empty -- Happens for non-record constructors @@ -1589,15 +1601,17 @@ missingFields con fields -- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) -noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc +noPossibleParents :: [LHsRecUpdField GhcRn] -> TcRnMessage noPossibleParents rbinds - = hang (text "No type has all these fields:") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "No type has all these fields:") 2 (pprQuotedList fields) where fields = map (hfbLHS . unLoc) rbinds -badOverloadedUpdate :: SDoc -badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" +badOverloadedUpdate :: TcRnMessage +badOverloadedUpdate = TcRnUnknownMessage $ mkPlainError noHints $ + text "Record update is ambiguous, and requires a type signature" {- ************************************************************************ @@ -1676,8 +1690,8 @@ checkClosedInStaticForm name = do -- -- when the final node has a non-closed type. -- - explain :: Name -> NotClosedReason -> SDoc - explain name reason = + explain :: Name -> NotClosedReason -> TcRnMessage + explain name reason = TcRnUnknownMessage $ mkPlainError noHints $ quotes (ppr name) <+> text "is used in a static form but it is not closed" <+> text "because it" $$ diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index ab7188fa97..4204071b7d 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -39,6 +39,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Expr @@ -306,11 +307,13 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh | cconv == PrimCallConv = do dflags <- getDynFlags checkTc (xopt LangExt.GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") + (TcRnUnknownMessage $ mkPlainError noHints $ + text "Use GHCForeignImportPrim to allow `foreign import prim'.") checkCg checkCOrAsmOrLlvmOrInterp checkCTarget target checkTc (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + (TcRnUnknownMessage $ mkPlainError noHints $ + text "The safe/unsafe annotation should not be used with `foreign import prim'.") checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty @@ -326,7 +329,8 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh case target of StaticTarget _ _ _ False | not (null arg_tys) -> - addErrTc (text "`value' imports cannot have function types") + addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + text "`value' imports cannot have function types") _ -> return () return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src @@ -344,8 +348,9 @@ checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" checkMissingAmpersand :: [Type] -> Type -> TcM () checkMissingAmpersand arg_tys res_ty | null arg_tys && isFunPtrTy res_ty - = addDiagnosticTc (WarningWithFlag Opt_WarnDodgyForeignImports) - (text "possible missing & in foreign import of FunPtr") + = addDiagnosticTc $ TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyForeignImports) noHints + (text "possible missing & in foreign import of FunPtr") | otherwise = return () @@ -519,7 +524,8 @@ checkCg check = do _ -> case check bcknd of IsValid -> return () - NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) + NotValid err -> + addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal foreign declaration:" <+> err) -- Calling conventions @@ -531,26 +537,33 @@ checkCConv StdCallConv = do dflags <- getDynFlags if platformArch platform == ArchX86 then return StdCallConv else do -- This is a warning, not an error. see #3336 - addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions) - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnUnsupportedCallingConventions) + noHints + (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + addDiagnosticTc msg return CCallConv -checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") - return PrimCallConv +checkCConv PrimCallConv = do + addErrTc $ TcRnUnknownMessage $ mkPlainError noHints + (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv checkCConv JavaScriptCallConv = do dflags <- getDynFlags if platformArch (targetPlatform dflags) == ArchJavaScript then return JavaScriptCallConv - else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") - return JavaScriptCallConv + else do + addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "The `javascript' calling convention is unsupported on this platform") + return JavaScriptCallConv -- Warnings -check :: Validity -> (SDoc -> SDoc) -> TcM () +check :: Validity -> (SDoc -> TcRnMessage) -> TcM () check IsValid _ = return () check (NotValid doc) err_fn = addErrTc (err_fn doc) -illegalForeignTyErr :: SDoc -> SDoc -> SDoc +illegalForeignTyErr :: SDoc -> SDoc -> TcRnMessage illegalForeignTyErr arg_or_res extra - = hang msg 2 extra + = TcRnUnknownMessage $ mkPlainError noHints $ hang msg 2 extra where msg = hsep [ text "Unacceptable", arg_or_res , text "type in foreign declaration:"] @@ -560,9 +573,10 @@ argument, result :: SDoc argument = text "argument" result = text "result" -badCName :: CLabelString -> SDoc +badCName :: CLabelString -> TcRnMessage badCName target - = sep [quotes (ppr target) <+> text "is not a valid C identifier"] + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [quotes (ppr target) <+> text "is not a valid C identifier"] foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc foreignDeclCtxt fo diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 0e90a22862..cd43111123 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -39,6 +39,7 @@ import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic +import GHC.Types.Error import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv ( FamInstEnvs ) @@ -461,7 +462,7 @@ tcInferRecSelId (FieldOcc sel_name lbl) -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here - _ -> failWithTc $ + _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ ppr thing <+> text "used where a value identifier was expected" } ------------------------ @@ -511,17 +512,20 @@ lookupParents is_selector rdr Nothing -> failWithTc (notSelector (greMangledName gre)) } -fieldNotInType :: RecSelParent -> RdrName -> SDoc +fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr - = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr + = TcRnUnknownMessage $ mkPlainError noHints $ + unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr -notSelector :: Name -> SDoc +notSelector :: Name -> TcRnMessage notSelector field - = hsep [quotes (ppr field), text "is not a record selector"] + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [quotes (ppr field), text "is not a record selector"] -naughtyRecordSel :: OccName -> SDoc +naughtyRecordSel :: OccName -> TcRnMessage naughtyRecordSel lbl - = text "Cannot use record selector" <+> quotes (ppr lbl) <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot use record selector" <+> quotes (ppr lbl) <+> text "as a function due to escaped type variables" $$ text "Probable fix: use pattern-matching syntax instead" @@ -720,7 +724,7 @@ tc_infer_id id_name ATcTyCon tc -> fail_tycon tc ATyVar name _ -> fail_tyvar name - _ -> failWithTc $ + _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ ppr thing <+> text "used where a value identifier was expected" } where fail_tycon tc = do @@ -731,14 +735,14 @@ tc_infer_id id_name Just gre -> nest 2 (pprNameProvenance gre) Nothing -> empty suggestions <- get_suggestions dataName - failWithTc (msg $$ pprov $$ suggestions) + failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions)) fail_tyvar name = do let msg = text "Illegal term-level use of the type variable" <+> quotes (ppr name) pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc name)) suggestions <- get_suggestions varName - failWithTc (msg $$ pprov $$ suggestions) + failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions)) get_suggestions ns = do let occ = mkOccNameFS ns (occNameFS (occName id_name)) @@ -796,9 +800,10 @@ tcInferPatSyn id_name ps Just (expr,ty) -> return (expr,ty) Nothing -> failWithTc (nonBidirectionalErr id_name) -nonBidirectionalErr :: Outputable name => name -> SDoc -nonBidirectionalErr name = text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" +nonBidirectionalErr :: Outputable name => name -> TcRnMessage +nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $ + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" {- Note [Typechecking data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -978,9 +983,10 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) checkCrossStageLifting _ _ _ = return () -polySpliceErr :: Id -> SDoc +polySpliceErr :: Id -> TcRnMessage polySpliceErr id - = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Can't splice the polymorphic local variable" <+> quotes (ppr id) {- Note [Lifting strings] diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 8de1974627..7d9682582a 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -78,6 +78,7 @@ import GHC.Prelude import GHC.Hs import GHC.Rename.Utils +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Core.Predicate @@ -96,6 +97,7 @@ import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBin tcInstInvisibleTyBinder ) import GHC.Core.Type import GHC.Builtin.Types.Prim +import GHC.Types.Error import GHC.Types.Name.Env import GHC.Types.Name.Reader( lookupLocalRdrOcc ) import GHC.Types.Var @@ -624,7 +626,8 @@ tcHsDeriv hs_ty (kind_args, _) = splitFunTys (tcTypeKind pred) ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) - Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } + Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } -- | Typecheck a deriving strategy. For most deriving strategies, this is a -- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. @@ -1130,7 +1133,7 @@ tc_hs_type _ ty@(HsBangTy _ bang _) _ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210, #14761) - = do { let bangError err = failWith $ + = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ text err <+> text "annotation cannot appear nested inside a type" ; case bang of @@ -1141,7 +1144,8 @@ tc_hs_type _ ty@(HsBangTy _ bang _) _ tc_hs_type _ ty@(HsRecTy {}) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now - = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Record syntax is illegal here:" <+> ppr ty) -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. -- Here we get rid of it and add the finalizers to the global environment @@ -1155,7 +1159,8 @@ tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) -- This should never happen; type splices are expanded by the renamer tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (text "Unexpected type splice:" <+> ppr ty) + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Unexpected type splice:" <+> ppr ty) ---------- Functions and applications tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind @@ -1703,8 +1708,9 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args n_initial_val_args _ = 0 ty_app_err arg ty - = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) + = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) mkAppTyM :: TCvSubst @@ -2722,8 +2728,8 @@ zipBinders = zip_binders [] emptyTCvSubst | otherwise = (reverse acc, bs, substTy subst ki) -tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc -tooManyBindersErr ki bndrs = +tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage +tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Not a function kind:") 4 (ppr ki) $$ hang (text "but extra binders found:") @@ -3770,8 +3776,8 @@ checkDataKindSig data_sort kind AnyBoxedKind -> ppr boxedRepDataConTyCon LiftedKind -> ppr liftedTypeKind - err_msg :: DynFlags -> SDoc - err_msg dflags = + err_msg :: DynFlags -> TcRnMessage + err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $ sep [ sep [ pp_dec <+> text "has non-" <> pp_allowed_kind dflags @@ -3796,8 +3802,8 @@ checkDataKindSig data_sort kind checkClassKindSig :: Kind -> TcM () checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg where - err_msg :: SDoc - err_msg = + err_msg :: TcRnMessage + err_msg = TcRnUnknownMessage $ mkPlainError noHints $ text "Kind signature on a class must end with" <+> ppr constraintKind $$ text "unobscured by type families" @@ -4248,7 +4254,8 @@ tc_lhs_kind_sig mode ctxt hs_kind promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") 2 (parens reason)) where reason = case err of diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index ece6c47420..06118359f1 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -41,6 +41,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC , tcCheckMonoExpr, tcCheckMonoExprNC , tcCheckPolyExpr ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat @@ -68,6 +69,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags ) +import GHC.Types.Error import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id @@ -1124,7 +1126,8 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) | null bad_matches = return () | otherwise - = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (vcat [ text "Equations for" <+> quotes (ppr fun) <+> text "have different numbers of arguments" , nest 2 (ppr (getLocA match1)) , nest 2 (ppr (getLocA (head bad_matches)))]) diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 0564d15cf9..be5a243dec 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -32,10 +32,12 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho ) import GHC.Hs import GHC.Hs.Syn.Type import GHC.Rename.Utils +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate +import GHC.Types.Error import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name @@ -773,9 +775,10 @@ tcPatSig in_pat_bind sig res_ty 2 (ppr res_ty)) ] ; return (tidy_env, msg) } -patBindSigErr :: [(Name,TcTyVar)] -> SDoc +patBindSigErr :: [(Name,TcTyVar)] -> TcRnMessage patBindSigErr sig_tvs - = hang (text "You cannot bind scoped type variable" <> plural sig_tvs + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "You cannot bind scoped type variable" <> plural sig_tvs <+> pprQuotedList (map fst sig_tvs)) 2 (text "in a pattern binding signature") @@ -946,7 +949,8 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled ; gadts_on <- xoptM LangExt.GADTs ; families_on <- xoptM LangExt.TypeFamilies ; checkTc (no_equalities || gadts_on || families_on) - (text "A pattern match on a GADT requires the" <+> + (TcRnUnknownMessage $ mkPlainError noHints $ + text "A pattern match on a GADT requires the" <+> text "GADTs or TypeFamilies language extension") -- #2905 decided that a *pattern-match* of a GADT -- should require the GADT language flag. @@ -1289,7 +1293,8 @@ tcConTyArg penv rn_ty thing_inside -- by the calls to unifyType in tcConArgs, which will also unify -- kinds. ; when (not (null sig_ibs) && inPatBind penv) $ - addErr (text "Binding type variables is not allowed in pattern bindings") + addErr (TcRnUnknownMessage $ mkPlainError noHints $ + text "Binding type variables is not allowed in pattern bindings") ; result <- tcExtendNameTyVarEnv sig_wcs $ tcExtendNameTyVarEnv sig_ibs $ thing_inside @@ -1319,9 +1324,10 @@ addDataConStupidTheta data_con inst_tys conTyArgArityErr :: ConLike -> Int -- expected # of arguments -> Int -- actual # of arguments - -> SDoc + -> TcRnMessage conTyArgArityErr con_like expected_number actual_number - = text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number {- @@ -1453,18 +1459,21 @@ checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existenti checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat checkExistentials _ _ _ = return () -existentialLazyPat :: SDoc +existentialLazyPat :: TcRnMessage existentialLazyPat - = hang (text "An existential or GADT data constructor cannot be used") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "An existential or GADT data constructor cannot be used") 2 (text "inside a lazy (~) pattern") -existentialProcPat :: SDoc +existentialProcPat :: TcRnMessage existentialProcPat - = text "Proc patterns cannot use existential or GADT data constructors" + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Proc patterns cannot use existential or GADT data constructors" -badFieldCon :: ConLike -> FieldLabelString -> SDoc +badFieldCon :: ConLike -> FieldLabelString -> TcRnMessage badFieldCon con field - = hsep [text "Constructor" <+> quotes (ppr con), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Constructor" <+> quotes (ppr con), text "does not have field", quotes (ppr field)] polyPatSig :: TcType -> SDoc diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 850b0bb48a..f318bfd140 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -31,6 +31,8 @@ import GHC.Driver.Backend import GHC.Hs + +import GHC.Tc.Errors.Types ( TcRnMessage(..), LevityCheckProvenance(..) ) import GHC.Tc.Gen.HsType import GHC.Tc.Types import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) @@ -44,12 +46,12 @@ import GHC.Tc.Utils.Unify( tcSkolemise, unifyType ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) -import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Core( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity +import GHC.Types.Error import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, setInlinePragma , mkLocalId, realIdUnfolding ) @@ -621,10 +623,12 @@ addInlinePrags poly_id prags_for_me warn_multiple_inlines inl2 inls | otherwise = setSrcSpanA loc $ - addDiagnosticTc WarningWithoutFlag - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints $ + (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (inl1:inl2:inls)))) + in addDiagnosticTc dia pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) @@ -754,9 +758,11 @@ tcSpecPrags poly_id prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) warn_discarded_sigs - = addDiagnosticTc WarningWithoutFlag - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) + = let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints $ + (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) bad_sigs))) + in addDiagnosticTc dia -------------- tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] @@ -769,10 +775,11 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) -- However we want to use fun_name in the error message, since that is -- what the user wrote (#8537) = addErrCtxt (spec_ctxt prag) $ - do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) - -- Note [SPECIALISE pragmas] + do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $ + TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints + (text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name)) + -- Note [SPECIALISE pragmas] ; spec_prags <- mapM tc_one hs_tys ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) ; return spec_prags } @@ -837,7 +844,9 @@ tcImpSpec (name, prag) ; if hasSomeUnfolding (realIdUnfolding id) -- See Note [SPECIALISE pragmas for imported Ids] then tcSpecPrag id prag - else do { addDiagnosticTc WarningWithoutFlag (impSpecErr name) + else do { let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (impSpecErr name) + ; addDiagnosticTc dia ; return [] } } impSpecErr :: Name -> SDoc diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 72fc259e83..b4d15ee4ab 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -323,7 +323,8 @@ tcTExpTy m_ty exp_ty ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } where err_msg ty - = vcat [ text "Illegal polytype:" <+> ppr ty + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal polytype:" <+> ppr ty , text "The type of a Typed Template Haskell expression must" <+> text "not have any quantification." ] @@ -1032,7 +1033,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- see where this splice is do { mb_result <- run_and_convert expr_span hval ; case mb_result of - Left err -> failWithTc err + Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) ; return $! result } } @@ -1050,7 +1051,7 @@ runMeta' show_code ppr_hs run_and_convert expr let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", nest 2 (text exn_msg), if show_code then text "Code:" <+> ppr expr else empty] - failWithTc msg + failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) {- Note [Running typed splices in the zonker] @@ -1166,8 +1167,9 @@ instance TH.Quasi TcM where -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addDiagnostic WarningWithoutFlag (text msg) + qReport True msg = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg) + qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM @@ -1215,7 +1217,7 @@ instance TH.Quasi TcM where th_origin <- getThSpliceOrigin let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of - Left exn -> failWithTc $ + Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Error in a declaration passed to addTopDecls:") 2 exn Right ds -> return ds @@ -1233,7 +1235,8 @@ instance TH.Quasi TcM where checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl _ - = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" bindName :: RdrName -> TcM () bindName (Exact n) @@ -1242,7 +1245,7 @@ instance TH.Quasi TcM where } bindName name = - addErr $ + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") @@ -1268,8 +1271,8 @@ instance TH.Quasi TcM where 2 (text "Plugins in the current package can't be specified.") case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err + Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err + FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err _ -> return () th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv updTcRef th_coreplugins_var (plugin:) @@ -1294,7 +1297,7 @@ instance TH.Quasi TcM where th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ text + unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Can't add documentation to" <+> ppr_loc doc_loc <+> text "as it isn't inside the current module" updTcRef th_doc_var (Map.insert resolved_doc_loc s) @@ -1380,7 +1383,7 @@ lookupThInstName th_type = do Right (_, (inst:_)) -> return $ getName inst Right (_, []) -> noMatches where - noMatches = failWithTc $ + noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't find any instances of" <+> ppr_th th_type <+> text "to add documentation to" @@ -1417,7 +1420,7 @@ lookupThInstName th_type = do inst_cls_name TH.WildCardT = inst_cls_name_err inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err - inst_cls_name_err = failWithTc $ + inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't work out what instance" <+> ppr_th th_type <+> text "is supposed to be" @@ -1707,15 +1710,16 @@ reifyInstances' th_nm th_tys ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances'2" (ppr matches) ; return $ Right (tc, map fim_instance matches) } - _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } + _ -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application")) } where doc = ClassInstanceCtx bale_out msg = failWithTc msg cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc msg + Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) Right ty -> return ty {- @@ -1808,17 +1812,18 @@ tcLookupTh name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc msg + Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) }}}} -notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" +notInScope :: TH.Name -> TcRnMessage +notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" -- Ugh! Rather an indirect way to display the name -notInEnv :: Name -> SDoc -notInEnv name = quotes (ppr name) <+> - text "is not in the type environment at a reify" +notInEnv :: Name -> TcRnMessage +notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr name) <+> text "is not in the type environment at a reify" ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -1826,7 +1831,7 @@ reifyRoles th_name = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) + _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing)) } where reify_role Nominal = TH.NominalR @@ -2620,9 +2625,10 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys noTH :: SDoc -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> s <+> - text "in Template Haskell:", - nest 2 d]) +noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (hsep [text "Can't represent" <+> s <+> + text "in Template Haskell:", + nest 2 d]) ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x) diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 015ae301cf..4818fd9ad9 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -29,6 +29,7 @@ import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX ) @@ -41,6 +42,7 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo +import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name @@ -56,6 +58,7 @@ import GHC.Data.Bag( Bag, unionBags, unitBag ) import GHC.Data.Maybe import Control.Monad +import Data.Bifunctor ( second ) import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Function ( on ) @@ -949,7 +952,7 @@ unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False) reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () reportConflictingInjectivityErrs _ [] _ = return () reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn - = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] + = addErrs [second mk_err $ buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] where herald = text "Type family equation right-hand sides overlap; this violates" $$ text "the family's injectivity annotation:" @@ -974,7 +977,7 @@ reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn herald $$ text "In the type family equation:") (tyfamEqn :| []) - in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) + in addErrAt loc (mk_err $ pprWithExplicitKindsWhen has_kinds doc) where herald = sep [ what <+> text "variable" <> pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) @@ -991,7 +994,7 @@ reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn -- level of RHS reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () reportTfHeadedErr fam_tc branch - = addErrs [buildInjectivityError fam_tc + = addErrs [second mk_err $ buildInjectivityError fam_tc (injectivityErrorHerald $$ text "RHS of injective type family equation cannot" <+> text "be a type family:") @@ -1001,7 +1004,7 @@ reportTfHeadedErr fam_tc branch -- but LHS pattern is not a bare type variable. reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () reportBareVariableInRHSErr fam_tc tys branch - = addErrs [buildInjectivityError fam_tc + = addErrs [second mk_err $ buildInjectivityError fam_tc (injectivityErrorHerald $$ text "RHS of injective type family equation is a bare" <+> text "type variable" $$ @@ -1009,6 +1012,9 @@ reportBareVariableInRHSErr fam_tc tys branch text "variables:" <+> pprQuotedList tys) (branch :| [])] +mk_err :: SDoc -> TcRnMessage +mk_err = TcRnUnknownMessage . mkPlainError noHints + buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc) buildInjectivityError fam_tc herald (eqn1 :| rest_eqns) = ( coAxBranchSpan eqn1 @@ -1023,7 +1029,7 @@ reportConflictInstErr fam_inst (match1 : _) , let sorted = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst] fi1 = head sorted span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - = setSrcSpan span $ addErr $ + = setSrcSpan span $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Conflicting family instance declarations:") 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) | fi <- sorted diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 08d082ba32..08005f1a74 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -259,8 +259,10 @@ tcRnModuleTcRnM hsc_env mod_sum ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } - ; when (notNull prel_imports) $ - addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn) + ; when (notNull prel_imports) $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn) + addDiagnostic msg ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = @@ -609,7 +611,7 @@ tc_rn_src_decls ds { Nothing -> return () ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpanA loc - $ addErr (text + $ addErr (TcRnUnknownMessage $ mkPlainError noHints $ text ("Declaration splices are not " ++ "permitted inside top-level " ++ "declarations added with addTopDecls")) @@ -731,7 +733,8 @@ tcRnHsBootDecls hsc_src decls badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _) - = addErrAt (locA loc) (char 'A' <+> text what + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of HsBootFile -> text "hs-boot" @@ -1357,24 +1360,27 @@ emptyRnEnv2 :: RnEnv2 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet ---------------- -missingBootThing :: Bool -> Name -> String -> SDoc +missingBootThing :: Bool -> Name -> String -> TcRnMessage missingBootThing is_boot name what - = quotes (ppr name) <+> text "is exported by the" + = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr name) <+> text "is exported by the" <+> (if is_boot then text "hs-boot" else text "hsig") <+> text "file, but not" <+> text what <+> text "the module" -badReexportedBootThing :: Bool -> Name -> Name -> SDoc +badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage badReexportedBootThing is_boot name name' - = withUserStyle alwaysQualify AllTheWay $ vcat + = TcRnUnknownMessage $ mkPlainError noHints $ + withUserStyle alwaysQualify AllTheWay $ vcat [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") <+> text "file (re)exports" <+> quotes (ppr name) , text "but the implementing module exports a different identifier" <+> quotes (ppr name') ] -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc +bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage bootMisMatch is_boot extra_info real_thing boot_thing - = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc + = TcRnUnknownMessage $ mkPlainError noHints $ + pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc where to_doc = pprTyThingInContext $ showToHeader { ss_forall = @@ -1402,9 +1408,10 @@ bootMisMatch is_boot extra_info real_thing boot_thing extra_info ] -instMisMatch :: DFunId -> SDoc +instMisMatch :: DFunId -> TcRnMessage instMisMatch dfun - = hang (text "instance" <+> ppr (idType dfun)) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "instance" <+> ppr (idType dfun)) 2 (text "is defined in the hs-boot file, but not in the module itself") {- @@ -1592,7 +1599,9 @@ tcPreludeClashWarn warnFlag name = do ; traceTc "tcPreludeClashWarn/prelude_functions" (hang (ppr name) 4 (sep [ppr clashingElts])) - ; let warn_msg x = addDiagnosticAt (WarningWithFlag warnFlag) (nameSrcSpan (greMangledName x)) (hsep + ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $ + TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep [ text "Local definition of" , (quotes . ppr . nameOccName . greMangledName) x , text "clashes with a future Prelude name." ] @@ -1703,7 +1712,8 @@ tcMissingParentClassWarn warnFlag isName shouldName -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst warnMsg (KnownTc name:_) = - addDiagnosticAt (WarningWithFlag warnFlag) instLoc $ + addDiagnosticAt instLoc $ + TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" , (ppr . nameOccName . className) isClass @@ -1837,7 +1847,8 @@ checkMain explicit_mod_hdr export_ies -- in other modes, add error message and go on with typechecking. noMainMsg main_mod main_occ - = text "The" <+> ppMainFn main_occ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "The" <+> ppMainFn main_occ <+> text "is not" <+> text defOrExp <+> text "module" <+> quotes (ppr main_mod) @@ -2177,7 +2188,8 @@ tcRnStmt hsc_env rdr_stmt return (global_ids, zonked_expr, fix_env) } where - bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", + bad_unboxed id = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (sep [text "GHCi can't bind a variable of unlifted type:", nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))]) {- @@ -2525,8 +2537,8 @@ isGHCiMonad hsc_env ty _ <- tcLookupInstance ghciClass [userTy] return name - Just _ -> failWithTc $ text "Ambiguous type!" - Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + Just _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" + Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) -- | How should we infer a type? See Note [TcRnExprMode] data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) @@ -2799,7 +2811,8 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) + ; when (null names) (addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) diff --git a/compiler/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot index 2748c769e4..40d89fe727 100644 --- a/compiler/GHC/Tc/Module.hs-boot +++ b/compiler/GHC/Tc/Module.hs-boot @@ -2,11 +2,11 @@ module GHC.Tc.Module where import GHC.Prelude import GHC.Types.TyThing(TyThing) +import GHC.Tc.Errors.Types (TcRnMessage) import GHC.Tc.Types (TcM) -import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name) checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> SDoc -badReexportedBootThing :: Bool -> Name -> Name -> SDoc +missingBootThing :: Bool -> Name -> String -> TcRnMessage +badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index b37cc33451..3840d833b4 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -39,6 +39,7 @@ import GHC.Utils.Outputable import GHC.Builtin.Utils import GHC.Builtin.Names import GHC.Tc.Errors +import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Solver.Interact import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) @@ -1343,10 +1344,10 @@ decideMonoTyVars infer_mode name_taus psigs candidates mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs -- Warn about the monomorphism restriction - ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ - diagnosticTc (WarningWithFlag Opt_WarnMonomorphism) - (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) - mr_msg + ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMonomorphism) noHints mr_msg + diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia ; traceTc "decideMonoTyVars" $ vcat [ text "infer_mode =" <+> ppr infer_mode @@ -1794,7 +1795,8 @@ maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples }) -- Typically if we blow the limit we are going to report some other error -- (an unsolved constraint), and we don't want that error to suppress -- the iteration limit warning! - addErrTcS (hang (text "solveWanteds: too many iterations" + addErrTcS $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "solveWanteds: too many iterations" <+> parens (text "limit =" <+> ppr limit)) 2 (vcat [ text "Unsolved:" <+> ppr wc , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index 2375fc749a..171cb958f2 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -11,12 +11,14 @@ module GHC.Tc.Solver.Interact ( import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..), infinity, IntWithInf, intGtLimit ) +import GHC.Types.Error import GHC.Tc.Solver.Canonical import GHC.Types.Var.Set import GHC.Core.Type as Type import GHC.Core.InstEnv ( DFunInstType ) import GHC.Types.Var +import GHC.Tc.Errors.Types import GHC.Tc.Utils.TcType import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) @@ -120,7 +122,8 @@ solveSimpleWanteds simples go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) go n limit wc | n `intGtLimit` limit - = failTcS (hang (text "solveSimpleWanteds: too many iterations" + = failTcS $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "solveSimpleWanteds: too many iterations" <+> parens (text "limit =" <+> ppr limit)) 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" , text "Simples =" <+> ppr simples diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 74c93c29ac..4b0523b7f2 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -146,6 +146,7 @@ import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon import GHC.Tc.Errors ( solverDepthErrorTcS ) +import GHC.Tc.Errors.Types import GHC.Types.Name import GHC.Types.TyThing @@ -1241,11 +1242,11 @@ wrapWarnTcS :: TcM a -> TcS a -- There's no static check; it's up to the user wrapWarnTcS = wrapTcS -failTcS, panicTcS :: SDoc -> TcS a -warnTcS :: WarningFlag -> SDoc -> TcS () -addErrTcS :: SDoc -> TcS () +panicTcS :: SDoc -> TcS a +failTcS :: TcRnMessage -> TcS a +warnTcS, addErrTcS :: TcRnMessage -> TcS () failTcS = wrapTcS . TcM.failWith -warnTcS flag = wrapTcS . TcM.addDiagnostic (WarningWithFlag flag) +warnTcS msg = wrapTcS (TcM.addDiagnostic msg) addErrTcS = wrapTcS . TcM.addErr panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index a025190003..07422604c8 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -33,7 +33,7 @@ import GHC.Driver.Session import GHC.Hs -import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) +import GHC.Tc.Errors.Types ( TcRnMessage(..), LevityCheckProvenance(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -70,6 +70,7 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Unify +import GHC.Types.Error import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Env @@ -835,7 +836,7 @@ swizzleTcTyConBndrs tc_infos report_dup :: (Name,Name) -> TcM () report_dup (n1,n2) - = setSrcSpan (getSrcSpan n2) $ addErrTc $ + = setSrcSpan (getSrcSpan n2) $ addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Different names for the same type variable:") 2 info where info | nameOccName n1 /= nameOccName n2 @@ -2534,7 +2535,8 @@ tcDefaultAssocDecl _ [] = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (text "More than one default declaration for" + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + text "More than one default declaration for" <+> ppr (tyFamInstDeclName (unLoc d1))) tcDefaultAssocDecl fam_tc @@ -2820,7 +2822,8 @@ tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) do { let tvs = binderVars tcbs ; dflags <- getDynFlags ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (text "Illegal injectivity annotation" $$ + (TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal injectivity annotation" $$ text "Use TypeFamilyDependencies to allow this") ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds @@ -4216,7 +4219,7 @@ checkValidTyCon tc ; ClosedSynFamilyTyCon Nothing -> return () ; AbstractClosedSynFamilyTyCon -> do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ + ; checkTc hsBoot $ TcRnUnknownMessage $ mkPlainError noHints $ text "You may define an abstract closed type family" $$ text "only in a .hs-boot file" } ; DataFamilyTyCon {} -> return () @@ -4293,10 +4296,10 @@ checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () -- See Note [Checking partial record field] checkPartialRecordField all_cons fld = setSrcSpan loc $ - warnIfFlag Opt_WarnPartialFields - (not is_exhaustive && not (startsWithUnderscore occ_name)) - (sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr occ_name)]) + warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) + (TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ + sep [text "Use of partial record field selector" <> colon, + nest 2 $ quotes (ppr occ_name)]) where loc = getSrcSpan (flSelector fld) occ_name = occName fld @@ -4397,11 +4400,13 @@ checkValidDataCon dflags existential_ok tc con check_bang bang rep_bang n | HsSrcBang _ _ SrcLazy <- bang , not (xopt LangExt.StrictData dflags) - = addErrTc (bad_bang n (text "Lazy annotation (~) without StrictData")) + = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (bad_bang n (text "Lazy annotation (~) without StrictData")) | HsSrcBang _ want_unpack strict_mark <- bang , isSrcUnpacked want_unpack, not (is_strict strict_mark) - = addDiagnosticTc WarningWithoutFlag (bad_bang n (text "UNPACK pragma lacks '!'")) + = addDiagnosticTc $ TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) | HsSrcBang _ want_unpack _ <- bang , isSrcUnpacked want_unpack @@ -4417,7 +4422,8 @@ checkValidDataCon dflags existential_ok tc con -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) , isHomeUnitDefinite (hsc_home_unit hsc_env) - = addDiagnosticTc WarningWithoutFlag (bad_bang n (text "Ignoring unusable UNPACK pragma")) + = addDiagnosticTc $ TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma")) | otherwise = return () @@ -4476,17 +4482,18 @@ checkNewDataCon con ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; let allowedArgType = unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True - ; checkTc allowedArgType $ vcat + ; checkTc allowedArgType $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" ] ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags ; let check_con what msg = - checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + checkTc what $ TcRnUnknownMessage $ mkPlainError noHints $ + (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) ; checkTc (ok_mult (scaledMult arg_ty1)) $ - text "A newtype constructor must be linear" + TcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear" ; check_con (null eq_spec) $ text "A newtype constructor must have a return type of form T a1 ... an" @@ -4541,7 +4548,7 @@ checkValidClass cls ; unless undecidable_super_classes $ case checkClassCycles cls of Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc err + addErrTc (TcRnUnknownMessage $ mkPlainError noHints err) Nothing -> return () -- Check the class operations. @@ -4684,6 +4691,7 @@ checkValidClass cls -- default foo2 :: a -> b unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ + TcRnUnknownMessage $ mkPlainError noHints $ hang (text "The default type signature for" <+> ppr sel_id <> colon) 2 (ppr dm_ty) @@ -4702,13 +4710,15 @@ checkFamFlag tc_name = do { idx_tys <- xoptM LangExt.TypeFamilies ; checkTc idx_tys err_msg } where - err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilies to allow indexed type families") + err_msg :: TcRnMessage + err_msg = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) + 2 (text "Enable TypeFamilies to allow indexed type families") checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () checkResultSigFlag tc_name (TyVarSig _ tvb) = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ + ; checkTc ty_fam_deps $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) 2 (text "Enable TypeFamilyDependencies to allow result variable names") } checkResultSigFlag _ _ = return () -- other cases OK @@ -5026,9 +5036,10 @@ checkValidRoles tc check_ty_roles env role ty report_error doc - = addErrTc $ vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] + = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Internal error in role inference:", + doc, + text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] {- ************************************************************************ @@ -5107,15 +5118,17 @@ tcAddClosedTypeFamilyDeclCtxt tc ctxt = text "In the equations for closed type family" <+> quotes (ppr tc) -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc +resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage resultTypeMisMatch field_name con1 con2 - = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "have a common field" <+> quotes (ppr field_name) <> comma], nest 2 $ text "but have different result types"] -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc +fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage fieldTypeMisMatch field_name con1 con2 - = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] dataConCtxt :: [LocatedN Name] -> SDoc @@ -5134,88 +5147,101 @@ classOpCtxt :: Var -> Type -> SDoc classOpCtxt sel_id tau = sep [text "When checking the class method:", nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] -classArityErr :: Int -> Class -> SDoc +classArityErr :: Int -> Class -> TcRnMessage classArityErr n cls | n == 0 = mkErr "No" "no-parameter" | otherwise = mkErr "Too many" "multi-parameter" where - mkErr howMany allowWhat = + mkErr howMany allowWhat = TcRnUnknownMessage $ mkPlainError noHints $ vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), parens (text ("Enable MultiParamTypeClasses to allow " ++ allowWhat ++ " classes"))] -classFunDepsErr :: Class -> SDoc +classFunDepsErr :: Class -> TcRnMessage classFunDepsErr cls - = vcat [text "Fundeps in class" <+> quotes (ppr cls), + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Fundeps in class" <+> quotes (ppr cls), parens (text "Enable FunctionalDependencies to allow fundeps")] -badMethPred :: Id -> TcPredType -> SDoc +badMethPred :: Id -> TcPredType -> TcRnMessage badMethPred sel_id pred - = vcat [ hang (text "Constraint" <+> quotes (ppr pred) + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Constraint" <+> quotes (ppr pred) <+> text "in the type of" <+> quotes (ppr sel_id)) 2 (text "constrains only the class type variables") , text "Enable ConstrainedClassMethods to allow it" ] -noClassTyVarErr :: Class -> TyCon -> SDoc +noClassTyVarErr :: Class -> TyCon -> TcRnMessage noClassTyVarErr clas fam_tc - = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) , text "mentions none of the type or kind variables of the class" <+> quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] -badDataConTyCon :: DataCon -> Type -> SDoc +badDataConTyCon :: DataCon -> Type -> TcRnMessage badDataConTyCon data_con res_ty_tmpl - = hang (text "Data constructor" <+> quotes (ppr data_con) <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Data constructor" <+> quotes (ppr data_con) <+> text "returns type" <+> quotes (ppr actual_res_ty)) 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) where actual_res_ty = dataConOrigResTy data_con -badGadtDecl :: Name -> SDoc +badGadtDecl :: Name -> TcRnMessage badGadtDecl tc_name - = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] -badExistential :: DataCon -> SDoc +badExistential :: DataCon -> TcRnMessage badExistential con - = sdocOption sdocLinearTypes (\show_linear_types -> + = TcRnUnknownMessage $ mkPlainError noHints $ + sdocOption sdocLinearTypes (\show_linear_types -> hang (text "Data constructor" <+> quotes (ppr con) <+> text "has existential type variables, a context, or a specialised result type") 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con) , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) -badStupidTheta :: Name -> SDoc +badStupidTheta :: Name -> TcRnMessage badStupidTheta tc_name - = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) + = TcRnUnknownMessage $ mkPlainError noHints $ + text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) -newtypeConError :: Name -> Int -> SDoc +newtypeConError :: Name -> Int -> TcRnMessage newtypeConError tycon n - = sep [text "A newtype must have exactly one constructor,", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "A newtype must have exactly one constructor,", nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] -newtypeStrictError :: DataCon -> SDoc +newtypeStrictError :: DataCon -> TcRnMessage newtypeStrictError con - = sep [text "A newtype constructor cannot have a strictness annotation,", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "A newtype constructor cannot have a strictness annotation,", nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] -newtypeFieldErr :: DataCon -> Int -> SDoc +newtypeFieldErr :: DataCon -> Int -> TcRnMessage newtypeFieldErr con_name n_flds - = sep [text "The constructor of a newtype must have exactly one field", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "The constructor of a newtype must have exactly one field", nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] -badSigTyDecl :: Name -> SDoc +badSigTyDecl :: Name -> TcRnMessage badSigTyDecl tc_name - = vcat [ text "Illegal kind signature" <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal kind signature" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] -emptyConDeclsErr :: Name -> SDoc +emptyConDeclsErr :: Name -> TcRnMessage emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> text "has no constructors", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [quotes (ppr tycon) <+> text "has no constructors", nest 2 $ text "(EmptyDataDecls permits this)"] -wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily :: TyCon -> TcRnMessage wrongKindOfFamily family - = text "Wrong category of family instance; declaration was for a" + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Wrong category of family instance; declaration was for a" <+> kindOfFamily where kindOfFamily | isTypeFamilyTyCon family = text "type family" @@ -5225,21 +5251,24 @@ wrongKindOfFamily family -- | Produce an error for oversaturated type family equations with too many -- required arguments. -- See Note [Oversaturated type family equations] in "GHC.Tc.Validity". -wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr :: Arity -> TcRnMessage wrongNumberOfParmsErr max_args - = text "Number of parameters must match family declaration; expected" + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Number of parameters must match family declaration; expected" <+> ppr max_args -badRoleAnnot :: Name -> Role -> Role -> SDoc +badRoleAnnot :: Name -> Role -> Role -> TcRnMessage badRoleAnnot var annot inferred - = hang (text "Role mismatch on variable" <+> ppr var <> colon) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Role mismatch on variable" <+> ppr var <> colon) 2 (sep [ text "Annotation says", ppr annot , text "but role", ppr inferred , text "is required" ]) -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc +wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = hang (text "Wrong number of roles listed in role annotation;" $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) @@ -5249,22 +5278,26 @@ illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpanA loc $ - addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") + addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") -needXRoleAnnotations :: TyCon -> SDoc +needXRoleAnnotations :: TyCon -> TcRnMessage needXRoleAnnotations tc - = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal role annotation for" <+> ppr tc <> char ';' $$ text "did you intend to use RoleAnnotations?" -incoherentRoles :: SDoc -incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") +incoherentRoles :: TcRnMessage +incoherentRoles = TcRnUnknownMessage $ mkPlainError noHints $ + (text "Roles other than" <+> quotes (text "nominal") <+> + text "for class parameters can lead to incoherence.") $$ + (text "Use IncoherentInstances to allow this; bad role found") -wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName :: Name -> Name -> TcRnMessage wrongTyFamName fam_tc_name eqn_tc_name - = hang (text "Mismatched type name in type family instance.") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Mismatched type name in type family instance.") 2 (vcat [ text "Expected:" <+> ppr fam_tc_name , text " Actual:" <+> ppr eqn_tc_name ]) diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index cd70be7c59..b4c1052385 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -30,6 +30,7 @@ where import GHC.Prelude import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Types.Evidence ( idHsWrapper ) import GHC.Tc.Gen.Bind @@ -50,6 +51,7 @@ import GHC.Core.Coercion ( pprCoAxiom ) import GHC.Driver.Session import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv +import GHC.Types.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env @@ -112,8 +114,8 @@ Death to "ExpandingDicts". ************************************************************************ -} -illegalHsigDefaultMethod :: Name -> SDoc -illegalHsigDefaultMethod n = +illegalHsigDefaultMethod :: Name -> TcRnMessage +illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" tcClassSigs :: Name -- Name of the class @@ -274,10 +276,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; spec_prags <- discardConstraints $ tcSpecPrags global_dm_id prags - ; diagnosticTc WarningWithoutFlag - (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) + ; let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints $ + (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name)) + ; diagnosticTc (not (null spec_prags)) dia ; let hs_ty = hs_sig_fn sel_name `orElse` pprPanic "tc_dm" (ppr sel_name) @@ -353,7 +355,7 @@ tcClassMinimalDef _clas sigs op_info -- since you can't write a default implementation. when (tcg_src tcg_env /= HsigFile) $ whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addDiagnosticTc WarningWithoutFlag (warningMinimalDefIncomplete bf)) + (\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf)) return mindef where -- By default require all methods without a default implementation @@ -454,14 +456,16 @@ This makes the error messages right. ************************************************************************ -} -badMethodErr :: Outputable a => a -> Name -> SDoc +badMethodErr :: Outputable a => a -> Name -> TcRnMessage badMethodErr clas op - = hsep [text "Class", quotes (ppr clas), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Class", quotes (ppr clas), text "does not have a method", quotes (ppr op)] -badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod :: Outputable a => a -> Name -> TcRnMessage badGenericMethod clas op - = hsep [text "Class", quotes (ppr clas), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Class", quotes (ppr clas), text "has a generic-default signature without a binding", quotes (ppr op)] {- @@ -485,13 +489,15 @@ dupGenericInsts tc_inst_infos -} badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag - = addErrTc (text "The" <+> hsSigDoc prag <+> text "for default method" + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + text "The" <+> hsSigDoc prag <+> text "for default method" <+> quotes (ppr sel_id) <+> text "lacks an accompanying binding") -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc +warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage warningMinimalDefIncomplete mindef - = vcat [ text "The MINIMAL pragma does not require:" + = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ + vcat [ text "The MINIMAL pragma does not require:" , nest 2 (pprBooleanFormulaNice mindef) , text "but there is no default implementation." ] @@ -572,7 +578,10 @@ warnMissingAT name -- hs-boot and signatures never need to provide complete "definitions" -- of any sort, as they aren't really defining anything, but just -- constraining items which are defined elsewhere. - ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile) - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name)) } + ; let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $ + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name)) + ; diagnosticTc (warn && hsc_src == HsSrcFile) dia + } diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index e0bff637a7..760c8c6438 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -22,6 +22,7 @@ where import GHC.Prelude import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Bind import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) @@ -60,6 +61,7 @@ import GHC.Core.Coercion.Axiom import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Class +import GHC.Types.Error import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -68,7 +70,6 @@ import GHC.Types.Basic import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Utils.Error import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id @@ -1995,9 +1996,10 @@ methSigCtxt sel_name sig_ty meth_ty env0 , text " Class sig:" <+> ppr meth_ty ]) ; return (env2, msg) } -misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc +misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage misplacedInstSig name hs_ty - = vcat [ hang (text "Illegal type signature in instance declaration:") + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Illegal type signature in instance declaration:") 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) , text "(Use InstanceSigs to allow this)" ] @@ -2123,7 +2125,9 @@ derivBindCtxt sel_id clas tys warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef = do { warn <- woptM Opt_WarnMissingMethods - ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) warn message + ; let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints message + ; diagnosticTc warn msg } where message = vcat [text "No explicit implementation for" @@ -2342,26 +2346,30 @@ inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = hang (text "In the instance declaration for") 2 (quotes doc) -badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr :: TcRnMessage badBootFamInstDeclErr - = text "Illegal family instance in hs-boot file" + = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file" -notFamily :: TyCon -> SDoc +notFamily :: TyCon -> TcRnMessage notFamily tycon - = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] -assocInClassErr :: TyCon -> SDoc +assocInClassErr :: TyCon -> TcRnMessage assocInClassErr name - = text "Associated type" <+> quotes (ppr name) <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Associated type" <+> quotes (ppr name) <+> text "must be inside a class instance" -badFamInstDecl :: TyCon -> SDoc +badFamInstDecl :: TyCon -> TcRnMessage badFamInstDecl tc_name - = vcat [ text "Illegal family instance for" <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal family instance for" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] -notOpenFamily :: TyCon -> SDoc +notOpenFamily :: TyCon -> TcRnMessage notOpenFamily tc - = text "Illegal instance for closed family" <+> quotes (ppr tc) + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 5f511d539c..c470258e43 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -25,12 +25,14 @@ import GHC.Tc.Gen.Pat import GHC.Core.Multiplicity import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk import GHC.Builtin.Types.Prim +import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc @@ -226,6 +228,7 @@ dependentArgErr :: (Id, DTyCoVarSet) -> TcM () -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos) = failWithTc $ -- fail here: otherwise we get downstream errors + TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" , hang (text "Pattern-bound variable") 2 (ppr arg <+> dcolon <+> ppr (idType arg)) @@ -370,7 +373,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- The existential 'x' should not appear in the result type -- Can't check this until we know P's arity (decl_arity above) ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs - ; checkTc (null bad_tvs) $ + ; checkTc (null bad_tvs) $ TcRnUnknownMessage $ mkPlainError noHints $ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma , text "namely" <+> quotes (ppr pat_ty) ]) 2 (text "mentions existential type variable" <> plural bad_tvs @@ -645,7 +648,7 @@ addPatSynCtxt (L loc name) thing_inside wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" <+> speakNOf decl_arity (text "argument")) 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") @@ -878,7 +881,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLocA lpat) $ failWithTc $ + = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" <+> quotes (ppr ps_name) <> colon) 2 why diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 9e13a632ae..dcc57592a5 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -29,6 +29,7 @@ module GHC.Tc.TyCl.Utils( import GHC.Prelude +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds ) @@ -64,6 +65,7 @@ import GHC.Data.FastString import GHC.Unit.Module import GHC.Types.Basic +import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -204,7 +206,7 @@ checkTyConIsAcyclic tc m = SynCycleM $ \s -> checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds = case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc err + Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Right _ -> return () where -- Try our best to print the LTyClDecl for locally defined things diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index a3b0068b3e..d433a46aed 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -47,6 +47,7 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Export import GHC.Tc.Solver import GHC.Tc.TyCl.Utils @@ -89,8 +90,9 @@ import Data.List (find) import {-# SOURCE #-} GHC.Tc.Module -fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc +fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage fixityMisMatch real_thing real_fixity sig_fixity = + TcRnUnknownMessage $ mkPlainError noHints $ vcat [ppr real_thing <+> text "has conflicting fixities in the module", text "and its hsig file", text "Main module:" <+> ppr_fix real_fixity, @@ -167,7 +169,7 @@ checkHsigIface tcg_env gr sig_iface -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr err + Failed err -> addErr (TcRnUnknownMessage $ mkPlainError noHints err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must @@ -711,7 +713,7 @@ mergeSignatures -- 3(d). Extend the name substitution (performing shaping) mb_r <- extend_ns nsubst as2 case mb_r of - Left err -> failWithTc err + Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) @@ -1021,7 +1023,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ + Failed err -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Could not find hi interface for signature" <+> quotes (ppr isig_mod) <> colon) 4 err @@ -1029,7 +1031,8 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do -- we need. (Notice we IGNORE the Modules in the AvailInfos.) forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ quotes (ppr occ) + [] -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr occ) <+> text "is exported by the hsig file, but not exported by the implementing module" <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) _ -> return () diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index cfcd53489b..f291c57ff9 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -85,6 +85,7 @@ import GHC.Hs import GHC.Iface.Env import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -128,6 +129,7 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Name.Reader import GHC.Types.TyThing +import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt import Data.IORef @@ -254,7 +256,7 @@ tcLookupGlobal name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc msg + Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. @@ -324,10 +326,12 @@ tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ text "Couldn't match instance:" <+> err + Left err -> + failWithTc $ TcRnUnknownMessage + $ mkPlainError noHints (text "Couldn't match instance:" <+> err) Right (inst, tys) | uniqueTyVars tys -> return inst - | otherwise -> failWithTc errNotExact + | otherwise -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact) } where errNotExact = text "Not an exact match (i.e., some variables get instantiated)" @@ -874,6 +878,7 @@ checkWellStaged pp_thing bind_lvl use_lvl | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) + TcRnUnknownMessage $ mkPlainError noHints $ text "Stage error:" <+> pp_thing <+> hsep [text "is bound at stage" <+> ppr bind_lvl, text "but used at stage" <+> ppr use_lvl] @@ -881,6 +886,7 @@ checkWellStaged pp_thing bind_lvl use_lvl stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing = failWithTc $ + TcRnUnknownMessage $ mkPlainError noHints $ sep [ text "GHC stage restriction:" , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," , text "and must be imported, not defined locally"])] @@ -1148,6 +1154,7 @@ notFound name -- don't report it again (#11941) | otherwise -> stageRestrictionError (quotes (ppr name)) _ -> failWithTc $ + TcRnUnknownMessage $ mkPlainError noHints $ vcat[text "GHC internal error:" <+> quotes (ppr name) <+> text "is not in scope during type checking, but it passed the renamer", text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] @@ -1163,8 +1170,10 @@ wrongThingErr :: String -> TcTyThing -> Name -> TcM a -- turn does not look at the details of the TcTyThing. -- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind wrongThingErr expected thing name - = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) + = let msg = TcRnUnknownMessage $ mkPlainError noHints $ + (pprTcTyThingCategory thing <+> quotes (ppr name) <+> + text "used as a" <+> text expected) + in failWithTc msg {- Note [Out of scope might be a staging error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index ded9d8eff5..42d2aafe30 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -70,9 +70,11 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Instance.FunDeps import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType +import GHC.Tc.Errors.Types import GHC.Types.Id.Make( mkDictFunId ) import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env @@ -822,14 +824,13 @@ newClsInst overlap_mode dfun_name tvs theta clas tys ; oflag <- getOverlapFlag overlap_mode ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; warnIfFlag Opt_WarnOrphans - (isOrphan (is_orphan inst)) - (instOrphWarn inst) + ; warnIf (isOrphan (is_orphan inst)) (instOrphWarn inst) ; return inst } -instOrphWarn :: ClsInst -> SDoc +instOrphWarn :: ClsInst -> TcRnMessage instOrphWarn inst - = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnOrphans) noHints $ + hang (text "Orphan instance:") 2 (pprInstanceHdr inst) $$ text "To avoid this" $$ nest 4 (vcat possibilities) where @@ -967,7 +968,8 @@ addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () addClsInstsErr herald ispecs = do unit_state <- hsc_units <$> getTopEnv setSrcSpan (getSrcSpan (head sorted)) $ - addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted)) + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted)) where sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs -- The sortBy just arranges that instances are displayed in order diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index a40dc2c81e..dea37f4919 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -76,7 +76,6 @@ module GHC.Tc.Utils.Monad( tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkTcRnMessage, addLongErrAt, reportDiagnostic, reportDiagnostics, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, askNoErrs, discardErrs, tryTcDiscardingErrs, @@ -87,15 +86,17 @@ module GHC.Tc.Utils.Monad( getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, - -- * Error message generation (type checker) + -- * Diagnostic message generation (type checker) addErrTc, addErrTcM, failWithTc, failWithTcM, checkTc, checkTcM, failIfTc, failIfTcM, - warnIfFlag, warnIf, diagnosticTc, diagnosticTcM, addDetailedDiagnostic, addTcRnDiagnostic, - addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, add_diagnostic, mkErrInfo, + addTcRnDiagnostic, addDetailedDiagnostic, + mkTcRnMessage, reportDiagnostic, reportDiagnostics, + warnIf, diagnosticTc, diagnosticTcM, + addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, -- * Type constraints newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, @@ -979,30 +980,30 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: SDoc -> TcRn () +addErr :: TcRnMessage -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: SDoc -> TcRn a +failWith :: TcRnMessage -> TcRn a failWith msg = addErr msg >> failM -failAt :: SrcSpan -> SDoc -> TcRn a +failAt :: SrcSpan -> TcRnMessage -> TcRn a failAt loc msg = addErrAt loc msg >> failM -addErrAt :: SrcSpan -> SDoc -> TcRn () +addErrAt :: SrcSpan -> TcRnMessage -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- tcInitTidyEnv ; err_info <- mkErrInfo tidy_env ctxt - ; addLongErrAt loc msg err_info } + ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } -addErrs :: [(SrcSpan,SDoc)] -> TcRn () +addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -checkErr :: Bool -> SDoc -> TcRn () +checkErr :: Bool -> TcRnMessage -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) @@ -1035,37 +1036,24 @@ discardWarnings thing_inside ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope TcRnMessage) -mkLongErrAt loc msg extra - = do { printer <- getPrintUnqualified ; - unit_state <- hsc_units <$> getTopEnv ; - let msg' = pprWithUnitState unit_state msg in - return $ mkErrorMsgEnvelope loc printer - $ TcRnUnknownMessage - $ mkDecoratedError noHints [msg', extra] } - -mkTcRnMessage :: DiagnosticReason - -> SrcSpan - -> SDoc - -- ^ The important part of the message - -> SDoc - -- ^ The context of the message - -> SDoc - -- ^ Any supplementary information. +add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn () +add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic + where + mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage) + mk_long_err_at loc msg + = do { printer <- getPrintUnqualified ; + unit_state <- hsc_units <$> getTopEnv ; + return $ mkErrorMsgEnvelope loc printer + $ TcRnMessageWithInfo unit_state msg + } + +mkTcRnMessage :: SrcSpan + -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage) -mkTcRnMessage reason loc important context extra +mkTcRnMessage loc msg = do { printer <- getPrintUnqualified ; - unit_state <- hsc_units <$> getTopEnv ; dflags <- getDynFlags ; - let errDocs = map (pprWithUnitState unit_state) - [important, context, extra] - in - return $ mkMsgEnvelope dflags loc printer - $ TcRnUnknownMessage - $ mkDecoratedDiagnostic reason noHints errDocs } - -addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () -addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic + return $ mkMsgEnvelope dflags loc printer msg } reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () reportDiagnostics = mapM_ reportDiagnostic @@ -1471,11 +1459,11 @@ tryTcDiscardingErrs recover thing_inside tidy up the message; we then use it to tidy the context messages -} -addErrTc :: SDoc -> TcM () +addErrTc :: TcRnMessage -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrTcM :: (TidyEnv, SDoc) -> TcM () +addErrTcM :: (TidyEnv, TcRnMessage) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; @@ -1483,27 +1471,27 @@ addErrTcM (tidy_env, err_msg) -- The failWith functions add an error message and cause failure -failWithTc :: SDoc -> TcM a -- Add an error message and fail +failWithTc :: TcRnMessage -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, SDoc) -> TcM a -- Add an error message and fail +failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a -- Add an error message and fail failWithTcM local_and_msg = addErrTcM local_and_msg >> failM -checkTc :: Bool -> SDoc -> TcM () -- Check that the boolean is true +checkTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err -checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM () +checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () checkTcM True _ = return () checkTcM False err = failWithTcM err -failIfTc :: Bool -> SDoc -> TcM () -- Check that the boolean is false +failIfTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is false failIfTc False _ = return () failIfTc True err = failWithTc err -failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM () +failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () -- Check that the boolean is false failIfTcM False _ = return () failIfTcM True err = failWithTcM err @@ -1511,46 +1499,39 @@ failIfTcM True err = failWithTcM err -- Warnings have no 'M' variant, nor failure --- | Display a warning if a condition is met, --- and the warning is enabled -warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () -warnIfFlag warn_flag is_bad msg - = do { -- No need to check the flag here, it will be done in 'diagReasonSeverity'. - ; when is_bad $ addDiagnostic (WarningWithFlag warn_flag) msg } - -- | Display a warning if a condition is met. -warnIf :: Bool -> SDoc -> TcRn () -warnIf is_bad msg - = when is_bad (addDiagnostic WarningWithoutFlag msg) +warnIf :: Bool -> TcRnMessage -> TcRn () +warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'. + = when is_bad (addDiagnostic msg) + +no_err_info :: ErrInfo +no_err_info = ErrInfo Outputable.empty Outputable.empty -- | Display a warning if a condition is met. -diagnosticTc :: DiagnosticReason -> Bool -> SDoc -> TcM () -diagnosticTc reason should_report warn_msg - | should_report = addDiagnosticTc reason warn_msg +diagnosticTc :: Bool -> TcRnMessage -> TcM () +diagnosticTc should_report warn_msg + | should_report = addDiagnosticTc warn_msg | otherwise = return () -- | Display a diagnostic if a condition is met. -diagnosticTcM :: DiagnosticReason -> Bool -> (TidyEnv, SDoc) -> TcM () -diagnosticTcM reason should_report warn_msg - | should_report = addDiagnosticTcM reason warn_msg +diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () +diagnosticTcM should_report warn_msg + | should_report = addDiagnosticTcM warn_msg | otherwise = return () -- | Display a diagnostic in the current context. -addDiagnosticTc :: DiagnosticReason -> SDoc -> TcM () -addDiagnosticTc reason msg +addDiagnosticTc :: TcRnMessage -> TcM () +addDiagnosticTc msg = do { env0 <- tcInitTidyEnv ; - addDiagnosticTcM reason (env0, msg) } + addDiagnosticTcM (env0, msg) } -- | Display a diagnostic in a given context. -addDiagnosticTcM :: DiagnosticReason -> (TidyEnv, SDoc) -> TcM () -addDiagnosticTcM reason (env0, msg) - = do { ctxt <- getErrCtxt ; - err_info <- mkErrInfo env0 ctxt ; - add_diagnostic reason msg err_info } - --- | Display a diagnostic for the current source location. -addDiagnostic :: DiagnosticReason -> SDoc -> TcRn () -addDiagnostic reason msg = add_diagnostic reason msg Outputable.empty +addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () +addDiagnosticTcM (env0, msg) + = do { ctxt <- getErrCtxt + ; extra <- mkErrInfo env0 ctxt + ; let err_info = ErrInfo extra Outputable.empty + ; add_diagnostic (TcRnMessageDetailed err_info msg) } -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' -- given some additional context about the diagnostic. @@ -1562,35 +1543,33 @@ addDetailedDiagnostic mkMsg = do env0 <- tcInitTidyEnv ctxt <- getErrCtxt err_info <- mkErrInfo env0 ctxt - reportDiagnostic (mkMsgEnvelope dflags loc printer (mkMsg (ErrInfo err_info))) + reportDiagnostic (mkMsgEnvelope dflags loc printer (mkMsg (ErrInfo err_info empty))) addTcRnDiagnostic :: TcRnMessage -> TcM () addTcRnDiagnostic msg = do loc <- getSrcSpanM - printer <- getPrintUnqualified - dflags <- getDynFlags - reportDiagnostic (mkMsgEnvelope dflags loc printer msg) + mkTcRnMessage loc msg >>= reportDiagnostic + +-- | Display a diagnostic for the current source location, taken from +-- the 'TcRn' monad. +addDiagnostic :: TcRnMessage -> TcRn () +addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg) -- | Display a diagnostic for a given source location. -addDiagnosticAt :: DiagnosticReason -> SrcSpan -> SDoc -> TcRn () -addDiagnosticAt reason loc msg = add_diagnostic_at reason loc msg Outputable.empty +addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () +addDiagnosticAt loc msg = do + unit_state <- hsc_units <$> getTopEnv + let dia = TcRnMessageDetailed no_err_info msg + mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic -- | Display a diagnostic, with an optional flag, for the current source -- location. -add_diagnostic :: DiagnosticReason -> SDoc -> SDoc -> TcRn () -add_diagnostic reason msg extra_info +add_diagnostic :: TcRnMessageDetailed -> TcRn () +add_diagnostic msg = do { loc <- getSrcSpanM - ; add_diagnostic_at reason loc msg extra_info } - --- | Display a diagnosticTc, with an optional flag, for a given location. -add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn () -add_diagnostic_at reason loc msg extra_info - = do { printer <- getPrintUnqualified ; - dflags <- getDynFlags ; - let { dia = mkMsgEnvelope dflags loc printer $ - TcRnUnknownMessage $ - mkDecoratedDiagnostic reason noHints [msg, extra_info] } ; - reportDiagnostic dia } + ; unit_state <- hsc_units <$> getTopEnv + ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic + } {- @@ -1598,12 +1577,12 @@ add_diagnostic_at reason loc msg extra_info Other helper functions -} -add_err_tcm :: TidyEnv -> SDoc -> SrcSpan +add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan -> [ErrCtxt] -> TcM () -add_err_tcm tidy_env err_msg loc ctxt +add_err_tcm tidy_env msg loc ctxt = do { err_info <- mkErrInfo tidy_env ctxt ; - addLongErrAt loc err_msg err_info } + add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 1a8be64e29..a4769bc759 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -121,13 +121,14 @@ import GHC.Types.Var import GHC.Types.Id as Id import GHC.Types.Name import GHC.Types.Var.Set + +import GHC.Builtin.Types +import GHC.Types.Error import GHC.Types.Var.Env import GHC.Types.Name.Env import GHC.Types.Unique.Set import GHC.Types.Basic ( TypeOrKind(..) ) -import GHC.Builtin.Types - import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair @@ -1830,9 +1831,10 @@ defaultTyVar default_kind tv ; writeMetaTyVar kv liftedTypeKind ; return True } | otherwise - = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) + = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') + , text "of kind:" <+> ppr (tyVarKind kv') + , text "Perhaps enable PolyKinds or add a kind signature" ]) -- We failed to default it, so return False to say so. -- Hence, it'll get skolemised. That might seem odd, but we must either -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType @@ -2020,12 +2022,13 @@ doNotQuantifyTyVars dvs where_found ; unless (null leftover_metas) $ do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas ; (tidy_env2, where_doc) <- where_found tidy_env1 - ; let doc = vcat [ text "Uninferrable type variable" - <> plural tidied_tvs - <+> pprWithCommas pprTyVar tidied_tvs - <+> text "in" - , where_doc ] - ; failWithTcM (tidy_env2, pprWithExplicitKindsWhen True doc) } + ; let msg = TcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen True $ + vcat [ text "Uninferrable type variable" + <> plural tidied_tvs + <+> pprWithCommas pprTyVar tidied_tvs + <+> text "in" + , where_doc ] + ; failWithTcM (tidy_env2, msg) } ; traceTc "doNotQuantifyTyVars success" empty } {- Note [Defaulting with -XNoPolyKinds] @@ -2678,7 +2681,8 @@ naughtyQuantification orig_ty tv escapees orig_ty' = tidyType env orig_ty1 ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - doc = pprWithExplicitKindsWhen True $ + msg = TcRnUnknownMessage $ mkPlainError noHints $ + pprWithExplicitKindsWhen True $ vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' , quotes $ ppr_tidied escapees' , text "would escape" <+> itsOrTheir escapees' <+> text "scope" @@ -2692,4 +2696,4 @@ naughtyQuantification orig_ty tv escapees , text " due to its ill-scoped nature.)" ] - ; failWithTcM (env, doc) } + ; failWithTcM (env, msg) } diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 3c664cb06e..3445270c9a 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -42,6 +42,7 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Predicate import GHC.Tc.Types.Origin +import GHC.Tc.Errors.Types -- others: import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) @@ -69,6 +70,7 @@ import GHC.Builtin.Uniques ( mkAlphaTyVarUnique ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad +import Data.Bifunctor import Data.Foldable import Data.Function import Data.List ( (\\), nub ) @@ -259,7 +261,10 @@ checkUserTypeError = check fail_with msg = do { env0 <- tcInitTidyEnv ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } + ; failWithTcM (env1 + , TcRnUnknownMessage $ + mkPlainError noHints (pprUserTypeErrorTy tidy_msg)) + } {- Note [When we don't check for ambiguity] @@ -915,10 +920,11 @@ check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } ---------------------------------------- -forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) +forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, TcRnMessage) forAllTyErr env rank ty = ( env - , vcat [ hang herald 2 (ppr_tidy env ty) + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang herald 2 (ppr_tidy env ty) , suggestion ] ) where (tvs, _rho) = tcSplitForAllTyVars ty @@ -946,10 +952,11 @@ checkEscapingKind env tvbs theta tau = -- If there are any constraints, the kind is *. (#11405) forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind - -> (TidyEnv, SDoc) + -> (TidyEnv, TcRnMessage) forAllEscapeErr env tvbs theta tau tau_kind = ( env - , vcat [ hang (text "Quantified type's kind mentions quantified type variable") + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Quantified type's kind mentions quantified type variable") 2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau))) -- NB: Don't tidy this type since the tvbs were already tidied -- previously, and re-tidying them will make the names of type @@ -976,11 +983,13 @@ its binding site! This is not desirable, so we establish a validity check kinds in this way. -} -ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) ubxArgTyErr env ty - = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:" - , ppr_tidy env ty ] - , text "Perhaps you intended to use UnboxedTuples" ] ) + = ( env + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ sep [ text "Illegal unboxed tuple type as function argument:" + , ppr_tidy env ty ] + , text "Perhaps you intended to use UnboxedTuples" ] ) checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () checkConstraintsOK ve theta ty @@ -992,23 +1001,25 @@ checkConstraintsOK ve theta ty checkTcM (all isEqPred theta) $ constraintTyErr (ve_tidy_env ve) ty -constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) constraintTyErr env ty - = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) + = (env + , TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal constraint in a kind:" <+> ppr_tidy env ty) -- | Reject a use of visible, dependent quantification in the type of a term. -illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) illegalVDQTyErr env ty = - (env, vcat + (env, TcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Illegal visible, dependent quantification" <+> text "in the type of a term:") 2 (ppr_tidy env ty) , text "(GHC does not yet support this)" ] ) -- | Reject uses of linear function arrows in kinds. -linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) linearFunKindErr env ty = - (env, text "Illegal linear function in a kind:" <+> ppr_tidy env ty) + (env, TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal linear function in a kind:" <+> ppr_tidy env ty) {- Note [Liberal type synonyms] @@ -1099,9 +1110,9 @@ check_valid_theta _ _ _ [] = return () check_valid_theta env ctxt expand theta = do { dflags <- getDynFlags - ; diagnosticTcM (WarningWithFlag Opt_WarnDuplicateConstraints) - (notNull dups) - (dupPredWarn env dups) + ; let dia m = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateConstraints) noHints m + ; diagnosticTcM (notNull dups) (second dia (dupPredWarn env dups)) ; traceTc "check_valid_theta" (ppr theta) ; mapM_ (check_pred_ty env dflags ctxt expand) theta } where @@ -1294,8 +1305,11 @@ checkSimplifiableClassConstraint env dflags ctxt cls tys = do { result <- matchGlobalInst dflags False cls tys ; case result of OneInst { cir_what = what } - -> addDiagnosticTc (WarningWithFlag Opt_WarnSimplifiableClassConstraints) - (simplifiable_constraint_warn what) + -> let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints) + noHints + (simplifiable_constraint_warn what) + in addDiagnosticTc dia _ -> return () } where pred = mkClassPred cls tys @@ -1402,40 +1416,47 @@ checkThetaCtxt ctxt theta env , text "While checking" <+> pprUserTypeCtxt ctxt ] ) eqPredTyErr, predTupleErr, predIrredErr, - badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) + badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage) badQuantHeadErr env pred = ( env - , hang (text "Quantified predicate must have a class or type variable head:") + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Quantified predicate must have a class or type variable head:") 2 (ppr_tidy env pred) ) eqPredTyErr env pred = ( env - , text "Illegal equational constraint" <+> ppr_tidy env pred $$ + , TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal equational constraint" <+> ppr_tidy env pred $$ parens (text "Use GADTs or TypeFamilies to permit this") ) predTupleErr env pred = ( env - , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) predIrredErr env pred = ( env - , hang (text "Illegal constraint:" <+> ppr_tidy env pred) + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) -predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) +predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage) predTyVarErr env pred = (env - , vcat [ hang (text "Non type-variable argument") + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Non type-variable argument") 2 (text "in the constraint:" <+> ppr_tidy env pred) , parens (text "Use FlexibleContexts to permit this") ]) -badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) +badIPPred :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage) badIPPred env pred = ( env - , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) + , TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) -constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintSynErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) constraintSynErr env kind = ( env - , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) 2 (parens constraintKindsMsg) ) dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) @@ -1446,7 +1467,7 @@ dupPredWarn env dups where primaryDups = map NE.head dups -tyConArityErr :: TyCon -> [TcType] -> SDoc +tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report -- the number of /visible/ arguments required and supplied, -- ignoring the /invisible/ arguments, which the user does not see. @@ -1462,9 +1483,10 @@ tyConArityErr tc tks tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) tc_type_args = length vis_tks -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc +arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage arityErr what name n m - = hsep [ text "The" <+> what, quotes (ppr name), text "should have", + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [ text "The" <+> what, quotes (ppr name), text "should have", n_arguments <> comma, text "but has been given", if m==0 then text "none" else int m] where @@ -1620,13 +1642,25 @@ check_special_inst_head dflags is_boot is_sig ctxt clas cls_args text "Only one type can be given in an instance head." $$ text "Use MultiParamTypeClasses if you want to allow more, or zero." - rejected_class_msg = text "Class" <+> quotes (ppr clas_nm) - <+> text "does not support user-specified instances" - tuple_class_msg = text "You can't specify an instance for a tuple constraint" + rejected_class_msg :: TcRnMessage + rejected_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ rejected_class_doc + + tuple_class_msg :: TcRnMessage + tuple_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ + text "You can't specify an instance for a tuple constraint" + + rejected_class_doc :: SDoc + rejected_class_doc = + text "Class" <+> quotes (ppr clas_nm) + <+> text "does not support user-specified instances" - gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)") + gen_inst_err :: TcRnMessage + gen_inst_err = TcRnUnknownMessage $ mkPlainError noHints $ + rejected_class_doc $$ nest 2 (text "(in Safe Haskell)") - abstract_class_msg = text "Cannot define instance for abstract class" + abstract_class_msg :: TcRnMessage + abstract_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm) mb_ty_args_msg @@ -1696,9 +1730,10 @@ dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy dropCastsB :: TyVarBinder -> TyVarBinder dropCastsB b = b -- Don't bother in the kind of a forall -instTypeErr :: Class -> [Type] -> SDoc -> SDoc +instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage instTypeErr cls tys msg - = hang (hang (text "Illegal instance declaration for") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (hang (text "Illegal instance declaration for") 2 (quotes (pprClassPred cls tys))) 2 msg @@ -1851,15 +1886,16 @@ synonyms, by matching on TyConApp directly. checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty | not is_tc_app - = failWithTc (hang (text "Instance head is not headed by a class:") - 2 ( ppr tau)) + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Instance head is not headed by a class:") 2 ( ppr tau)) | isNothing mb_cls - = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) , text "A class instance must be for a class" ]) | not arity_ok - = failWithTc (text "Arity mis-match in instance head") + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Arity mis-match in instance head") | otherwise = do { setSrcSpanA head_loc $ @@ -1961,9 +1997,12 @@ checkInstTermination theta head_pred -- when the predicates are individually checked for validity check2 foralld_tvs pred pred_size - | not (null bad_tvs) = failWithTc (noMoreMsg bad_tvs what (ppr head_pred)) - | not (isTyFamFree pred) = failWithTc (nestedMsg what) - | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred)) + | not (null bad_tvs) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (noMoreMsg bad_tvs what (ppr head_pred)) + | not (isTyFamFree pred) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (nestedMsg what) + | pred_size >= head_size = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (smallerMsg what (ppr head_pred)) | otherwise = return () -- isTyFamFree: see Note [Type families in instance contexts] where @@ -2046,8 +2085,9 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { addDiagnosticAt WarningWithoutFlag (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch fam_tc cur_branch + = do { let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch) + ; addDiagnosticAt (coAxBranchSpan cur_branch) dia ; return prev_branches } | otherwise = do { check_injectivity prev_branches cur_branch @@ -2116,7 +2156,8 @@ checkValidTyFamEqn fam_tc qvs typats rhs case drop (tyConArity fam_tc) typats of [] -> pure () spec_arg:_ -> - addErr $ text "Illegal oversaturated visible kind argument:" + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal oversaturated visible kind argument:" <+> quotes (char '@' <> pprParendType spec_arg) -- The argument patterns, and RHS, are all boxed tau types @@ -2163,7 +2204,7 @@ checkValidAssocTyFamDeflt fam_tc pats = extract_tv pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv - Nothing -> failWithTc $ + Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") 2 (vcat [ppr_eqn, suggestion]) @@ -2181,6 +2222,7 @@ checkValidAssocTyFamDeflt fam_tc pats = let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in traverse_ (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ + TcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") @@ -2203,9 +2245,9 @@ checkValidAssocTyFamDeflt fam_tc pats = -- checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS - -> [SDoc] + -> [TcRnMessage] checkFamInstRhs lhs_tc lhs_tys famInsts - = mapMaybe check famInsts + = map (TcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts where lhs_size = sizeTyConAppArgs lhs_tc lhs_tys inst_head = pprType (TyConApp lhs_tc lhs_tys) @@ -2276,7 +2318,7 @@ checkFamPatBinders fam_tc qtvs pats rhs dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ + = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs <+> isOrAre tvs <+> what <> comma) 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" @@ -2307,7 +2349,7 @@ checkValidTypePats tc pat_ty_args -- Ensure that no type family applications occur a type pattern ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of [] -> pure () - ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ + ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ ty_fam_inst_illegal_err tf_is_invis_arg (mkTyConApp tf_tc tf_args) } where @@ -2332,9 +2374,10 @@ nestedMsg what = sep [ text "Illegal nested" <+> what , parens undecidableMsg ] -badATErr :: Name -> Name -> SDoc +badATErr :: Name -> Name -> TcRnMessage badATErr clas op - = hsep [text "Class", quotes (ppr clas), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Class", quotes (ppr clas), text "does not have an associated type", quotes (ppr op)] @@ -2414,7 +2457,7 @@ checkConsistentFamInst (InClsInst { ai_class = clas , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 = go lr_subst1 rl_subst1 triples | otherwise - = addErrTc (pp_wrong_at_arg vis) + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) -- The /scoped/ type variables from the class-instance header -- should not be alpha-renamed. Inferred ones can be. @@ -2842,7 +2885,7 @@ checkTyConTelescope :: TyCon -> TcM () checkTyConTelescope tc | bad_scope = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") 2 pp_tc_kind , extra diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index a97c690260..bb27b568bb 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -40,6 +40,8 @@ module GHC.Types.Error , SDoc , DecoratedSDoc (unDecorated) , mkDecorated, mkSimpleDecorated + , unionDecoratedSDoc + , mapDecoratedSDoc , pprMessageBag , mkLocMessage @@ -162,6 +164,18 @@ mkDecorated = Decorated mkSimpleDecorated :: SDoc -> DecoratedSDoc mkSimpleDecorated doc = Decorated [doc] +-- | Joins two 'DecoratedSDoc' together. The resulting 'DecoratedSDoc' +-- will have a number of entries which is the sum of the lengths of +-- the input. +unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc +unionDecoratedSDoc (Decorated s1) (Decorated s2) = + Decorated (s1 `mappend` s2) + +-- | Apply a transformation function to all elements of a 'DecoratedSDoc'. +mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc +mapDecoratedSDoc f (Decorated s1) = + Decorated (map f s1) + {- Note [Rendering Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~ |