From db47e6320b585adb5100c773105c9e861eebab21 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 11 Feb 2019 09:24:04 +0000 Subject: 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 not enabled by `-Wall` currently. If people think it is appropuiate to add them then that is an easy change. --- compiler/main/DynFlags.hs | 4 + compiler/rename/RnExpr.hs | 2 +- compiler/rename/RnPat.hs | 113 ++++++++++++++++----- compiler/rename/RnUtils.hs | 15 +++ docs/users_guide/using-warnings.rst | 48 ++++++++- testsuite/tests/rename/should_compile/T15957.hs | 8 ++ testsuite/tests/rename/should_compile/all.T | 1 + testsuite/tests/rename/should_fail/T15957_Fail.hs | 11 ++ .../tests/rename/should_fail/T15957_Fail.stderr | 9 ++ testsuite/tests/rename/should_fail/all.T | 1 + 10 files changed, 185 insertions(+), 27 deletions(-) create mode 100644 testsuite/tests/rename/should_compile/T15957.hs create mode 100644 testsuite/tests/rename/should_fail/T15957_Fail.hs create mode 100644 testsuite/tests/rename/should_fail/T15957_Fail.stderr 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']) -- cgit v1.2.1