diff options
Diffstat (limited to 'compiler/GHC/Rename/Bind.hs')
| -rw-r--r-- | compiler/GHC/Rename/Bind.hs | 52 |
1 files changed, 30 insertions, 22 deletions
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 609ab180f9..79b0a5661a 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -49,6 +49,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module +import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env @@ -453,9 +454,10 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) ; name <- applyNameMaker name_maker rdrname ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } where - localPatternSynonymErr :: SDoc + localPatternSynonymErr :: TcRnMessage localPatternSynonymErr - = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) 2 (text "Pattern synonym declarations are only valid at top level") rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) @@ -663,9 +665,10 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls ; return env} } -dupFixityDecl :: SrcSpan -> RdrName -> SDoc +dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage dupFixityDecl loc rdr_name - = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), text "also at " <+> ppr loc] @@ -753,9 +756,10 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name -- See Note [Renaming pattern synonym variables] lookupPatSynBndr = wrapLocMA lookupLocalOccRn - patternSynonymErr :: SDoc + patternSynonymErr :: TcRnMessage patternSynonymErr - = hang (text "Illegal pattern synonym declaration") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal pattern synonym declaration") 2 (text "Use -XPatternSynonyms to enable this extension") {- @@ -910,7 +914,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt (locA loc) $ + = do { addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ what <+> text "not allowed in" <+> decl_sort , nest 2 (ppr bind) ] ; return rest } @@ -1056,8 +1060,8 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs) where - orphanError :: SDoc - orphanError = + orphanError :: TcRnMessage + orphanError = TcRnUnknownMessage $ mkPlainError noHints $ text "Orphan COMPLETE pragmas not supported" $$ text "A COMPLETE pragma must mention at least one data constructor" $$ text "or pattern synonym defined in the same module." @@ -1217,9 +1221,10 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats' , m_grhss = grhss'}, grhss_fvs ) } -emptyCaseErr :: HsMatchContext GhcRn -> SDoc -emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) - 2 (text "Use EmptyCase to allow this") +emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage +emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Empty list of alternatives in" <+> pp_ctxt) + 2 (text "Use EmptyCase to allow this") where pp_ctxt = case ctxt of CaseAlt -> text "case expression" @@ -1260,8 +1265,10 @@ rnGRHS' ctxt rnBody (GRHS _ guards rhs) ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ -> rnBody rhs - ; unless (pattern_guards_allowed || is_standard_guard guards') - (addDiagnostic WarningWithoutFlag (nonStdGuardErr guards')) + ; unless (pattern_guards_allowed || is_standard_guard guards') $ + let diag = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards') + in addDiagnostic diag ; return (GRHS noAnn guards' rhs', fvs) } where @@ -1314,7 +1321,7 @@ rnSrcFixityDecl sig_ctxt = rn_decl dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Duplicate" <+> what_it_is <> text "s for" <+> quotes (ppr name) , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest @@ -1326,17 +1333,18 @@ dupSigDeclErr pairs@((L loc name, sig) :| _) misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] -defaultSigErr :: Sig GhcPs -> SDoc -defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") - 2 (ppr sig) - , text "Use DefaultSignatures to enable default signatures" ] +defaultSigErr :: Sig GhcPs -> TcRnMessage +defaultSigErr sig = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Unexpected default signature:") + 2 (ppr sig) + , text "Use DefaultSignatures to enable default signatures" ] bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM () bindInHsBootFileErr (L loc _) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Bindings in hs-boot files are not allowed" ] nonStdGuardErr :: (Outputable body, @@ -1348,7 +1356,7 @@ nonStdGuardErr guards dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Multiple minimal complete definitions" , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs) , text "Combine alternative minimal complete definitions with `|'" ] |