Implement -Wforall-identifier (#20609)

In accordance with GHC Proposal #281 "Visible forall in types of terms":

	For three releases before this change takes place, include a new
	warning -Wforall-identifier in -Wdefault. This warning will be triggered
	at definition sites (but not use sites) of forall as an identifier.

Updates the haddock submodule.

5 files changed, 26 insertions, 8 deletions

diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index b85cee2a51..08e8672d00 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -43,7 +43,9 @@ import GHC.Rename.Names
 import GHC.Rename.Env
 import GHC.Rename.Fixity
 import GHC.Rename.Utils ( HsDocContext(..), mapFvRn
-                        , checkDupRdrNames, checkDupRdrNamesN, warnUnusedLocalBinds
+                        , checkDupRdrNames, checkDupRdrNamesN
+                        , warnUnusedLocalBinds
+                        , warnForallIdentifier
                         , checkUnusedRecordWildcard
                         , checkDupAndShadowedNames, bindLocalNamesFV
                         , addNoNestedForallsContextsErr, checkInferredVars )
@@ -981,6 +983,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures
         ; when (is_deflt && not defaultSigs_on) $
           addErr (defaultSigErr sig)
+        ; mapM_ warnForallIdentifier vs
         ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs
         ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
         ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 1340993084..6740e02430 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -51,7 +51,8 @@ import GHC.Rename.Env
 import GHC.Rename.Utils  ( HsDocContext(..), inHsDocContext, withHsDocContext
                          , mapFvRn, pprHsDocContext, bindLocalNamesFV
                          , typeAppErr, newLocalBndrRn, checkDupRdrNamesN
-                         , checkShadowedRdrNames )
+                         , checkShadowedRdrNames
+                         , warnForallIdentifier )
 import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
                          , lookupTyFixityRn )
 import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
@@ -1281,7 +1282,8 @@ rnConDeclFields ctxt fls fields
 rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
         -> RnM (LConDeclField GhcRn, FreeVars)
 rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
-  = do { let new_names = map (fmap (lookupField fl_env)) names
+  = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names
+       ; let new_names = map (fmap (lookupField fl_env)) names
        ; (new_ty, fvs) <- rnLHsTyKi env ty
        ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc)
                 , fvs) }
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 2febede5c5..d2f5463d58 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -31,6 +31,7 @@ import GHC.Rename.Env
 import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames
                         , checkDupRdrNamesN, bindLocalNamesFV
                         , checkShadowedRdrNames, warnUnusedTypePatterns
+                        , warnForallIdentifier
                         , newLocalBndrsRn
                         , withHsDocContext, noNestedForallsContextsErr
                         , addNoNestedForallsContextsErr, checkInferredVars )
@@ -351,6 +352,7 @@ rnDefaultDecl (DefaultDecl _ tys)
 rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
 rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
   = do { topEnv :: HscEnv <- getTopEnv
+       ; warnForallIdentifier name
        ; name' <- lookupLocatedTopBndrRnN name
        ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
 
@@ -1220,6 +1222,7 @@ rnHsRuleDecl (HsRule { rd_name = rule_name
                      , rd_lhs  = lhs
                      , rd_rhs  = rhs })
   = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
+       ; mapM_ warnForallIdentifier rdr_names_w_loc
        ; checkDupRdrNamesN rdr_names_w_loc
        ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
@@ -2299,7 +2302,7 @@ rnConDecls = mapFvRn (wrapLocFstMA rnConDecl)
 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
 rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
                            , con_mb_cxt = mcxt, con_args = args
-                           , con_doc = mb_doc, con_forall = forall })
+                           , con_doc = mb_doc, con_forall = forall_ })
   = do  { _        <- addLocMA checkConName name
         ; new_name <- lookupLocatedTopConstructorRnN name
 
@@ -2326,7 +2329,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
                        , con_name = new_name, con_ex_tvs = new_ex_tvs
                        , con_mb_cxt = new_context, con_args = new_args
                        , con_doc = mb_doc
-                       , con_forall = forall }, -- Remove when #18311 is fixed
+                       , con_forall = forall_ }, -- Remove when #18311 is fixed
                   all_fvs) }}
 
 rnConDecl (ConDeclGADT { con_names   = names
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index a011b709cf..79eeaa3477 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -53,7 +53,7 @@ import GHC.Tc.Utils.Zonk   ( hsOverLitName )
 import GHC.Rename.Env
 import GHC.Rename.Fixity
 import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames
-                           , warnUnusedMatches, newLocalBndrRn
+                           , warnUnusedMatches, warnForallIdentifier
                            , checkUnusedRecordWildcard
                            , checkDupNames, checkDupAndShadowedNames
                            , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit )
@@ -232,14 +232,16 @@ newPatLName name_maker rdr_name@(L loc _)
 newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name
 newPatName (LamMk report_unused) rdr_name
   = CpsRn (\ thing_inside ->
-        do { name <- newLocalBndrRn rdr_name
+        do { warnForallIdentifier rdr_name
+           ; name <- newLocalBndrRn rdr_name
            ; (res, fvs) <- bindLocalNames [name] (thing_inside name)
            ; when report_unused $ warnUnusedMatches [name] fvs
            ; return (res, name `delFV` fvs) })
 
 newPatName (LetMk is_top fix_env) rdr_name
   = CpsRn (\ thing_inside ->
-        do { name <- case is_top of
+        do { warnForallIdentifier rdr_name
+           ; name <- case is_top of
                        NotTopLevel -> newLocalBndrRn rdr_name
                        TopLevel    -> newTopSrcBinder rdr_name
            ; bindLocalNames [name] $
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index fc27dac004..4041b0b6c8 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -15,6 +15,7 @@ module GHC.Rename.Utils (
         addFvRn, mapFvRn, mapMaybeFvRn,
         warnUnusedMatches, warnUnusedTypePatterns,
         warnUnusedTopBinds, warnUnusedLocalBinds,
+        warnForallIdentifier,
         checkUnusedRecordWildcard,
         mkFieldEnv,
         unknownSubordinateErr, badQualBndrErr, typeAppErr,
@@ -426,6 +427,13 @@ check_unused flag bound_names used_names
   = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
                                                bound_names))
 
+warnForallIdentifier :: LocatedN RdrName -> RnM ()
+warnForallIdentifier (L l rdr_name@(Unqual occ))
+  | isKw (fsLit "forall") || isKw (fsLit "∀")
+  = addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name)
+  where isKw = (occNameFS occ ==)
+warnForallIdentifier _ = return ()
+
 -------------------------
 --      Helpers
 warnUnusedGREs :: [GlobalRdrElt] -> RnM ()