diff options
| author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-06-02 10:14:55 +0200 |
|---|---|---|
| committer | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-06-28 07:50:59 +0200 |
| commit | e4af16f1a96efdf21490f5558260aa3d3d78e9f8 (patch) | |
| tree | bf46c464dabf131a20d658abd59db24b4e7c2c82 | |
| parent | 469126b3cef2936d9831283a77d54330d0ff1ba8 (diff) | |
| download | haskell-wip/adinapoli-issue-19930.tar.gz | |
Try to simplify zoo of functions in `Tc.Utils.Monad`wip/adinapoli-issue-19930
This commit tries to untangle the zoo of diagnostic-related functions
in `Tc.Utils.Monad` so that we can have the interfaces mentions only
`TcRnMessage`s while we push the creation of these messages upstream.
It also ports TcRnMessage diagnostics to use the new API, in particular
this commit switch to use TcRnMessage in the external interfaces
of the diagnostic functions, and port the old SDoc to be wrapped
into TcRnUnknownMessage.
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] ~~~~~~~~~~~~~~~~~~~~~~~~~ |