Implement -Wredundant-record-wildcards and -Wunused-record-wildcards

-Wredundant-record-wildcards warns when a .. pattern binds no variables.

-Wunused-record-wildcards warns when none of the variables bound by a ..
pattern are used.

These flags are enabled by `-Wall`.

23 files changed, 365 insertions, 63 deletions

diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 8ec39bc1f5..91be1492a8 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -374,7 +374,7 @@ data HsRecFields p arg         -- A bunch of record fields
                                 --      { x = 3, y = True }
         -- Used for both expressions and patterns
   = HsRecFields { rec_flds   :: [LHsRecField p arg],
-                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
+                  rec_dotdot :: Maybe (Located Int) }  -- Note [DotDot fields]
   deriving (Functor, Foldable, Traversable)
 
 
@@ -593,7 +593,7 @@ instance (Outputable arg)
       => Outputable (HsRecFields p arg) where
   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
         = braces (fsep (punctuate comma (map ppr flds)))
-  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) })
         = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
         where
           dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 23cca4c737..9cd3a207ad 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -1316,26 +1316,35 @@ that were defined "implicitly", without being explicitly written by the user.
 
 The main purpose is to find names introduced by record wildcards so that we can avoid
 warning the user when they don't use those names (#4404)
+
+Since the addition of -Wunused-record-wildcards, this function returns a pair
+of [(SrcSpan, [Name])]. Each element of the list is one set of implicit
+binders, the first component of the tuple is the document describes the possible
+fix to the problem (by removing the ..).
+
+This means there is some unfortunate coupling between this function and where it
+is used but it's only used for one specific purpose in one place so it seemed
+easier.
 -}
 
 lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
-                -> NameSet
+                -> [(SrcSpan, [Name])]
 lStmtsImplicits = hs_lstmts
   where
     hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
-              -> NameSet
-    hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
+              -> [(SrcSpan, [Name])]
+    hs_lstmts = concatMap (hs_stmt . unLoc)
 
     hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
-            -> NameSet
+            -> [(SrcSpan, [Name])]
     hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
-    hs_stmt (ApplicativeStmt _ args _) = unionNameSets (map do_arg args)
+    hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
       where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
             do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
             do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits"
     hs_stmt (LetStmt _ binds)     = hs_local_binds (unLoc binds)
-    hs_stmt (BodyStmt {})         = emptyNameSet
-    hs_stmt (LastStmt {})         = emptyNameSet
+    hs_stmt (BodyStmt {})         = []
+    hs_stmt (LastStmt {})         = []
     hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
                                                 , s <- ss]
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
@@ -1343,28 +1352,28 @@ lStmtsImplicits = hs_lstmts
     hs_stmt (XStmtLR {})          = panic "lStmtsImplicits"
 
     hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
-    hs_local_binds (HsIPBinds {})           = emptyNameSet
-    hs_local_binds (EmptyLocalBinds _)      = emptyNameSet
-    hs_local_binds (XHsLocalBindsLR _)      = emptyNameSet
+    hs_local_binds (HsIPBinds {})           = []
+    hs_local_binds (EmptyLocalBinds _)      = []
+    hs_local_binds (XHsLocalBindsLR _)      = []
 
-hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet
+hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
 hsValBindsImplicits (XValBindsLR (NValBinds binds _))
-  = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
+  = concatMap (lhsBindsImplicits . snd) binds
 hsValBindsImplicits (ValBinds _ binds _)
   = lhsBindsImplicits binds
 
-lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet
-lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
+lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]
+lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []
   where
     lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
-    lhs_bind _ = emptyNameSet
+    lhs_bind _ = []
 
-lPatImplicits :: LPat GhcRn -> NameSet
+lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]
 lPatImplicits = hs_lpat
   where
     hs_lpat lpat = hs_pat (unLoc lpat)
 
-    hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
+    hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []
 
     hs_pat (LazyPat _ pat)      = hs_lpat pat
     hs_pat (BangPat _ pat)      = hs_lpat pat
@@ -1377,16 +1386,26 @@ lPatImplicits = hs_lpat
     hs_pat (SigPat _ pat _)     = hs_lpat pat
     hs_pat (CoPat _ _ pat _)    = hs_pat pat
 
-    hs_pat (ConPatIn _ ps)           = details ps
-    hs_pat (ConPatOut {pat_args=ps}) = details ps
+    hs_pat (ConPatIn n ps)           = details n ps
+    hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps
+
+    hs_pat _ = []
 
-    hs_pat _ = emptyNameSet
+    details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
+    details _ (PrefixCon ps)   = hs_lpats ps
+    details n (RecCon fs)      =
+      [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
+        ++ hs_lpats explicit_pats
 
-    details (PrefixCon ps)   = hs_lpats ps
-    details (RecCon fs)      = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit)
-      where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
+      where implicit_pats = map (hsRecFieldArg . unLoc) implicit
+            explicit_pats = map (hsRecFieldArg . unLoc) explicit
+
+
+            (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
                                                     | (i, fld) <- [0..] `zip` rec_flds fs
-                                                    , let pat = hsRecFieldArg
-                                                                     (unLoc fld)
-                                                          pat_explicit = maybe True (i<) (rec_dotdot fs)]
-    details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2
+                                                    ,  let  pat_explicit =
+                                                              maybe True ((i<) . unLoc)
+                                                                         (rec_dotdot fs)]
+            err_loc = maybe (getLoc n) getLoc (rec_dotdot fs)
+
+    details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 858d174c17..f929d98cca 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -790,6 +790,8 @@ data WarningFlag =
    | Opt_WarnUnusedMatches
    | Opt_WarnUnusedTypePatterns
    | Opt_WarnUnusedForalls
+   | Opt_WarnUnusedRecordWildcards
+   | Opt_WarnRedundantRecordWildcards
    | Opt_WarnWarningsDeprecations
    | Opt_WarnDeprecatedFlags
    | Opt_WarnMissingMonadFailInstances -- since 8.0
@@ -4046,6 +4048,8 @@ wWarningFlagsDeps = [
   flagSpec "unused-pattern-binds"        Opt_WarnUnusedPatternBinds,
   flagSpec "unused-top-binds"            Opt_WarnUnusedTopBinds,
   flagSpec "unused-type-patterns"        Opt_WarnUnusedTypePatterns,
+  flagSpec "unused-record-wildcards"     Opt_WarnUnusedRecordWildcards,
+  flagSpec "redundant-record-wildcards"  Opt_WarnRedundantRecordWildcards,
   flagSpec "warnings-deprecations"       Opt_WarnWarningsDeprecations,
   flagSpec "wrong-do-bind"               Opt_WarnWrongDoBind,
   flagSpec "missing-pattern-synonym-signatures"
@@ -4799,7 +4803,9 @@ minusWallOpts
         Opt_WarnUnusedDoBind,
         Opt_WarnTrustworthySafe,
         Opt_WarnUntickedPromotedConstructors,
-        Opt_WarnMissingPatternSynonymSignatures
+        Opt_WarnMissingPatternSynonymSignatures,
+        Opt_WarnUnusedRecordWildcards,
+        Opt_WarnRedundantRecordWildcards
       ]
 
 -- | Things you get with -Weverything, i.e. *all* known warnings flags
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 820144d930..da9febdcd8 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -3084,16 +3084,16 @@ qual  :: { LStmt GhcPs (LHsExpr GhcPs) }
 -----------------------------------------------------------------------------
 -- Record Field Update/Construction
 
-fbinds  :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) }
+fbinds  :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) }
         : fbinds1                       { $1 }
-        | {- empty -}                   { ([],([], False)) }
+        | {- empty -}                   { ([],([], Nothing)) }
 
-fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) }
+fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) }
         : fbind ',' fbinds1
                 {% addAnnotation (gl $1) AnnComma (gl $2) >>
                    return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) }
-        | fbind                         { ([],([$1], False)) }
-        | '..'                          { ([mj AnnDotdot $1],([],   True)) }
+        | fbind                         { ([],([$1], Nothing)) }
+        | '..'                          { ([mj AnnDotdot $1],([],   Just (getLoc $1))) }
 
 fbind   :: { LHsRecField GhcPs (LHsExpr GhcPs) }
         : qvar '=' texp {% ams  (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 88217c27a2..91a27e93e6 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1976,14 +1976,14 @@ checkPrecP (dL->L l (_,i)) (dL->L _ ol)
 mkRecConstrOrUpdate
         :: LHsExpr GhcPs
         -> SrcSpan
-        -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
+        -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
         -> P (HsExpr GhcPs)
 
 mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
   | isRdrDataCon c
   = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
-mkRecConstrOrUpdate exp@(dL->L l _) _ (fs,dd)
-  | dd        = parseErrorSDoc l (text "You cannot use `..' in a record update")
+mkRecConstrOrUpdate exp _ (fs,dd)
+  | Just dd_loc <- dd = parseErrorSDoc dd_loc (text "You cannot use `..' in a record update")
   | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
 
 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
@@ -1996,10 +1996,10 @@ mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
 mkRdrRecordCon con flds
   = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }
 
-mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
-mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
-mk_rec_fields fs True  = HsRecFields { rec_flds = fs
-                                     , rec_dotdot = Just (length fs) }
+mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
+mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
+mk_rec_fields fs (Just s)  = HsRecFields { rec_flds = fs
+                                     , rec_dotdot = Just (cL s (length fs)) }
 
 mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
 mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun)
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index ade67b7a49..3650fecf09 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -38,7 +38,8 @@ import RnNames
 import RnEnv
 import RnFixity
 import RnUtils          ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn
-                        , checkDupRdrNames, warnUnusedLocalBinds
+                        , checkDupRdrNames, warnUnusedLocalBinds,
+                        checkUnusedRecordWildcard
                         , checkDupAndShadowedNames, bindLocalNamesFV )
 import DynFlags
 import Module
@@ -362,7 +363,12 @@ rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
         ; let real_uses = findUses dus result_fvs
               -- Insert fake uses for variables introduced implicitly by
               -- wildcards (#4404)
-              implicit_uses = hsValBindsImplicits binds'
+              rec_uses = hsValBindsImplicits binds'
+              implicit_uses = mkNameSet $ concatMap snd
+                                        $ rec_uses
+        ; mapM_ (\(loc, ns) ->
+                    checkUnusedRecordWildcard loc real_uses (Just ns))
+                rec_uses
         ; warnUnusedLocalBinds bound_names
                                       (real_uses `unionNameSet` implicit_uses)
 
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 607f5237c5..c74e46df97 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -35,7 +35,8 @@ import RnFixity
 import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames
                         , bindLocalNames
                         , mapMaybeFvRn, mapFvRn
-                        , warnUnusedLocalBinds, typeAppErr )
+                        , warnUnusedLocalBinds, typeAppErr
+                        , checkUnusedRecordWildcard )
 import RnUnbound        ( reportUnboundName )
 import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
 import RnTypes
@@ -1089,13 +1090,16 @@ rnRecStmtsAndThen rnBody s cont
           --    ...bring them and their fixities into scope
         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
               -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
-              implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
+              rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)
+              implicit_uses = mkNameSet $ concatMap snd $ rec_uses
         ; bindLocalNamesFV bound_names $
           addLocalFixities fix_env bound_names $ do
 
           -- (C) do the right-hand-sides and thing-inside
         { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
         ; (res, fvs) <- cont segs
+        ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))
+                rec_uses
         ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
         ; return (res, fvs) }}
 
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index ba19c4ebff..3d5f3b92b7 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -54,6 +54,7 @@ import RnEnv
 import RnFixity
 import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames
                            , warnUnusedMatches, newLocalBndrRn
+                           , checkUnusedRecordWildcard
                            , checkDupNames, checkDupAndShadowedNames
                            , checkTupSize , unknownSubordinateErr )
 import RnTypes
@@ -529,6 +530,12 @@ rnConPatAndThen mk con (RecCon rpats)
         ; rpats' <- rnHsRecPatsAndThen mk con' rpats
         ; return (ConPatIn con' (RecCon rpats')) }
 
+checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
+checkUnusedRecordWildcardCps loc dotdot_names =
+  CpsRn (\thing -> do
+                    (r, fvs) <- thing ()
+                    checkUnusedRecordWildcard loc fvs dotdot_names
+                    return (r, fvs) )
 --------------------
 rnHsRecPatsAndThen :: NameMaker
                    -> Located Name      -- Constructor
@@ -539,6 +546,7 @@ rnHsRecPatsAndThen mk (dL->L _ con)
   = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
                                             hs_rec_fields
        ; flds' <- mapM rn_field (flds `zip` [1..])
+       ; check_unused_wildcard (implicit_binders flds' <$> dd)
        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
   where
     mkVarPat l n = VarPat noExt (cL l n)
@@ -546,10 +554,23 @@ rnHsRecPatsAndThen mk (dL->L _ con)
       do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)
          ; return (cL l (fld { hsRecFieldArg = arg' })) }
 
+    loc = maybe noSrcSpan getLoc dd
+
+    -- Get the arguments of the implicit binders
+    implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats
+      where
+        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)
+
+    -- Don't warn for let P{..} = ... in ...
+    check_unused_wildcard = case mk of
+                              LetMk{} -> const (return ())
+                              LamMk{} -> checkUnusedRecordWildcardCps loc
+
         -- Suppress unused-match reporting for fields introduced by ".."
     nested_mk Nothing  mk                    _  = mk
     nested_mk (Just _) mk@(LetMk {})         _  = mk
-    nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
+    nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
+      = LamMk (report_unused && (n' <= n))
 
 {-
 ************************************************************************
@@ -622,19 +643,18 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                 -- due to #15884
 
 
-    rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat
+    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in HsPat
               -> Maybe Name -- The constructor (Nothing for an
                                 --    out of scope constructor)
               -> [LHsRecField GhcRn arg] -- Explicit fields
-              -> RnM [LHsRecField GhcRn arg]   -- Filled in .. fields
-    rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
+              -> RnM ([LHsRecField GhcRn arg])   -- Field Labels we need to fill in
+    rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match
       | not (isUnboundName con) -- This test is because if the constructor
                                 -- isn't in scope the constructor lookup will add
                                 -- an error but still return an unbound name. We
                                 -- don't want that to screw up the dot-dot fill-in stuff.
       = ASSERT( flds `lengthIs` n )
-        do { loc <- getSrcSpanM -- Rather approximate
-           ; dd_flag <- xoptM LangExt.RecordWildCards
+        do { dd_flag <- xoptM LangExt.RecordWildCards
            ; checkErr dd_flag (needFlagDotDot ctxt)
            ; (rdr_env, lcl_env) <- getRdrEnvs
            ; con_fields <- lookupConstructorFields con
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 3a743b56fb..9de4aacaba 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -14,6 +14,7 @@ module RnUtils (
         addFvRn, mapFvRn, mapMaybeFvRn,
         warnUnusedMatches, warnUnusedTypePatterns,
         warnUnusedTopBinds, warnUnusedLocalBinds,
+        checkUnusedRecordWildcard,
         mkFieldEnv,
         unknownSubordinateErr, badQualBndrErr, typeAppErr,
         HsDocContext(..), pprHsDocContext,
@@ -222,6 +223,57 @@ warnUnusedTopBinds gres
                                else                 gres
          warnUnusedGREs gres'
 
+
+-- | Checks to see if we need to warn for -Wunused-record-wildcards or
+-- -Wredundant-record-wildcards
+checkUnusedRecordWildcard :: SrcSpan
+                          -> FreeVars
+                          -> Maybe [Name]
+                          -> RnM ()
+checkUnusedRecordWildcard _ _ Nothing    = return ()
+checkUnusedRecordWildcard loc _ (Just [])  = do
+  -- Add a new warning if the .. pattern binds no variables
+  setSrcSpan loc $ warnRedundantRecordWildcard
+checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
+  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs
+
+
+-- | Produce a warning when the `..` pattern binds no new
+-- variables.
+--
+-- @
+--   data P = P { x :: Int }
+--
+--   foo (P{x, ..}) = x
+-- @
+--
+-- The `..` here doesn't bind any variables as `x` is already bound.
+warnRedundantRecordWildcard :: RnM ()
+warnRedundantRecordWildcard =
+  whenWOptM Opt_WarnRedundantRecordWildcards
+            (addWarn (Reason Opt_WarnRedundantRecordWildcards)
+                     redundantWildcardWarning)
+
+
+-- | Produce a warning when no variables bound by a `..` pattern are used.
+--
+-- @
+--   data P = P { x :: Int }
+--
+--   foo (P{..}) = ()
+-- @
+--
+-- The `..` pattern binds `x` but it is not used in the RHS so we issue
+-- a warning.
+warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
+warnUnusedRecordWildcard ns used_names = do
+  let used = filter (`elemNameSet` used_names) ns
+  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
+  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)
+    unusedRecordWildcardWarning
+
+
+
 warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
   :: [Name] -> FreeVars -> RnM ()
 warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds
@@ -296,6 +348,20 @@ addUnusedWarning flag occ span msg
          nest 2 $ pprNonVarNameSpace (occNameSpace occ)
                         <+> quotes (ppr occ)]
 
+unusedRecordWildcardWarning :: SDoc
+unusedRecordWildcardWarning =
+  wildcardDoc $ text "No variables bound in the record wildcard match are used"
+
+redundantWildcardWarning :: SDoc
+redundantWildcardWarning =
+  wildcardDoc $ text "Record wildcard does not bind any new variables"
+
+wildcardDoc :: SDoc -> SDoc
+wildcardDoc herald =
+  herald
+    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"
+                                            <+> quotes (text ".."))
+
 addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
 addNameClashErrRn rdr_name gres
   | all isLocalGRE gres && not (all isRecFldGRE gres)
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index 1fe2c68ae0..d6b1f70e38 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -397,7 +397,7 @@ mkTrNameLit = do
 -- | Make Typeable bindings for the given 'TyCon'.
 mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
                 -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
-mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
+mkTyConRepBinds stuff todo (TypeableTyCon {..})
   = do -- Make a KindRep
        let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)
        liftTc $ traceTc "mkTyConKindRepBinds"
@@ -477,7 +477,7 @@ initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
 mkExportedKindReps :: TypeableStuff
                    -> [(Kind, Id)]  -- ^ the kinds to generate bindings for
                    -> KindRepM ()
-mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding
+mkExportedKindReps stuff = mapM_ kindrep_binding
   where
     empty_scope = mkDeBruijnContext []
 
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
new file mode 100644
index 0000000000..cf67246abf
--- /dev/null
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -0,0 +1,45 @@
+.. _release-8-10-1:
+
+Release notes for version 8.10.1
+===============================
+
+The significant changes to the various parts of the compiler are listed in the
+following sections.
+
+
+Highlights
+----------
+
+Full details
+------------
+
+Language
+~~~~~~~~
+
+Compiler
+~~~~~~~~
+
+- Add new flags :ghc-flag:`-Wunused-record-wildcards` and
+  :ghc-flag:`-Wredundant-record-wildcards`  which warn users when they have
+  redundant or unused uses of a record wildcard match.
+
+Runtime system
+~~~~~~~~~~~~~~
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+
+``ghc-prim`` library
+~~~~~~~~~~~~~~~~~~~~
+
+``ghc`` library
+~~~~~~~~~~~~~~~
+
+``base`` library
+~~~~~~~~~~~~~~~~
+
+Build system
+~~~~~~~~~~~~
+
+Included libraries
+------------------
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 03ca184531..c392ab38df 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -1565,9 +1565,9 @@ of ``-W(no-)*``.
 
     When :extension:`ExplicitForAll` is enabled, explicitly quantified type
     variables may also be identified as unused. For instance: ::
-      
+
         type instance forall x y. F x y = []
-    
+
     would still report ``x`` and ``y`` as unused on the right hand side
 
     Unlike :ghc-flag:`-Wunused-matches`, :ghc-flag:`-Wunused-type-patterns` is
@@ -1575,7 +1575,7 @@ of ``-W(no-)*``.
     unlike term-level pattern names, type names are often chosen expressly for
     documentation purposes, so using underscores in type names can make the
     documentation harder to read.
-    
+
 .. ghc-flag:: -Wunused-foralls
     :shortdesc: warn about type variables in user-written
         ``forall``\\s that are unused
@@ -1594,6 +1594,50 @@ of ``-W(no-)*``.
 
     would report ``a`` and ``c`` as unused.
 
+.. ghc-flag:: -Wunused-record-wildcards
+    :shortdesc: Warn about record wildcard matches when none of the bound variables
+      are used.
+    :type: dynamic
+    :since: 8.10.1
+    :reverse: -Wno-unused-record-wildcards
+    :category:
+
+    .. index::
+       single: unused, warning, record wildcards
+
+    Report all record wildcards where none of the variables bound implicitly
+    are used. For instance: ::
+
+
+	data P = P { x :: Int, y :: Int }
+
+        f1 :: P -> Int
+        f1 P{..} = 1 + 3
+
+    would report that the ``P{..}`` match is unused.
+
+.. ghc-flag:: -Wredundant-record-wildcards
+    :shortdesc: Warn about record wildcard matches when the wildcard binds no patterns.
+    :type: dynamic
+    :since: 8.10.1
+    :reverse: -Wno-redundant-record-wildcards
+    :category:
+
+    .. index::
+       single: unused, warning, record wildcards
+
+    Report all record wildcards where the wild card match binds no patterns.
+    For instance: ::
+
+
+	data P = P { x :: Int, y :: Int }
+
+        f1 :: P -> Int
+        f1 P{x,y,..} = x + y
+
+    would report that the ``P{x, y, ..}`` match has a redundant use of ``..``.
+
+
 .. ghc-flag:: -Wwrong-do-bind
     :shortdesc: warn about do bindings that appear to throw away monadic values
         that you should have bound instead
diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index 01c226dfbd..720eef575b 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -604,7 +604,7 @@ hSetBinaryMode handle bin =
 -- data is flushed first.
 hSetNewlineMode :: Handle -> NewlineMode -> IO ()
 hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =
-  withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} ->
+  withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{} ->
     do
          flushBuffer h_
          return h_{ haInputNL=i, haOutputNL=o }
@@ -705,7 +705,7 @@ dupHandleTo :: FilePath
             -> Maybe HandleFinalizer
             -> IO Handle__
 dupHandleTo filepath h other_side
-            hto_@Handle__{haDevice=devTo,..}
+            hto_@Handle__{haDevice=devTo}
             h_@Handle__{haDevice=dev} mb_finalizer = do
   flushBuffer h_
   case cast devTo of
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index a3f9b9729e..e624a17b78 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -313,7 +313,7 @@ allClosures (APClosure {..}) = fun:payload
 allClosures (PAPClosure {..}) = fun:payload
 allClosures (APStackClosure {..}) = fun:payload
 allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]
-allClosures (ArrWordsClosure {..}) = []
+allClosures (ArrWordsClosure {}) = []
 allClosures (MutArrClosure {..}) = mccPayload
 allClosures (MutVarClosure {..}) = [var]
 allClosures (MVarClosure {..}) = [queueHead,queueTail,value]
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index d9f4443d14..09df787db3 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -265,7 +265,7 @@ runTH pipe rstate rhv ty mb_loc = do
 runTHQ
   :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
   -> IO ByteString
-runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
+runTHQ pipe rstate mb_loc ghciq = do
   qstateref <- localRef rstate
   qstate <- readIORef qstateref
   let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
diff --git a/libraries/libiserv/src/Lib.hs b/libraries/libiserv/src/Lib.hs
index 57e65706c3..0c478d3bf5 100644
--- a/libraries/libiserv/src/Lib.hs
+++ b/libraries/libiserv/src/Lib.hs
@@ -13,7 +13,7 @@ import Data.Binary
 type MessageHook = Msg -> IO Msg
 
 serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
-serv verbose hook pipe@Pipe{..} restore = loop
+serv verbose hook pipe restore = loop
  where
   loop = do
     Msg msg <- readPipe pipe getMessage >>= hook
diff --git a/testsuite/tests/rename/should_compile/T15957.hs b/testsuite/tests/rename/should_compile/T15957.hs
new file mode 100644
index 0000000000..d684e57495
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T15957.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module T15957 where
+
+data P = P { x :: Int, y :: Int }
+
+g1 P{..} = x + 3 -- x from .. is used
+g2 P{x, ..} = x + y -- y from .. is used, even if it's in a weird style
+
+old P{..} | x < 5 = 10
+
+-- Record wildcards in lets have different scoping rules.. they bring
+-- all the identifiers into scope
+do_example :: IO Int
+do_example = do
+  let P{..} = P 1 2
+  return $ x + y
+
+let_in_example =
+  let P{..} = P 1 2
+  in x + 4
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 0c60360e17..4d427de44f 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -166,3 +166,4 @@ test('T15798a', normal, compile, [''])
 test('T15798b', normal, compile, [''])
 test('T15798c', normal, compile, [''])
 test('T16116a', normal, compile, [''])
+test('T15957', normal, compile, ['-Werror -Wredundant-record-wildcards -Wunused-record-wildcards'])
diff --git a/testsuite/tests/rename/should_fail/T15957_Fail.hs b/testsuite/tests/rename/should_fail/T15957_Fail.hs
new file mode 100644
index 0000000000..77ed3ada15
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T15957_Fail.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module T15957_Fail where
+
+data P = P { x :: Int, y :: Int }
+
+f1 P{..} = 1 + 3 -- nothing bound is used
+f2 P{x, ..} = x + 3 -- y bound but not used
+f3 P{x, y, ..} = x + y -- no bindings left, i.e. no new useful bindings introduced
+
+g2 P{x=a, ..} = a + 3
+g3 P{x=a, y=b, ..} = a + b
+g4 P{x=0, y=0,..} = 0
+g4 _ = 0
+
+-- Record wildcards in lets have different scoping rules.. they bring
+-- all the identifiers into scope
+do_example :: IO Int
+do_example = do
+  let P{..} = P 1 2
+  return $ 0
+
+let_in_example :: Int
+let_in_example =
+  let P{..} = P 1 2
+  in 0
+
+data Q = Q { a, b :: P }
+
+nested :: Q -> Int
+nested Q { a = P{..}, .. } = (case b of (P x1 _) -> x1)
+
diff --git a/testsuite/tests/rename/should_fail/T15957_Fail.stderr b/testsuite/tests/rename/should_fail/T15957_Fail.stderr
new file mode 100644
index 0000000000..54d77c189b
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T15957_Fail.stderr
@@ -0,0 +1,36 @@
+
+T15957_Fail.hs:7:6: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:8:9: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:9:12: error: [-Wredundant-record-wildcards (in -Wall), -Werror=redundant-record-wildcards]
+    Record wildcard does not bind any new variables
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:11:11: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:12:16: error: [-Wredundant-record-wildcards (in -Wall), -Werror=redundant-record-wildcards]
+    Record wildcard does not bind any new variables
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:13:15: error: [-Wredundant-record-wildcards (in -Wall), -Werror=redundant-record-wildcards]
+    Record wildcard does not bind any new variables
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:20:9: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:25:9: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+      Possible fix: omit the ‘..’
+
+T15957_Fail.hs:31:18: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+      Possible fix: omit the ‘..’
diff --git a/testsuite/tests/rename/should_fail/T9437.stderr b/testsuite/tests/rename/should_fail/T9437.stderr
index 8c2222ef97..2b8ec84502 100644
--- a/testsuite/tests/rename/should_fail/T9437.stderr
+++ b/testsuite/tests/rename/should_fail/T9437.stderr
@@ -1,2 +1,2 @@
 
-T9437.hs:8:12: You cannot use `..' in a record update
+T9437.hs:8:18: You cannot use `..' in a record update
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index ce8c5c9a13..af382b1a0c 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -145,3 +145,4 @@ test('T16002', normal, compile_fail, [''])
 test('T16114', normal, compile_fail, [''])
 test('T16116b', normal, compile_fail, [''])
 test('ExplicitForAllRules2', normal, compile_fail, [''])
+test('T15957_Fail', normal, compile_fail, ['-Werror -Wall -Wno-missing-signatures'])
diff --git a/testsuite/tests/typecheck/should_compile/T4404.hs b/testsuite/tests/typecheck/should_compile/T4404.hs
index 1b46a158fb..36d16e031f 100644
--- a/testsuite/tests/typecheck/should_compile/T4404.hs
+++ b/testsuite/tests/typecheck/should_compile/T4404.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards, RecursiveDo #-}
+{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 
 module TT where