diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Rename/Module.hs | 166 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 148 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 223 | ||||
| -rw-r--r-- | compiler/GHC/Types/Error/Codes.hs | 16 |
4 files changed, 414 insertions, 139 deletions
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 5441d0419a..516966044c 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -38,7 +38,6 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNames import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr (pprScopeError) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad @@ -56,7 +55,7 @@ import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Utils.Outputable import GHC.Data.Bag -import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) ) +import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session @@ -75,11 +74,9 @@ import Control.Monad import Control.Arrow ( first ) import Data.Foldable ( toList ) import Data.List ( mapAccumL ) -import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..), head ) import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) -import Data.Function ( on ) import GHC.Types.ConInfo (ConInfo, mkConInfo, conInfoFields) {- | @rnSourceDecl@ "renames" declarations. @@ -619,14 +616,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds Just (L _ cls) -> Right cls Nothing -> Left ( getLocA head_ty' - , mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal head of an instance declaration:" - <+> quotes (ppr head_ty')) - 2 (vcat [ text "Instance heads must be of the form" - , nest 2 $ text "C ty_1 ... ty_n" - , text "where" <+> quotes (char 'C') - <+> text "is a class" - ]) + , TcRnIllegalInstanceHeadDecl head_ty' ) -- ...finally, attempt to retrieve the class type constructor, failing -- with an error message if there isn't one. To avoid excessive @@ -798,7 +788,7 @@ rnFamEqn doc atfi extra_kvars && not (cls_tkv `elemNameSet` lhs_bound_vars) -- ...but not bound on the LHS. bad_tvs = filter improperly_scoped inst_head_tvs - ; unless (null bad_tvs) (badAssocRhs bad_tvs) + ; unless (null bad_tvs) (addErr (TcRnBadAssocRhs bad_tvs)) ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs -- See Note [Type family equations and occurrences] @@ -845,14 +835,6 @@ rnFamEqn doc atfi extra_kvars [loc] -> loc (loc:locs) -> loc `combineSrcSpans` last locs - badAssocRhs :: [Name] -> RnM () - badAssocRhs ns - = addErr $ mkTcRnUnknownMessage $ 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")) - rnTyFamInstDecl :: AssocTyFamInfo -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars) @@ -1190,7 +1172,7 @@ simplistic solution above, as it fixes the egregious bug in #18470. rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) rnSrcDerivDecl (DerivDecl _ ty mds overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving - ; unless standalone_deriv_ok (addErr standaloneDerivErr) + ; unless standalone_deriv_ok (addErr TcRnUnexpectedStandaloneDerivingDecl) ; checkInferredVars ctxt inf_err nowc_ty ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty -- Check if there are any nested `forall`s or contexts, which are @@ -1208,12 +1190,6 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap) loc = getLocA nowc_ty nowc_ty = dropWildCards ty -standaloneDerivErr :: TcRnMessage -standaloneDerivErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal standalone deriving declaration") - 2 (text "Use StandaloneDeriving to enable this extension") - {- ********************************************************* * * @@ -1316,7 +1292,7 @@ checkValidRule rule_name ids lhs' fv_lhs' -- Check that LHS vars are all bound ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mapM_ (addErr . badRuleVar rule_name) bad_vars } + ; mapM_ (addErr . TcRnUnusedVariableInRuleDecl rule_name) bad_vars } validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) -- Nothing => OK @@ -1353,27 +1329,15 @@ validRuleLhs foralls lhs checkl_es es = foldr (mplus . checkl_e) Nothing es -} -badRuleVar :: FastString -> Name -> TcRnMessage -badRuleVar name var - = mkTcRnUnknownMessage $ 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 -> TcRnMessage badRuleLhsErr name lhs bad_e - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Rule" <+> pprRuleName name <> colon, - nest 2 (vcat [err, - text "in left-hand side:" <+> ppr lhs])] - $$ - text "LHS must be of form (f e1 .. en) where f is not forall'd" + = TcRnIllegalRuleLhs errReason name lhs bad_e where - err = - case bad_e of - HsUnboundVar _ uv -> - pprScopeError uv $ notInScopeErr WL_Global uv - _ -> text "Illegal expression:" <+> ppr bad_e + errReason = case bad_e of + HsUnboundVar _ uv -> + UnboundVariable uv $ notInScopeErr WL_Global uv + _ -> IllegalExpression {- ************************************************************** * * @@ -1618,17 +1582,12 @@ rnStandaloneKindSignature -> RnM (StandaloneKindSig GhcRn, FreeVars) rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures - ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr + ; unless standalone_ki_sig_ok $ addErr TcRnUnexpectedStandaloneKindSig ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v ; let doc = StandaloneKindSigCtx (ppr v) ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) } - where - standaloneKiSigErr :: TcRnMessage - standaloneKiSigErr = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal standalone kind signature") - 2 (text "Did you mean to enable StandaloneKindSignatures?") depAnalTyClDecls :: GlobalRdrEnv -> KindSig_FV_Env @@ -1698,34 +1657,12 @@ rnRoleAnnots tc_names role_annots ; return $ RoleAnnotDecl noExtField tycon' roles } dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () -dupRoleAnnotErr list - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Duplicate role annotations for" <+> - quotes (ppr $ roleAnnotDeclName first_decl) <> colon) - 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_loc list - ((L loc first_decl) :| _) = sorted_list - - pp_role_annot (L loc decl) = hang (ppr decl) - 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLocA +dupRoleAnnotErr list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateRoleAnnot list) dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () -dupKindSig_Err list - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Duplicate standalone kind signatures for" <+> - quotes (ppr $ standaloneKindSigName first_decl) <> colon) - 2 (vcat $ map pp_kisig $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_loc list - ((L loc first_decl) :| _) = sorted_list - - pp_kisig (L loc decl) = - hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLocA +dupKindSig_Err list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateKindSig list) {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1955,7 +1892,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond = do { -- DatatypeContexts (i.e., stupid contexts) can't be combined with -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon. checkTc (h98_style || null (fromMaybeContext context)) - (badGadtStupidTheta doc) + (TcRnStupidThetaInGadt doc) -- Check restrictions on "type data" declarations. -- See Note [Type data declarations]. @@ -1991,7 +1928,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond rn_derivs ds = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) - multipleDerivClausesErr + TcRnIllegalMultipleDerivClauses ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds ; return (ds', fvs) } @@ -2213,21 +2150,10 @@ warnNoDerivStrat mds loc = do { dyn_flags <- getDynFlags ; case mds of Nothing -> - let dia = mkTcRnUnknownMessage $ - 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 + addDiagnosticAt loc $ TcRnNoDerivStratSpecified + (xopt LangExt.DerivingStrategies dyn_flags) _ -> pure () } - where - no_strat_warning :: SDoc - no_strat_warning = text "No deriving strategy specified. Did you want stock" - <> text ", newtype, or anyclass?" - deriv_strat_nenabled :: SDoc - deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy." rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) @@ -2291,7 +2217,7 @@ rnLDerivStrategy doc mds thing_inside = LangExt.DerivingStrategies unlessXOptM extNeeded $ - failWith $ illegalDerivStrategyErr ds + failWith $ TcRnIllegalDerivStrategy ds case ds of StockStrategy _ -> boring_case (StockStrategy noExtField) @@ -2319,32 +2245,6 @@ rnLDerivStrategy doc mds thing_inside (thing, fvs) <- thing_inside pure (ds, thing, fvs) -badGadtStupidTheta :: HsDocContext -> TcRnMessage -badGadtStupidTheta _ - = mkTcRnUnknownMessage $ 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 -> TcRnMessage -illegalDerivStrategyErr ds - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds - , text enableStrategy ] - - where - enableStrategy :: String - enableStrategy - | ViaStrategy{} <- ds - = "Use DerivingVia to enable this extension" - | otherwise - = "Use DerivingStrategies to enable this extension" - -multipleDerivClausesErr :: TcRnMessage -multipleDerivClausesErr - = mkTcRnUnknownMessage $ 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 -- inside an *class decl* for cls -- used for associated types @@ -2407,11 +2307,8 @@ rnFamResultSig doc (TyVarSig _ tvbndr) rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLocA tvbndr) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hsep [ text "Type variable", quotes (ppr resName) <> comma - , text "naming a type family result," - ] $$ - text "shadows an already bound type variable") + addErrAt (getLocA tvbndr) $ + TcRnShadowedTyVarNameInFamResult resName ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for -- scoping checks that are irrelevant here @@ -2481,20 +2378,13 @@ 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) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ( vcat [ text $ "Incorrect type variable on the LHS of " - ++ "injectivity condition" - , nest 5 - ( vcat [ text "Expected :" <+> ppr resName - , text "Actual :" <+> ppr injFrom ])]) + addErrAt (getLocA injFrom) $ + TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid - ; addErrAt (locA srcSpan) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ( hsep - [ text "Unknown type variable" <> plural errorVars - , text "on the RHS of injectivity condition:" - , interpp'SP errorVars ] ) } + ; addErrAt (locA srcSpan) $ + TcRnUnknownTyVarsOnRhsOfInjCond errorVars } ; return injDecl' } @@ -2783,9 +2673,7 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds ; return (gp, Just (splice, ds)) } where badImplicitSplice :: TcRnMessage - badImplicitSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Parse error: module header, import declaration" - $$ text "or top-level declaration expected." + badImplicitSplice = TcRnBadImplicitSplice -- The compiler should suggest the above, and not using -- TemplateHaskell since the former suggestion is more -- relevant to the larger base of users. diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index a9b9718433..a800b451c9 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1324,6 +1324,88 @@ instance Diagnostic TcRnMessage where = vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ] user_manual = vcat [ text "See the user manual, ยง Undecidable instances and loopy superclasses." ] + TcRnIllegalInstanceHeadDecl head_ty -> mkSimpleDecorated $ + hang (text "Illegal head of an instance declaration:" + <+> quotes (ppr head_ty)) + 2 (vcat [ text "Instance heads must be of the form" + , nest 2 $ text "C ty_1 ... ty_n" + , text "where" <+> quotes (char 'C') + <+> text "is a class" + ]) + TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $ + text "Illegal standalone deriving declaration" + TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $ + sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, + text "Forall'd variable" <+> quotes (ppr var) <+> + text "does not appear on left hand side"] + TcRnUnexpectedStandaloneKindSig -> mkSimpleDecorated $ + text "Illegal standalone kind signature" + TcRnIllegalRuleLhs errReason name lhs bad_e -> mkSimpleDecorated $ + sep [text "Rule" <+> pprRuleName name <> colon, + nest 2 (vcat [err, + text "in left-hand side:" <+> ppr lhs])] + $$ + text "LHS must be of form (f e1 .. en) where f is not forall'd" + where + err = case errReason of + UnboundVariable uv nis -> pprScopeError uv nis + IllegalExpression -> text "Illegal expression:" <+> ppr bad_e + TcRnBadAssocRhs ns -> mkSimpleDecorated $ + 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") + TcRnDuplicateRoleAnnot list -> mkSimpleDecorated $ + hang (text "Duplicate role annotations for" <+> + quotes (ppr $ roleAnnotDeclName first_decl) <> colon) + 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L _ first_decl) :| _) = sorted_list + + pp_role_annot (L loc decl) = hang (ppr decl) + 4 (text "-- written at" <+> ppr (locA loc)) + + cmp_loc = leftmost_smallest `on` getLocA + TcRnDuplicateKindSig list -> mkSimpleDecorated $ + hang (text "Duplicate standalone kind signatures for" <+> + quotes (ppr $ standaloneKindSigName first_decl) <> colon) + 2 (vcat $ map pp_kisig $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L _ first_decl) :| _) = sorted_list + + pp_kisig (L loc decl) = + hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) + + cmp_loc = leftmost_smallest `on` getLocA + TcRnIllegalDerivStrategy ds -> mkSimpleDecorated $ + text "Illegal deriving strategy" <> colon <+> derivStrategyName ds + TcRnIllegalMultipleDerivClauses -> mkSimpleDecorated $ + text "Illegal use of multiple, consecutive deriving clauses" + TcRnNoDerivStratSpecified{} -> mkSimpleDecorated $ text + "No deriving strategy specified. Did you want stock, newtype, or anyclass?" + TcRnStupidThetaInGadt{} -> mkSimpleDecorated $ + vcat [text "No context is allowed on a GADT-style data declaration", + text "(You can put a context on each constructor, though.)"] + TcRnBadImplicitSplice -> mkSimpleDecorated $ + text "Parse error: module header, import declaration" + $$ text "or top-level declaration expected." + TcRnShadowedTyVarNameInFamResult resName -> mkSimpleDecorated $ + hsep [ text "Type variable", quotes (ppr resName) <> comma + , text "naming a type family result," + ] $$ + text "shadows an already bound type variable" + TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom -> mkSimpleDecorated $ + vcat [ text $ "Incorrect type variable on the LHS of " + ++ "injectivity condition" + , nest 5 + ( vcat [ text "Expected :" <+> ppr resName + , text "Actual :" <+> ppr injFrom ])] + TcRnUnknownTyVarsOnRhsOfInjCond errorVars -> mkSimpleDecorated $ + hsep [ text "Unknown type variable" <> plural errorVars + , text "on the RHS of injectivity condition:" + , interpp'SP errorVars ] diagnosticReason = \case TcRnUnknownMessage m @@ -1756,6 +1838,38 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnLoopySuperclassSolve{} -> WarningWithFlag Opt_WarnLoopySuperclassSolve + TcRnIllegalInstanceHeadDecl{} + -> ErrorWithoutFlag + TcRnUnexpectedStandaloneDerivingDecl{} + -> ErrorWithoutFlag + TcRnUnusedVariableInRuleDecl{} + -> ErrorWithoutFlag + TcRnUnexpectedStandaloneKindSig{} + -> ErrorWithoutFlag + TcRnIllegalRuleLhs{} + -> ErrorWithoutFlag + TcRnBadAssocRhs{} + -> ErrorWithoutFlag + TcRnDuplicateRoleAnnot{} + -> ErrorWithoutFlag + TcRnDuplicateKindSig{} + -> ErrorWithoutFlag + TcRnIllegalDerivStrategy{} + -> ErrorWithoutFlag + TcRnIllegalMultipleDerivClauses{} + -> ErrorWithoutFlag + TcRnNoDerivStratSpecified{} + -> WarningWithFlag Opt_WarnMissingDerivingStrategies + TcRnStupidThetaInGadt{} + -> ErrorWithoutFlag + TcRnBadImplicitSplice{} + -> ErrorWithoutFlag + TcRnShadowedTyVarNameInFamResult{} + -> ErrorWithoutFlag + TcRnIncorrectTyVarOnLhsOfInjCond{} + -> ErrorWithoutFlag + TcRnUnknownTyVarsOnRhsOfInjCond{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -2204,6 +2318,40 @@ instance Diagnostic TcRnMessage where cls_or_qc = case ctLocOrigin wtd_loc of ScOrigin c_or_q _ -> c_or_q _ -> IsClsInst -- shouldn't happen + TcRnIllegalInstanceHeadDecl{} + -> noHints + TcRnUnexpectedStandaloneDerivingDecl{} + -> [suggestExtension LangExt.StandaloneDeriving] + TcRnUnusedVariableInRuleDecl{} + -> noHints + TcRnUnexpectedStandaloneKindSig{} + -> [suggestExtension LangExt.StandaloneKindSignatures] + TcRnIllegalRuleLhs{} + -> noHints + TcRnBadAssocRhs{} + -> noHints + TcRnDuplicateRoleAnnot{} + -> noHints + TcRnDuplicateKindSig{} + -> noHints + TcRnIllegalDerivStrategy ds -> case ds of + ViaStrategy{} -> [suggestExtension LangExt.DerivingVia] + _ -> [suggestExtension LangExt.DerivingStrategies] + TcRnIllegalMultipleDerivClauses{} + -> [suggestExtension LangExt.DerivingStrategies] + TcRnNoDerivStratSpecified isDSEnabled -> if isDSEnabled + then noHints + else [suggestExtension LangExt.DerivingStrategies] + TcRnStupidThetaInGadt{} + -> noHints + TcRnBadImplicitSplice{} + -> noHints + TcRnShadowedTyVarNameInFamResult{} + -> noHints + TcRnIncorrectTyVarOnLhsOfInjCond{} + -> noHints + TcRnUnknownTyVarsOnRhsOfInjCond{} + -> noHints diagnosticCode = constructorCode diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 108eba5ab0..82d749e4ea 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -90,6 +90,7 @@ module GHC.Tc.Errors.Types ( , UnexpectedStatement(..) , DeclSort(..) , NonStandardGuards(..) + , RuleLhsErrReason(..) ) where import GHC.Prelude @@ -2959,6 +2960,224 @@ data TcRnMessage where -> PredType -- ^ Wanted 'PredType' -> TcRnMessage + {-| TcRnIllegalInstanceHeadDecl is an error triggered by malformed head of + type class instance + + Examples: + + instance 42 + + instance !Show D + + Test cases: parser/should_fail/T3811c + rename/should_fail/T18240a + -} + TcRnIllegalInstanceHeadDecl :: LHsType GhcRn -> TcRnMessage + + {-| TcRnUnexpectedStandaloneDerivingDecl is an error thrown when a user uses + standalone deriving without enabling the StandaloneDeriving extension. + + Example: + + deriving instance Eq Foo + + Test cases: rename/should_fail/RnUnexpectedStandaloneDeriving + -} + TcRnUnexpectedStandaloneDerivingDecl :: TcRnMessage + + {-| TcRnUnusedVariableInRuleDecl is an error triggered by forall'd variable in + rewrite rule that does not appear on left-hand side + + Example: + + {-# RULES "rule" forall a. id = id #-} + + Test cases: rename/should_fail/ExplicitForAllRules2 + -} + TcRnUnusedVariableInRuleDecl :: FastString -> Name -> TcRnMessage + + {-| TcRnUnexpectedStandaloneKindSig is an error thrown when a user uses standalone + kind signature without enabling the StandaloneKindSignatures extension. + + Example: + + type D :: Type + data D = D + + Test cases: saks/should_fail/saks_fail001 + -} + TcRnUnexpectedStandaloneKindSig :: TcRnMessage + + {-| TcRnIllegalRuleLhs is an error triggered by malformed left-hand side + of rewrite rule + + Examples: + + {-# RULES "test" forall x. f x = x #-} + + {-# RULES "test" forall x. case x of = x #-} + + Test cases: rename/should_fail/T15659 + -} + TcRnIllegalRuleLhs + :: RuleLhsErrReason + -> FastString -- Rule name + -> LHsExpr GhcRn -- Full expression + -> HsExpr GhcRn -- Bad expression + -> TcRnMessage + + {-| TcRnBadAssocRhs is an error triggered by out-of-scope type variables + occurred in right-hand side of an associated type declaration + + Example: + + instance forall a. C Int where + data instance D Int = MkD1 a + + cases: indexed-types/should_fail/T5515 + polykinds/T9574 + rename/should_fail/T18021 + -} + TcRnBadAssocRhs :: [Name] -> TcRnMessage + + {-| TcRnDuplicateRoleAnnot is an error triggered by two or more role + annotations for one type + + Example: + + data D a + type role D phantom + type role D phantom + + Test cases: roles/should_fail/Roles8 + -} + TcRnDuplicateRoleAnnot :: NE.NonEmpty (LRoleAnnotDecl GhcPs) -> TcRnMessage + + {-| TcRnDuplicateKindSig is an error triggered by two or more standalone + kind signatures for one type + + Example: + + type D :: Type + type D :: Type + data D + + Test cases: saks/should_fail/saks_fail002 + -} + TcRnDuplicateKindSig :: NE.NonEmpty (LStandaloneKindSig GhcPs) -> TcRnMessage + + {-| TcRnIllegalDerivStrategy is an error thrown when a user uses deriving + strategy without enabling the DerivingStrategies extension or uses deriving + via without enabling the DerivingVia extension. + + Examples: + + data T = T deriving stock Eq + + data T = T deriving via Eq T + + Test cases: deriving/should_fail/deriving-via-fail3 + deriving/should_fail/T10598_fail4 + -} + TcRnIllegalDerivStrategy :: DerivStrategy GhcPs -> TcRnMessage + + {-| TcRnIllegalMultipleDerivClauses is an error thrown when a user uses two or more + deriving clauses without enabling the DerivingStrategies extension. + + Example: + + data T = T + deriving Eq + deriving Ord + + Test cases: deriving/should_fail/T10598_fail5 + -} + TcRnIllegalMultipleDerivClauses :: TcRnMessage + + {-| TcRnNoDerivStratSpecified is a warning implied by -Wmissing-deriving-strategies + and triggered by deriving clause without specified deriving strategy. + + Example: + + data T = T + deriving Eq + + Test cases: rename/should_compile/T15798a + rename/should_compile/T15798b + rename/should_compile/T15798c + -} + TcRnNoDerivStratSpecified + :: Bool -- True if DerivingStrategies is enabled + -> TcRnMessage + + {-| TcRnStupidThetaInGadt is an error triggered by data contexts in GADT-style + data declaration + + Example: + + data (Eq a) => D a where + MkD :: D Int + + Test cases: rename/should_fail/RnStupidThetaInGadt + -} + TcRnStupidThetaInGadt :: HsDocContext -> TcRnMessage + + {-| TcRnBadImplicitSplice is an error thrown when a user uses top-level implicit + TH-splice without enabling the TemplateHaskell extension. + + Example: + + pure [] -- on top-level + + Test cases: ghci/prog019/prog019 + ghci/scripts/T1914 + ghci/scripts/T6106 + rename/should_fail/T4042 + rename/should_fail/T12146 + -} + TcRnBadImplicitSplice :: TcRnMessage + + {-| TcRnShadowedTyVarNameInFamResult is an error triggered by type variable in + type family result that shadows type variable from left hand side + + Example: + + type family F a b c = b + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnShadowedTyVarNameInFamResult :: IdP GhcPs -> TcRnMessage + + {-| TcRnIncorrectTyVarOnRhsOfInjCond is an error caused by a situation where the + left-hand side of an injectivity condition of a type family is not a variable + referring to the type family result. + See Note [Renaming injectivity annotation] for more details. + + Example: + + type family F a = r | a -> a + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnIncorrectTyVarOnLhsOfInjCond + :: IdP GhcRn -- Expected + -> LIdP GhcPs -- Actual + -> TcRnMessage + + {-| TcRnUnknownTyVarsOnRhsOfInjCond is an error triggered by out-of-scope type + variables on the right-hand side of a of an injectivity condition of a type family + + Example: + + type family F a = res | res -> b + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage + deriving Generic -- | Things forbidden in @type data@ declarations. @@ -4196,3 +4415,7 @@ data NonStandardGuards where Anno (Stmt GhcRn body) ~ SrcSpanAnnA) => [LStmtLR GhcRn GhcRn body] -> NonStandardGuards + +data RuleLhsErrReason + = UnboundVariable RdrName NotInScopeError + | IllegalExpression diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 9d3fe30084..dca0923ce7 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -514,6 +514,22 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnBindInBootFile" = 11247 GhcDiagnosticCode "TcRnDuplicateMinimalSig" = 85346 GhcDiagnosticCode "TcRnLoopySuperclassSolve" = 36038 + GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = 12222 + GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl" = 95159 + GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl" = 65669 + GhcDiagnosticCode "TcRnUnexpectedStandaloneKindSig" = 45906 + GhcDiagnosticCode "TcRnIllegalRuleLhs" = 63294 + GhcDiagnosticCode "TcRnBadAssocRhs" = 53634 + GhcDiagnosticCode "TcRnDuplicateRoleAnnot" = 97170 + GhcDiagnosticCode "TcRnDuplicateKindSig" = 43371 + GhcDiagnosticCode "TcRnIllegalDerivStrategy" = 87139 + GhcDiagnosticCode "TcRnIllegalMultipleDerivClauses" = 30281 + GhcDiagnosticCode "TcRnNoDerivStratSpecified" = 55631 + GhcDiagnosticCode "TcRnStupidThetaInGadt" = 18403 + GhcDiagnosticCode "TcRnBadImplicitSplice" = 25277 + GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult" = 99412 + GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333 + GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254 -- IllegalNewtypeReason GhcDiagnosticCode "DoesNotHaveSingleField" = 23517 |