From 41dc5190d5ffec988834fa055f407157c1e1022b Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Sat, 2 Apr 2011 16:52:33 +0100 Subject: [PATCH] Ignore names introduced "implicitly" in unused-variable warnings (Fix #4404) 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. --- compiler/hsSyn/HsUtils.lhs | 83 ++++++++++++++++++++++++++++++++++++++++++- compiler/rename/RnBinds.lhs | 4 ++- compiler/rename/RnExpr.lhs | 4 ++- 3 files changed, 88 insertions(+), 3 deletions(-) diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index bf75f4c..13f3cd7 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 0b10764..6c57cb2 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 6d425d0..9bb9551 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 -- 1.7.10.4