Implement -Wredundant-record-wildcards and -Wunused-record-wildcardswip/wildcards-warn

-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 not enabled by `-Wall` currently. If people think it
is appropuiate to add them then that is an easy change.

10 files changed, 185 insertions, 27 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index a9b4a03962..747c8601ce 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
@@ -4040,6 +4042,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"
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 607f5237c5..bbc8f912b1 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -297,7 +297,7 @@ rnExpr (ExplicitSum x alt arity expr)
 rnExpr (RecordCon { rcon_con_name = con_id
                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
   = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
-       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
+       ; (flds, fvs)   <- rnHsRecFieldsExpr (HsRecFieldCon con_name) mk_hs_var rec_binds
        ; (flds', fvss) <- mapAndUnzipM rn_field flds
        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
        ; return (RecordCon { rcon_ext = noExt
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index ba19c4ebff..2be3657b11 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -25,7 +25,7 @@ module RnPat (-- main entry points
                                              --   sometimes we want to make top (qualified) names.
               isTopRecNameMaker,
 
-              rnHsRecFields, HsRecFieldContext(..),
+              rnHsRecFields, rnHsRecFieldsExpr, HsRecFieldContext(..),
               rnHsRecUpdFields,
 
               -- CpsRn monad
@@ -54,6 +54,7 @@ import RnEnv
 import RnFixity
 import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames
                            , warnUnusedMatches, newLocalBndrRn
+                           , warnUnusedRecordWildcard
                            , checkDupNames, checkDupAndShadowedNames
                            , checkTupSize , unknownSubordinateErr )
 import RnTypes
@@ -74,6 +75,8 @@ import qualified GHC.LanguageExtensions as LangExt
 import Control.Monad       ( when, liftM, ap, guard )
 import qualified Data.List.NonEmpty as NE
 import Data.Ratio
+import DynFlags
+import Data.Maybe
 
 {-
 *********************************************************
@@ -529,6 +532,30 @@ rnConPatAndThen mk con (RecCon rpats)
         ; rpats' <- rnHsRecPatsAndThen mk con' rpats
         ; return (ConPatIn con' (RecCon rpats')) }
 
+-- Run the inner action to find out its free variables and then
+-- check whether the variables we bound are actually used.
+-- If none of them are used and -Wwarn-redundant-record-wildcards is
+-- enabled then we issue a warning.
+checkUnusedRecordWildcard :: SrcSpan
+                          -> Maybe [(LHsRecField GhcRn arg, Name)]
+                          -> CpsRn [LHsRecField GhcRn arg]
+checkUnusedRecordWildcard _ Nothing = return []
+checkUnusedRecordWildcard loc (Just [])  = do
+  -- Add a new warning if the .. pattern binds no variables
+  liftCps . setSrcSpan loc $
+              whenWOptM Opt_WarnRedundantRecordWildcards
+                (addWarn (Reason Opt_WarnRedundantRecordWildcards)
+                         redundantWildcardErr)
+  return []
+checkUnusedRecordWildcard loc (Just dds) =
+  let (res, dotdot_names) = unzip dds
+  in CpsRn (\thing -> do
+                    (r, fvs) <- thing res
+                    -- Check if any of the bound variables are used. We
+                    -- warn if none of them are used.
+                    setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs
+                    return (r, fvs) )
+
 --------------------
 rnHsRecPatsAndThen :: NameMaker
                    -> Located Name      -- Constructor
@@ -536,20 +563,33 @@ rnHsRecPatsAndThen :: NameMaker
                    -> CpsRn (HsRecFields GhcRn (LPat GhcRn))
 rnHsRecPatsAndThen mk (dL->L _ con)
      hs_rec_fields@(HsRecFields { rec_dotdot = dd })
-  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
+  = do { (flds, mdd_fls) <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
                                             hs_rec_fields
-       ; flds' <- mapM rn_field (flds `zip` [1..])
-       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
+       -- Save the location from the outer scope so the error points
+       -- to the whole match. Otherwise the error points to one
+       -- of the inner variables.
+       ; loc <- liftCps getSrcSpanM
+       ; flds' <- mapM rn_field flds
+       ; mdd_fls' <- traverse (mapM rn_dot_dot_fl) mdd_fls
+       ; dd_fls' <- checkUnusedRecordWildcard loc mdd_fls'
+       ; return (HsRecFields { rec_flds = flds' ++ dd_fls', rec_dotdot = dd }) }
   where
     mkVarPat l n = VarPat noExt (cL l n)
-    rn_field (dL->L l fld, n') =
-      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)
+    rn_field (dL->L l fld) =
+      do { arg' <- rnLPatAndThen mk (hsRecFieldArg fld)
          ; return (cL l (fld { hsRecFieldArg = arg' })) }
 
+    rn_dot_dot_fl fl = do
+      loc <- liftCps getSrcSpanM
+      let arg_rdr = mkVarUnqual (flLabel fl)
+      name <- newPatName (nested_mk mk) (cL loc arg_rdr)
+      let e = VarPat noExt (cL loc name)
+          rec_field = mkDotDotHsRecField loc (\_ _ -> e) fl
+      return (rec_field, name)
+
         -- 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 mk@(LetMk {}) = mk
+    nested_mk (LamMk {})    = LamMk False
 
 {-
 ************************************************************************
@@ -564,13 +604,43 @@ data HsRecFieldContext
   | HsRecFieldPat Name
   | HsRecFieldUpd
 
-rnHsRecFields
+rnHsRecFieldsExpr
     :: forall arg. HasSrcSpan arg =>
        HsRecFieldContext
     -> (SrcSpan -> RdrName -> SrcSpanLess arg)
          -- When punning, use this to build a new field
     -> HsRecFields GhcPs arg
     -> RnM ([LHsRecField GhcRn arg], FreeVars)
+rnHsRecFieldsExpr ctxt mk_arg fs = do
+  ((r, mdot_fls), fvs) <- rnHsRecFields ctxt mk_arg fs
+  loc <- getSrcSpanM
+  let dot_fls = fromMaybe [] mdot_fls
+      mk_dd fl = mkDotDotHsRecField loc mk_arg fl
+  return (r ++ (map mk_dd dot_fls), fvs)
+
+mkDotDotHsRecField :: HasSrcSpan arg
+                   => SrcSpan
+                   -> (SrcSpan -> RdrName -> SrcSpanLess arg)
+                   -> FieldLabel
+                   -> LHsRecField GhcRn arg
+mkDotDotHsRecField loc mk_arg fl =
+  cL loc (HsRecField
+    { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
+    , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
+    , hsRecPun      = False })
+  where
+    sel     = flSelector fl
+    arg_rdr = mkVarUnqual (flLabel fl)
+
+-- The FieldLabels we need to make names for are returned as they are treated
+-- differently to normal record fields when renaming patterns.
+rnHsRecFields
+    :: forall arg. HasSrcSpan arg =>
+       HsRecFieldContext
+    -> (SrcSpan -> RdrName -> SrcSpanLess arg)
+         -- When punning, use this to build a new field
+    -> HsRecFields GhcPs arg
+    -> RnM (([LHsRecField GhcRn arg], Maybe [FieldLabel]), FreeVars)
 
 -- This surprisingly complicated pass
 --   a) looks up the field name (possibly using disambiguation)
@@ -588,8 +658,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
        ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
        ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
        ; let all_flds | null dotdot_flds = flds1
-                      | otherwise        = flds1 ++ dotdot_flds
-       ; return (all_flds, mkFVs (getFieldIds all_flds)) }
+                      | otherwise        = flds1 -- ++ fromMaybe [] dotdot_flds
+       ; return ((flds1, dotdot_flds), mkFVs (getFieldIds all_flds)) }
   where
     mb_con = case ctxt of
                 HsRecFieldCon con  -> Just con
@@ -626,15 +696,14 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
               -> Maybe Name -- The constructor (Nothing for an
                                 --    out of scope constructor)
               -> [LHsRecField GhcRn arg] -- Explicit fields
-              -> RnM [LHsRecField GhcRn arg]   -- Filled in .. fields
+              -> RnM (Maybe [FieldLabel])   -- Field Labels we need to fill in
     rn_dotdot (Just 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
@@ -660,16 +729,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                     _other           -> True ]
 
            ; addUsedGREs dot_dot_gres
-           ; return [ cL loc (HsRecField
-                        { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
-                        , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
-                        , hsRecPun      = False })
-                    | fl <- dot_dot_fields
-                    , let sel     = flSelector fl
-                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }
+           ; return (Just dot_dot_fields)
+          }
 
     rn_dotdot _dotdot _mb_con _flds
-      = return []
+      = return Nothing
       -- _dotdot = Nothing => No ".." at all
       -- _mb_con = Nothing => Record update
       -- _mb_con = Just unbound => Out of scope data constructor
@@ -787,6 +851,9 @@ dupFieldErr ctxt dups
           quotes (ppr (NE.head dups)),
           text "in record", pprRFC ctxt]
 
+redundantWildcardErr :: SDoc
+redundantWildcardErr = text "Record wildcard does not bind any new variables"
+
 pprRFC :: HsRecFieldContext -> SDoc
 pprRFC (HsRecFieldCon {}) = text "construction"
 pprRFC (HsRecFieldPat {}) = text "pattern"
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 3a743b56fb..8d103142ed 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -14,6 +14,7 @@ module RnUtils (
         addFvRn, mapFvRn, mapMaybeFvRn,
         warnUnusedMatches, warnUnusedTypePatterns,
         warnUnusedTopBinds, warnUnusedLocalBinds,
+        warnUnusedRecordWildcard,
         mkFieldEnv,
         unknownSubordinateErr, badQualBndrErr, typeAppErr,
         HsDocContext(..), pprHsDocContext,
@@ -222,6 +223,16 @@ warnUnusedTopBinds gres
                                else                 gres
          warnUnusedGREs gres'
 
+
+-- | Get to see whether at least one name from each RecordWildcard is used.
+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 +307,10 @@ addUnusedWarning flag occ span msg
          nest 2 $ pprNonVarNameSpace (occNameSpace occ)
                         <+> quotes (ppr occ)]
 
+unusedRecordWildcardWarning :: SDoc
+unusedRecordWildcardWarning
+  = text "No variables bound in the record wildcard match are used"
+
 addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
 addNameClashErrRn rdr_name gres
   | all isLocalGRE gres && not (all isRecFldGRE gres)
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 03ca184531..396bc2b1bc 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,48 @@ 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
+    :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
+    :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/testsuite/tests/rename/should_compile/T15957.hs b/testsuite/tests/rename/should_compile/T15957.hs
new file mode 100644
index 0000000000..afa8eaae11
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T15957.hs
@@ -0,0 +1,8 @@
+{-# 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
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..9c7ff6d8b6
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T15957_Fail.hs
@@ -0,0 +1,11 @@
+{-# 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
+
+
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..6bebb08981
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T15957_Fail.stderr
@@ -0,0 +1,9 @@
+
+T15957_Fail.hs:7:4: error: [-Wunused-record-wildcards, -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+
+T15957_Fail.hs:8:4: error: [-Wunused-record-wildcards, -Werror=unused-record-wildcards]
+    No variables bound in the record wildcard match are used
+
+T15957_Fail.hs:9:4: error: [-Wredundant-record-wildcards, -Werror=redundant-record-wildcards]
+    Record wildcard does not bind any new variables
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index ce8c5c9a13..b5b244680e 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 -Wredundant-record-wildcards -Wunused-record-wildcards'])