diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Driver/Flags.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 43 | ||||
-rw-r--r-- | compiler/GHC/Types/Error/Codes.hs | 1 |
6 files changed, 64 insertions, 4 deletions
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 2099d7c100..759c137eb5 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -636,6 +636,7 @@ data WarningFlag = | Opt_WarnTypeEqualityRequiresOperators -- Since 9.4 | Opt_WarnLoopySuperclassSolve -- Since 9.6 | Opt_WarnTermVariableCapture -- Since 9.8 + | Opt_WarnMissingRoleAnnotations -- Since 9.8 deriving (Eq, Ord, Show, Enum) -- | Return the names of a WarningFlag @@ -742,6 +743,7 @@ warnFlagNames wflag = case wflag of Opt_WarnTypeEqualityOutOfScope -> "type-equality-out-of-scope" :| [] Opt_WarnLoopySuperclassSolve -> "loopy-superclass-solve" :| [] Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] + Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| [] -- ----------------------------------------------------------------------------- -- Standard sets of warning options diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index d7fd2f3249..dd5bb6b7cb 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2249,7 +2249,8 @@ wWarningFlagsDeps = mconcat [ warnSpec Opt_WarnGADTMonoLocalBinds, warnSpec Opt_WarnTypeEqualityOutOfScope, warnSpec Opt_WarnTypeEqualityRequiresOperators, - warnSpec Opt_WarnTermVariableCapture + warnSpec Opt_WarnTermVariableCapture, + warnSpec Opt_WarnMissingRoleAnnotations ] warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index bf92125405..a9b1084914 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1338,6 +1338,9 @@ instance Diagnostic TcRnMessage where TcRnSectionWithoutParentheses expr -> mkSimpleDecorated $ hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) + TcRnMissingRoleAnnotation name roles -> mkSimpleDecorated $ + hang (text "Missing role annotation" <> colon) + 2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) TcRnCapturedTermName tv_name shadowed_term_names -> mkSimpleDecorated $ @@ -2547,6 +2550,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnGhciMonadLookupFail {} -> ErrorWithoutFlag + TcRnMissingRoleAnnotation{} + -> WarningWithFlag Opt_WarnMissingRoleAnnotations diagnosticHints = \case TcRnUnknownMessage m @@ -3226,6 +3231,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnGhciMonadLookupFail {} -> noHints + TcRnMissingRoleAnnotation{} + -> noHints diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode diagnosticCode = constructorCode diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 4f0d961a3d..41fa0515ee 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -4168,6 +4168,18 @@ data TcRnMessage where -> Maybe [GlobalRdrElt] -- ^ lookup result -> TcRnMessage + {- TcRnMissingRoleAnnotation is a warning that occurs when type declaration + doesn't have a role annotatiosn + + Controlled by flags: + - Wmissing-role-annotations + + Test cases: + T22702 + + -} + TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage + deriving Generic -- | Things forbidden in @type data@ declarations. diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index a2d507475a..6abbbfde26 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -4976,9 +4976,13 @@ checkValidRoleAnnots role_annots tc | isVisibleTyConBinder tvb = Just (role, binderVar tvb) | otherwise = Nothing - check_roles - = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> + check_roles = case role_annot_decl_maybe of + Nothing -> + setSrcSpan (getSrcSpan name) $ + -- See Note [Missing role annotations warning] + warnIf (not (isClassTyCon tc) && not (null vis_roles)) $ + TcRnMissingRoleAnnotation name vis_roles + Just (decl@(L loc (RoleAnnotDecl _ _ the_role_annots))) -> addRoleAnnotCtxt name $ setSrcSpanA loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations @@ -5001,6 +5005,39 @@ checkValidRoleAnnots role_annots tc check_no_roles = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl +-- Note [Missing role annotations warning] +-- +-- We warn about missing role annotations for tycons +-- 1. not type-classes: +-- type classes are nominal by default, which is most conservative +-- choice. E.g. we cannot have a type-class with an (accidentally) +-- phantom or representational type variable, as we can with +-- data types. +-- 2. with visible roles +-- +-- We don't make any exceptions for other data types. +-- In particular we explicitly warn about omitted (default and common) +-- representational roles. That is the point of the warning. +-- For example the default representational role for `Map`s key type parameter +-- would be wrong, and this warning is there to warn about it, +-- asking users to be explicit. +-- +-- If the default roles have been nominal, i.e. as conservative as possible, +-- the warning would still be valuable, as most types can be `representational` +-- (c.f. type-classes, which usually cannot). +-- +-- We don't warn about types with invisible roles only, because users cannot +-- specify them: +-- +-- type Foo :: forall {k}. Type +-- data Foo = Foo Int +-- type role Foo phantom +-- +-- is incorrect, GHC complains: +-- Wrong number of roles listed in role annotation; +-- Expected 0, got 1: +-- + checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () checkRoleAnnot _ (L _ Nothing) _ = return () checkRoleAnnot tv (L _ (Just r1)) r2 diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 7bcafbe32e..25f78f9fbd 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -439,6 +439,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnUnexpectedKindVar" = 12875 GhcDiagnosticCode "TcRnNegativeNumTypeLiteral" = 93632 GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar" = 54180 + GhcDiagnosticCode "TcRnMissingRoleAnnotation" = 65490 GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 |