Add -Wmissing-role-annotations

Implements #22702

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