diff options
23 files changed, 365 insertions, 63 deletions
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 8ec39bc1f5..91be1492a8 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -374,7 +374,7 @@ data HsRecFields p arg -- A bunch of record fields -- { x = 3, y = True } -- Used for both expressions and patterns = HsRecFields { rec_flds :: [LHsRecField p arg], - rec_dotdot :: Maybe Int } -- Note [DotDot fields] + rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] deriving (Functor, Foldable, Traversable) @@ -593,7 +593,7 @@ instance (Outputable arg) => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n }) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) where dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 23cca4c737..9cd3a207ad 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -1316,26 +1316,35 @@ 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) + +Since the addition of -Wunused-record-wildcards, this function returns a pair +of [(SrcSpan, [Name])]. Each element of the list is one set of implicit +binders, the first component of the tuple is the document describes the possible +fix to the problem (by removing the ..). + +This means there is some unfortunate coupling between this function and where it +is used but it's only used for one specific purpose in one place so it seemed +easier. -} lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] - -> NameSet + -> [(SrcSpan, [Name])] lStmtsImplicits = hs_lstmts where hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] - -> NameSet - hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet + -> [(SrcSpan, [Name])] + hs_lstmts = concatMap (hs_stmt . unLoc) hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) - -> NameSet + -> [(SrcSpan, [Name])] hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat - hs_stmt (ApplicativeStmt _ args _) = unionNameSets (map do_arg args) + hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits" hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) - hs_stmt (BodyStmt {}) = emptyNameSet - hs_stmt (LastStmt {}) = emptyNameSet + hs_stmt (BodyStmt {}) = [] + hs_stmt (LastStmt {}) = [] hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts @@ -1343,28 +1352,28 @@ lStmtsImplicits = hs_lstmts hs_stmt (XStmtLR {}) = panic "lStmtsImplicits" hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds - hs_local_binds (HsIPBinds {}) = emptyNameSet - hs_local_binds (EmptyLocalBinds _) = emptyNameSet - hs_local_binds (XHsLocalBindsLR _) = emptyNameSet + hs_local_binds (HsIPBinds {}) = [] + hs_local_binds (EmptyLocalBinds _) = [] + hs_local_binds (XHsLocalBindsLR _) = [] -hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet +hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])] hsValBindsImplicits (XValBindsLR (NValBinds binds _)) - = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds + = concatMap (lhsBindsImplicits . snd) binds hsValBindsImplicits (ValBinds _ binds _) = lhsBindsImplicits binds -lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet -lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet +lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])] +lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) [] where lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat - lhs_bind _ = emptyNameSet + lhs_bind _ = [] -lPatImplicits :: LPat GhcRn -> NameSet +lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])] lPatImplicits = hs_lpat where hs_lpat lpat = hs_pat (unLoc lpat) - hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet + hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) [] hs_pat (LazyPat _ pat) = hs_lpat pat hs_pat (BangPat _ pat) = hs_lpat pat @@ -1377,16 +1386,26 @@ lPatImplicits = hs_lpat hs_pat (SigPat _ 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 (ConPatIn n ps) = details n ps + hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps + + hs_pat _ = [] - hs_pat _ = emptyNameSet + details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] + details _ (PrefixCon ps) = hs_lpats ps + details n (RecCon fs) = + [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] + ++ hs_lpats explicit_pats - details (PrefixCon ps) = hs_lpats ps - details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit) - where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat + where implicit_pats = map (hsRecFieldArg . unLoc) implicit + explicit_pats = map (hsRecFieldArg . unLoc) explicit + + + (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld | (i, fld) <- [0..] `zip` rec_flds fs - , let pat = hsRecFieldArg - (unLoc fld) - pat_explicit = maybe True (i<) (rec_dotdot fs)] - details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2 + , let pat_explicit = + maybe True ((i<) . unLoc) + (rec_dotdot fs)] + err_loc = maybe (getLoc n) getLoc (rec_dotdot fs) + + details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 858d174c17..f929d98cca 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 @@ -4046,6 +4048,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" @@ -4799,7 +4803,9 @@ minusWallOpts Opt_WarnUnusedDoBind, Opt_WarnTrustworthySafe, Opt_WarnUntickedPromotedConstructors, - Opt_WarnMissingPatternSynonymSignatures + Opt_WarnMissingPatternSynonymSignatures, + Opt_WarnUnusedRecordWildcards, + Opt_WarnRedundantRecordWildcards ] -- | Things you get with -Weverything, i.e. *all* known warnings flags diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 820144d930..da9febdcd8 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -3084,16 +3084,16 @@ qual :: { LStmt GhcPs (LHsExpr GhcPs) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) } +fbinds :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) } : fbinds1 { $1 } - | {- empty -} { ([],([], False)) } + | {- empty -} { ([],([], Nothing)) } -fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) } +fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) } : fbind ',' fbinds1 {% addAnnotation (gl $1) AnnComma (gl $2) >> return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } - | fbind { ([],([$1], False)) } - | '..' { ([mj AnnDotdot $1],([], True)) } + | fbind { ([],([$1], Nothing)) } + | '..' { ([mj AnnDotdot $1],([], Just (getLoc $1))) } fbind :: { LHsRecField GhcPs (LHsExpr GhcPs) } : qvar '=' texp {% ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 88217c27a2..91a27e93e6 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -1976,14 +1976,14 @@ checkPrecP (dL->L l (_,i)) (dL->L _ ol) mkRecConstrOrUpdate :: LHsExpr GhcPs -> SrcSpan - -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) + -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> P (HsExpr GhcPs) mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) | isRdrDataCon c = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp@(dL->L l _) _ (fs,dd) - | dd = parseErrorSDoc l (text "You cannot use `..' in a record update") +mkRecConstrOrUpdate exp _ (fs,dd) + | Just dd_loc <- dd = parseErrorSDoc dd_loc (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs @@ -1996,10 +1996,10 @@ mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds } -mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg -mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } -mk_rec_fields fs True = HsRecFields { rec_flds = fs - , rec_dotdot = Just (length fs) } +mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg +mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs + , rec_dotdot = Just (cL s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) 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) diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 1fe2c68ae0..d6b1f70e38 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -397,7 +397,7 @@ mkTrNameLit = do -- | Make Typeable bindings for the given 'TyCon'. mkTyConRepBinds :: TypeableStuff -> TypeRepTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) -mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..}) +mkTyConRepBinds stuff todo (TypeableTyCon {..}) = do -- Make a KindRep let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon) liftTc $ traceTc "mkTyConKindRepBinds" @@ -477,7 +477,7 @@ initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps mkExportedKindReps :: TypeableStuff -> [(Kind, Id)] -- ^ the kinds to generate bindings for -> KindRepM () -mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding +mkExportedKindReps stuff = mapM_ kindrep_binding where empty_scope = mkDeBruijnContext [] diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst new file mode 100644 index 0000000000..cf67246abf --- /dev/null +++ b/docs/users_guide/8.10.1-notes.rst @@ -0,0 +1,45 @@ +.. _release-8-10-1: + +Release notes for version 8.10.1 +=============================== + +The significant changes to the various parts of the compiler are listed in the +following sections. + + +Highlights +---------- + +Full details +------------ + +Language +~~~~~~~~ + +Compiler +~~~~~~~~ + +- Add new flags :ghc-flag:`-Wunused-record-wildcards` and + :ghc-flag:`-Wredundant-record-wildcards` which warn users when they have + redundant or unused uses of a record wildcard match. + +Runtime system +~~~~~~~~~~~~~~ + +Template Haskell +~~~~~~~~~~~~~~~~ + +``ghc-prim`` library +~~~~~~~~~~~~~~~~~~~~ + +``ghc`` library +~~~~~~~~~~~~~~~ + +``base`` library +~~~~~~~~~~~~~~~~ + +Build system +~~~~~~~~~~~~ + +Included libraries +------------------ diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index 03ca184531..c392ab38df 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,50 @@ 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 + :since: 8.10.1 + :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 + :since: 8.10.1 + :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/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs index 01c226dfbd..720eef575b 100644 --- a/libraries/base/GHC/IO/Handle.hs +++ b/libraries/base/GHC/IO/Handle.hs @@ -604,7 +604,7 @@ hSetBinaryMode handle bin = -- data is flushed first. hSetNewlineMode :: Handle -> NewlineMode -> IO () hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } = - withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} -> + withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{} -> do flushBuffer h_ return h_{ haInputNL=i, haOutputNL=o } @@ -705,7 +705,7 @@ dupHandleTo :: FilePath -> Maybe HandleFinalizer -> IO Handle__ dupHandleTo filepath h other_side - hto_@Handle__{haDevice=devTo,..} + hto_@Handle__{haDevice=devTo} h_@Handle__{haDevice=dev} mb_finalizer = do flushBuffer h_ case cast devTo of diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs index a3f9b9729e..e624a17b78 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -313,7 +313,7 @@ allClosures (APClosure {..}) = fun:payload allClosures (PAPClosure {..}) = fun:payload allClosures (APStackClosure {..}) = fun:payload allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs] -allClosures (ArrWordsClosure {..}) = [] +allClosures (ArrWordsClosure {}) = [] allClosures (MutArrClosure {..}) = mccPayload allClosures (MutVarClosure {..}) = [var] allClosures (MVarClosure {..}) = [queueHead,queueTail,value] diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs index d9f4443d14..09df787db3 100644 --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -265,7 +265,7 @@ runTH pipe rstate rhv ty mb_loc = do runTHQ :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a -> IO ByteString -runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do +runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate qstate <- readIORef qstateref let st = qstate { qsLocation = mb_loc, qsPipe = pipe } diff --git a/libraries/libiserv/src/Lib.hs b/libraries/libiserv/src/Lib.hs index 57e65706c3..0c478d3bf5 100644 --- a/libraries/libiserv/src/Lib.hs +++ b/libraries/libiserv/src/Lib.hs @@ -13,7 +13,7 @@ import Data.Binary type MessageHook = Msg -> IO Msg serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose hook pipe@Pipe{..} restore = loop +serv verbose hook pipe restore = loop where loop = do Msg msg <- readPipe pipe getMessage >>= hook diff --git a/testsuite/tests/rename/should_compile/T15957.hs b/testsuite/tests/rename/should_compile/T15957.hs new file mode 100644 index 0000000000..d684e57495 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T15957.hs @@ -0,0 +1,21 @@ +{-# 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 + +old P{..} | x < 5 = 10 + +-- Record wildcards in lets have different scoping rules.. they bring +-- all the identifiers into scope +do_example :: IO Int +do_example = do + let P{..} = P 1 2 + return $ x + y + +let_in_example = + let P{..} = P 1 2 + in x + 4 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..77ed3ada15 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T15957_Fail.hs @@ -0,0 +1,32 @@ +{-# 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 + +g2 P{x=a, ..} = a + 3 +g3 P{x=a, y=b, ..} = a + b +g4 P{x=0, y=0,..} = 0 +g4 _ = 0 + +-- Record wildcards in lets have different scoping rules.. they bring +-- all the identifiers into scope +do_example :: IO Int +do_example = do + let P{..} = P 1 2 + return $ 0 + +let_in_example :: Int +let_in_example = + let P{..} = P 1 2 + in 0 + +data Q = Q { a, b :: P } + +nested :: Q -> Int +nested Q { a = P{..}, .. } = (case b of (P x1 _) -> x1) + 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..54d77c189b --- /dev/null +++ b/testsuite/tests/rename/should_fail/T15957_Fail.stderr @@ -0,0 +1,36 @@ + +T15957_Fail.hs:7:6: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards] + No variables bound in the record wildcard match are used + Possible fix: omit the ‘..’ + +T15957_Fail.hs:8:9: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards] + No variables bound in the record wildcard match are used + Possible fix: omit the ‘..’ + +T15957_Fail.hs:9:12: error: [-Wredundant-record-wildcards (in -Wall), -Werror=redundant-record-wildcards] + Record wildcard does not bind any new variables + Possible fix: omit the ‘..’ + +T15957_Fail.hs:11:11: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards] + No variables bound in the record wildcard match are used + Possible fix: omit the ‘..’ + +T15957_Fail.hs:12:16: error: [-Wredundant-record-wildcards (in -Wall), -Werror=redundant-record-wildcards] + Record wildcard does not bind any new variables + Possible fix: omit the ‘..’ + +T15957_Fail.hs:13:15: error: [-Wredundant-record-wildcards (in -Wall), -Werror=redundant-record-wildcards] + Record wildcard does not bind any new variables + Possible fix: omit the ‘..’ + +T15957_Fail.hs:20:9: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards] + No variables bound in the record wildcard match are used + Possible fix: omit the ‘..’ + +T15957_Fail.hs:25:9: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards] + No variables bound in the record wildcard match are used + Possible fix: omit the ‘..’ + +T15957_Fail.hs:31:18: error: [-Wunused-record-wildcards (in -Wall), -Werror=unused-record-wildcards] + No variables bound in the record wildcard match are used + Possible fix: omit the ‘..’ diff --git a/testsuite/tests/rename/should_fail/T9437.stderr b/testsuite/tests/rename/should_fail/T9437.stderr index 8c2222ef97..2b8ec84502 100644 --- a/testsuite/tests/rename/should_fail/T9437.stderr +++ b/testsuite/tests/rename/should_fail/T9437.stderr @@ -1,2 +1,2 @@ -T9437.hs:8:12: You cannot use `..' in a record update +T9437.hs:8:18: You cannot use `..' in a record update diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index ce8c5c9a13..af382b1a0c 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 -Wall -Wno-missing-signatures']) diff --git a/testsuite/tests/typecheck/should_compile/T4404.hs b/testsuite/tests/typecheck/should_compile/T4404.hs index 1b46a158fb..36d16e031f 100644 --- a/testsuite/tests/typecheck/should_compile/T4404.hs +++ b/testsuite/tests/typecheck/should_compile/T4404.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards, RecursiveDo #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} module TT where |