summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.hs10
-rw-r--r--compiler/rename/RnExpr.hs8
-rw-r--r--compiler/rename/RnPat.hs32
-rw-r--r--compiler/rename/RnUtils.hs66
4 files changed, 106 insertions, 10 deletions
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)
View Lorry Controller Status