Ignore names introduced "implicitly" in unused-variable warnings (Fix #4404)wip/T4404

We collect variables introduced by the {...} part of a let-like record wildcard
pattern and do not warn if the user then doesn't actually use them.

3 files changed, 88 insertions, 3 deletions

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index bf75f4ccf4..13f3cd7e55 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -61,7 +61,10 @@ module HsUtils(
   collectSigTysFromPats, collectSigTysFromPat,
 
   hsTyClDeclBinders, hsTyClDeclsBinders, 
-  hsForeignDeclsBinders, hsGroupBinders
+  hsForeignDeclsBinders, hsGroupBinders,
+  
+  -- Collecting implicit binders
+  lStmtsImplicits, hsValBindsImplicits, lPatImplicits
   ) where
 
 import HsDecls
@@ -81,8 +84,11 @@ import NameSet
 import BasicTypes
 import SrcLoc
 import FastString
+import Outputable
 import Util
 import Bag
+
+import Data.Either
 \end{code}
 
 
@@ -617,6 +623,81 @@ hsConDeclsBinders cons
 
 %************************************************************************
 %*									*
+	Collecting binders the user did not write
+%*									*
+%************************************************************************
+
+The job of this family of functions is to run through binding sites and find the set of all Names
+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)
+
+\begin{code}
+lStmtsImplicits :: [LStmtLR Name idR] -> NameSet
+lStmtsImplicits = hs_lstmts
+  where
+    hs_lstmts :: [LStmtLR Name idR] -> NameSet
+    hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet
+    
+    hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
+    hs_stmt (LetStmt binds)      = hs_local_binds binds
+    hs_stmt (ExprStmt _ _ _)     = emptyNameSet
+    hs_stmt (ParStmt xs)         = hs_lstmts $ concatMap fst xs
+    
+    hs_stmt (TransformStmt stmts _ _ _)   = hs_lstmts stmts
+    hs_stmt (GroupStmt     stmts _ _ _)   = hs_lstmts stmts
+    hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
+    
+    hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
+    hs_local_binds (HsIPBinds _)         = emptyNameSet
+    hs_local_binds EmptyLocalBinds       = emptyNameSet
+
+hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
+hsValBindsImplicits (ValBindsOut binds _)
+  = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
+  where
+    hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
+    hs_bind _ = emptyNameSet
+hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
+
+lPatImplicits :: LPat Name -> NameSet
+lPatImplicits = hs_lpat
+  where
+    hs_lpat (L _ pat) = hs_pat pat
+    
+    hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet
+    
+    hs_pat (LazyPat pat)       = hs_lpat pat
+    hs_pat (BangPat pat)       = hs_lpat pat
+    hs_pat (AsPat _ pat)       = hs_lpat pat
+    hs_pat (ViewPat _ pat _)   = hs_lpat pat
+    hs_pat (ParPat  pat)       = hs_lpat pat
+    hs_pat (ListPat pats _)    = hs_lpats pats
+    hs_pat (PArrPat pats _)    = hs_lpats pats
+    hs_pat (TuplePat pats _ _) = hs_lpats pats
+
+    hs_pat (SigPatIn pat _)  = hs_lpat pat
+    hs_pat (SigPatOut 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 _ = emptyNameSet
+    
+    details (PrefixCon ps)   = hs_lpats ps
+    details (RecCon fs)      = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
+      where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
+                                                    | (i, fld) <- [0..] `zip` rec_flds fs
+                                                    , let pat = hsRecFieldArg fld
+                                                          pat_explicit = maybe True (i<) (rec_dotdot fs)]
+    details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2
+\end{code}
+
+
+%************************************************************************
+%*									*
 	Collecting type signatures from patterns
 %*									*
 %************************************************************************
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 0b107645f3..6c57cb2aa8 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -357,7 +357,9 @@ rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
 		-- 	let x = x in 3
 		-- should report 'x' unused
 	; let real_uses = findUses dus result_fvs
-	; warnUnusedLocalBinds bound_names real_uses
+	      -- Insert fake uses for variables introduced implicitly by wildcards (#4404)
+	      implicit_uses = hsValBindsImplicits binds'
+	; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses)
 
 	; let
             -- The variables "used" in the val binds are: 
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 6d425d0822..9bb955131d 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -874,13 +874,15 @@ rnRecStmtsAndThen 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)
 	; bindLocalNamesFV bound_names $
           addLocalFixities fix_env bound_names $ do
 
 	  -- (C) do the right-hand-sides and thing-inside
 	{ segs <- rn_rec_stmts bound_names new_lhs_and_fv
 	; (res, fvs) <- cont segs 
-	; warnUnusedLocalBinds bound_names fvs
+	; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
 	; return (res, fvs) }}
 
 -- get all the fixity decls in any Let stmt