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`.

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))

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

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

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)

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)

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)
 

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) }}
 

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

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)

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 []
 

docs/users_guide/8.10.1-notes.rst

+.. _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
+------------------

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

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

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]

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 }

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

testsuite/tests/rename/should_compile/T15957.hs

+{-# 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

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'])

testsuite/tests/rename/should_fail/T15957_Fail.hs

+{-# 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)
+

testsuite/tests/rename/should_fail/T15957_Fail.stderr

+
+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 ‘..’