diff options
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/PmCheck.hs | 175 | ||||
| -rw-r--r-- | docs/users_guide/9.2.1-notes.rst | 18 | ||||
| -rw-r--r-- | docs/users_guide/using-warnings.rst | 41 | ||||
| -rw-r--r-- | testsuite/tests/pmcheck/should_compile/T17340.hs | 54 | ||||
| -rw-r--r-- | testsuite/tests/pmcheck/should_compile/T17340.stderr | 48 | ||||
| -rw-r--r-- | testsuite/tests/pmcheck/should_compile/all.T | 2 |
9 files changed, 298 insertions, 46 deletions
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 1b437c3235..a1691c1397 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -442,6 +442,7 @@ data WarningFlag = | Opt_WarnUnusedTypePatterns | Opt_WarnUnusedForalls | Opt_WarnUnusedRecordWildcards + | Opt_WarnRedundantBangPatterns | Opt_WarnRedundantRecordWildcards | Opt_WarnWarningsDeprecations | Opt_WarnDeprecatedFlags diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 45f6d4328d..fea01278ef 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3387,6 +3387,7 @@ wWarningFlagsDeps = [ flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards, + flagSpec "redundant-bang-patterns" Opt_WarnRedundantBangPatterns, flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards, flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 188f9e63fd..01e882cacd 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -885,14 +885,14 @@ BUT we have a special case when abs_sig is true; -- | Should we treat this as an unlifted bind? This will be true for any -- bind that binds an unlifted variable, but we must be careful around -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage --- information, see Note [Strict binds check] is "GHC.HsToCore.Binds". +-- information, see Note [Strict binds checks] is GHC.HsToCore.Binds. isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds isUnliftedHsBind bind | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind = if has_sig then any (is_unlifted_id . abe_poly) exports else any (is_unlifted_id . abe_mono) exports - -- If has_sig is True we wil never generate a binding for abe_mono, + -- If has_sig is True we will never generate a binding for abe_mono, -- so we don't need to worry about it being unlifted. The abe_poly -- binding might not be: e.g. forall a. Num a => (# a, a #) diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 9d5f2e5581..31ac10f0a0 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -10,6 +10,7 @@ Pattern Matching Coverage Checking. {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} module GHC.HsToCore.PmCheck ( -- Checking and printing @@ -105,8 +106,12 @@ data PmGrd } -- | @PmBang x@ corresponds to a @seq x True@ guard. + -- If the extra SrcInfo is present, the bang guard came from a source + -- bang pattern, in which case we might want to report it as redundant, + -- see Note [Dead bang patterns]. | PmBang { - pm_id :: !Id + pm_id :: !Id, + pm_loc :: !(Maybe SrcInfo) } -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually @@ -120,7 +125,7 @@ data PmGrd instance Outputable PmGrd where ppr (PmCon x alt _tvs _con_dicts con_args) = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x] - ppr (PmBang x) = char '!' <> ppr x + ppr (PmBang x _loc) = char '!' <> ppr x ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr] type GrdVec = [PmGrd] @@ -139,14 +144,15 @@ instance Monoid Precision where mempty = Precise mappend = (Semi.<>) --- | Means by which we identify a RHS for later pretty-printing in a warning --- message. 'SDoc' for the equation to show, 'Located' for the location. -type RhsInfo = Located SDoc +-- | Means by which we identify source location for later pretty-printing +-- in a warning message. 'SDoc' for the equation to show, 'Located' for +-- the location. +type SrcInfo = Located SDoc -- | A representation of the desugaring to 'PmGrd's of all clauses of a -- function definition/pattern match/etc. data GrdTree - = Rhs !RhsInfo + = Rhs !SrcInfo | Guard !PmGrd !GrdTree -- ^ @Guard grd t@ will try to match @grd@ and on success continue to match -- @t@. Falls through if either match fails. Models left-to-right semantics @@ -157,14 +163,48 @@ data GrdTree -- of pattern matching. -- @Sequence []@ always fails; it is useful for Note [Checking EmptyCase]. +{- Note [Dead bang patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f :: Bool -> Int + f True = 1 + f !x = 2 + +Whenever we fall through to the second equation, we will already have evaluated +the argument. Thus, the bang pattern serves no purpose and should be warned +about. We call this kind of bang patterns "dead". Dead bangs are the ones +that under no circumstances can force a thunk that wasn't already forced. +Dead bangs are a form of redundant bangs; see below. + +We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable +where the PmBang appears in 'checkGrdTree'. If not, then clearly the bang is +dead. Such a dead bang is then indicated in the annotated pattern-match tree by +a 'RedundantSrcBang' wrapping. In 'redundantAndInaccessibles', we collect +all dead bangs to warn about. + +Note that we don't want to warn for a dead bang that appears on a redundant +clause. That is because in that case, we recommend to delete the clause wholly, +including its leading pattern match. + +Dead bang patterns are redundant. But there are bang patterns which are +redundant that aren't dead, for example + + f !() = 0 + +the bang still forces the match variable, before we attempt to match on (). But +it is redundant with the forcing done by the () match. We currently don't +detect redundant bangs that aren't dead. +-} + -- | The digest of 'checkGrdTree', representing the annotated pattern-match --- tree. 'redundantAndInaccessibleRhss' can figure out redundant and proper --- inaccessible RHSs from this. +-- tree. 'extractRedundancyInfo' can figure out redundant and proper +-- inaccessible RHSs from this, as well as dead bangs. data AnnotatedTree - = AccessibleRhs !Deltas !RhsInfo + = AccessibleRhs !Deltas !SrcInfo -- ^ A RHS deemed accessible. The 'Deltas' is the (non-empty) set of covered -- values. - | InaccessibleRhs !RhsInfo + | InaccessibleRhs !SrcInfo -- ^ A RHS deemed inaccessible; it covers no value. | MayDiverge !AnnotatedTree -- ^ Asserts that the tree may force diverging values, so not all of its @@ -173,13 +213,15 @@ data AnnotatedTree -- ^ @SequenceAnn inc ts@ mirrors @'Sequence' ts@ for preserving the -- skeleton of a 'GrdTree's @ts@. It also carries the set of incoming values -- @inc@. + | RedundantSrcBang !SrcInfo !AnnotatedTree + -- ^ For tracking redundant bangs. See Note [Dead bang patterns] -pprRhsInfo :: RhsInfo -> SDoc -pprRhsInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss) -pprRhsInfo (L s _) = ppr s +pprSrcInfo :: SrcInfo -> SDoc +pprSrcInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss) +pprSrcInfo (L s _) = ppr s instance Outputable GrdTree where - ppr (Rhs info) = text "->" <+> pprRhsInfo info + ppr (Rhs info) = text "->" <+> pprSrcInfo info -- Format guards as "| True <- x, let x = 42, !z" ppr g@Guard{} = fsep (prefix (map ppr grds)) <+> ppr t where @@ -192,11 +234,12 @@ instance Outputable GrdTree where ppr (Sequence ts) = braces (space <> fsep (punctuate semi (map ppr ts)) <> space) instance Outputable AnnotatedTree where - ppr (AccessibleRhs _delta info) = parens (ppr _delta) <+> pprRhsInfo info - ppr (InaccessibleRhs info) = text "inaccessible" <+> pprRhsInfo info + ppr (AccessibleRhs _delta info) = parens (ppr _delta) <+> pprSrcInfo info + ppr (InaccessibleRhs info) = text "inaccessible" <+> pprSrcInfo info ppr (MayDiverge t) = text "div" <+> ppr t ppr (SequenceAnn _ []) = text "<empty case>" ppr (SequenceAnn _ ts) = braces (space <> fsep (punctuate semi (map ppr ts)) <> space) + ppr (RedundantSrcBang l t) = text "redundant bang" <+> pprSrcInfo l <+> ppr t -- | Lift 'addPmCts' over 'Deltas'. addPmCtsDeltas :: Deltas -> PmCts -> DsM Deltas @@ -336,8 +379,9 @@ extractRhsDeltas = go_matches go_match :: Deltas -> AnnotatedTree -> (Deltas, NonEmpty Deltas) -- There is no -XEmptyCase at this level, only at the Matches level. So @ts@ -- is non-empty! - go_match def (SequenceAnn pat ts) = (pat, foldMap1 (text "go_match: empty SequenceAnn") (go_grhss def) ts) - go_match def (MayDiverge t) = go_match def t + go_match def (SequenceAnn pat ts) = (pat, foldMap1 (text "go_match: empty SequenceAnn") (go_grhss def) ts) + go_match def (MayDiverge t) = go_match def t + go_match def (RedundantSrcBang _ t) = go_match def t -- Even if there's only a single GRHS, we wrap it in a SequenceAnn for the -- Deltas covered by the pattern. So the remaining cases are impossible! go_match _ t = pprPanic "extractRhsDeltas.go_match" (text "Single GRHS must be wrapped in SequenceAnn. But got " $$ ppr t) @@ -347,6 +391,7 @@ extractRhsDeltas = go_matches -- is non-empty! go_grhss def (SequenceAnn _ ts) = foldMap1 (text "go_grhss: empty SequenceAnn") (go_grhss def) ts go_grhss def (MayDiverge t) = go_grhss def t + go_grhss def (RedundantSrcBang _ t) = go_grhss def t go_grhss _ (AccessibleRhs deltas _) = deltas :| [] go_grhss def (InaccessibleRhs _) = def :| [] @@ -442,10 +487,11 @@ translatePat fam_insts x pat = case pat of VarPat _ y -> pure (mkPmLetVar (unLoc y) x) ParPat _ p -> translateLPat fam_insts x p LazyPat _ _ -> pure [] -- like a wildcard - BangPat _ p -> + BangPat _ p@(L l p') -> -- Add the bang in front of the list, because it will happen before any -- nested stuff. - (PmBang x :) <$> translateLPat fam_insts x p + (PmBang x pm_loc :) <$> translateLPat fam_insts x p + where pm_loc = Just (L l (ppr p')) -- (x@pat) ==> Translate pat with x as match var and handle impedance -- mismatch with incoming match var @@ -629,7 +675,8 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case -- 2. bang strict fields let arg_is_banged = map isBanged $ conLikeImplBangs con - bang_grds = map PmBang $ filterByList arg_is_banged arg_ids + noSrcPmBang i = PmBang {pm_id = i, pm_loc = Nothing} + bang_grds = map noSrcPmBang (filterByList arg_is_banged arg_ids) -- 3. guards from field selector patterns let arg_grds = concat arg_grdss @@ -958,8 +1005,9 @@ mayDiverge a = MayDiverge a -- 'GrdTree'. Note that 'PmCon' guards are the only way in which values -- fall through from one 'Many' branch to the next. -- * An 'AnnotatedTree' that contains divergence and inaccessibility info --- for all clauses. Will be fed to 'redundantAndInaccessibleRhss' for --- presenting redundant and proper innaccessible RHSs to the user. +-- for all clauses. Will be fed to 'extractRedundancyInfo' for +-- presenting redundant and proper innaccessible RHSs, as well as dead +-- bangs to the user. checkGrdTree' :: GrdTree -> Deltas -> DsM CheckResult -- RHS: Check that it covers something and wrap Inaccessible if not checkGrdTree' (Rhs sdoc) deltas = do @@ -976,11 +1024,21 @@ checkGrdTree' (Guard (PmLet x e) tree) deltas = do deltas' <- addPmCtDeltas deltas (PmCoreCt x e) checkGrdTree' tree deltas' -- Bang x: Diverge on x ~ ⊥, refine with x /~ ⊥ -checkGrdTree' (Guard (PmBang x) tree) deltas = do +checkGrdTree' (Guard (PmBang x src_bang_info) tree) deltas = do has_diverged <- addPmCtDeltas deltas (PmBotCt x) >>= isInhabited deltas' <- addPmCtDeltas deltas (PmNotBotCt x) res <- checkGrdTree' tree deltas' - pure res{ cr_clauses = applyWhen has_diverged mayDiverge (cr_clauses res) } + let clauses + | not has_diverged + , Just info <- src_bang_info + = RedundantSrcBang info (cr_clauses res) + | has_diverged + = mayDiverge (cr_clauses res) + | otherwise -- won't diverge and it wasn't a source bang + = cr_clauses res + + pure res{ cr_clauses = clauses } + -- Con: Diverge on x ~ ⊥, fall through on x /~ K and refine with x ~ K ys -- and type info checkGrdTree' (Guard (PmCon x con tvs dicts args) tree) deltas = do @@ -1122,25 +1180,43 @@ needToRunPmCheck dflags origin | otherwise = notNull (filter (`wopt` dflags) allPmCheckWarnings) -redundantAndInaccessibleRhss :: AnnotatedTree -> ([RhsInfo], [RhsInfo]) -redundantAndInaccessibleRhss tree = (fromOL ol_red, fromOL ol_inacc) +-- | A type for organising information to be used in warnings. +data RedundancyInfo + = RedundancyInfo + { redundant_rhss :: ![SrcInfo] + , inaccessible_rhss :: ![SrcInfo] + , redundant_bangs :: ![Located SDoc] + } + +extractRedundancyInfo :: AnnotatedTree -> RedundancyInfo +extractRedundancyInfo tree = + RedundancyInfo { redundant_rhss = fromOL ol_red + , inaccessible_rhss = fromOL ol_inacc + , redundant_bangs = fromOL ol_bangs } where - (_ol_acc, ol_inacc, ol_red) = go tree - -- | Collects RHSs which are - -- 1. accessible - -- 2. proper inaccessible (so we can't delete them) - -- 3. hypothetically redundant (so not only inaccessible RHS, but we can + (_ol_acc, ol_inacc, ol_red, ol_bangs) = go tree + -- | Collects + -- 1. accessible RHSs + -- 2. proper inaccessible RHSs (so we can't delete them) + -- 3. hypothetically redundant RHSs (so not only inaccessible, but we can -- even safely delete the equation without altering semantics) + -- 4. 'Dead' bangs from the source, collected to be warned about -- See Note [Determining inaccessible clauses] - go :: AnnotatedTree -> (OrdList RhsInfo, OrdList RhsInfo, OrdList RhsInfo) - go (AccessibleRhs _ info) = (unitOL info, nilOL, nilOL) - go (InaccessibleRhs info) = (nilOL, nilOL, unitOL info) -- presumably redundant + -- See Note [Dead bang patterns] + go :: AnnotatedTree -> (OrdList SrcInfo, OrdList SrcInfo, OrdList SrcInfo, OrdList SrcInfo) + go (AccessibleRhs _ info) = (unitOL info, nilOL, nilOL , nilOL) + go (InaccessibleRhs info) = (nilOL, nilOL, unitOL info, nilOL) -- presumably redundant go (MayDiverge t) = case go t of -- See Note [Determining inaccessible clauses] - (acc, inacc, red) - | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL) + (acc, inacc, red, bs) + | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL, bs) res -> res go (SequenceAnn _ ts) = foldMap go ts + go (RedundantSrcBang l t) = case go t of + -- See Note [Dead bang patterns] + res@(acc, inacc, _, _) + | isNilOL acc, isNilOL inacc -> res + | otherwise -> (nilOL, nilOL, nilOL, unitOL l) Semi.<> res {- Note [Determining inaccessible clauses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1169,26 +1245,31 @@ inaccessible ones, we report the first clause as inaccessible. Clearly, it is enough if we say that we only degrade if *not all* of the child clauses are redundant. As long as there is at least one clause which we announce not to be redundant, the guard prefix responsible for the 'MayDiverge' will -survive. Hence we check for that in 'redundantAndInaccessibleRhss'. +survive. Hence we check for that in 'extractRedundancyInfo'. -} -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility) dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> CheckResult -> DsM () dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result - = when (flag_i || flag_u) $ do + = when (flag_i || flag_u || flag_b) $ do unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered - let exists_r = flag_i && notNull redundant - exists_i = flag_i && notNull inaccessible + let exists_r = flag_i && notNull redundant_rhss + exists_i = flag_i && notNull inaccessible_rhss exists_u = flag_u && notNull unc_examples + exists_b = flag_b && notNull redundant_bangs approx = precision == Approximate when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_r $ forM_ redundant $ \(L l q) -> do + when exists_b $ forM_ redundant_bangs $ \(L l q) -> do + putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns) + (pprEqn q "has redundant bang")) + + when exists_r $ forM_ redundant_rhss $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant")) - when exists_i $ forM_ inaccessible $ \(L l q) -> do + when exists_i $ forM_ inaccessible_rhss $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) @@ -1199,10 +1280,12 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result { cr_clauses = clauses , cr_uncov = uncovered , cr_approx = precision } = result - (redundant, inaccessible) = redundantAndInaccessibleRhss clauses + RedundancyInfo{redundant_rhss, inaccessible_rhss, redundant_bangs} + = extractRedundancyInfo clauses flag_i = overlapping dflags kind flag_u = exhaustive dflags kind + flag_b = redundant_bang dflags flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind) maxPatterns = maxUncoveredPatterns dflags @@ -1297,6 +1380,10 @@ overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags exhaustive :: DynFlags -> HsMatchContext id -> Bool exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag +-- | Check whether unnecessary bangs should be warned about +redundant_bang :: DynFlags -> Bool +redundant_bang dflags = wopt Opt_WarnRedundantBangPatterns dflags + -- | Denotes whether an exhaustiveness check is supported, and if so, -- via which 'WarningFlag' it's controlled. -- Returns 'Nothing' if check is not supported. diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst new file mode 100644 index 0000000000..bdc0271e6f --- /dev/null +++ b/docs/users_guide/9.2.1-notes.rst @@ -0,0 +1,18 @@ +.. _release-9-2-1: + +Version 9.2.1 +============== + +Compiler +~~~~~~~~ + +- New '-Wredundant-bang-patterns' flag that enables checks for "dead" bangs. + For instance, given this program: :: + + f :: Bool -> Bool + f True = False + f !x = x + + GHC would report that the bang on ``x`` is redundant and can be removed + since the argument was already forced in the first equation. For more + details see :ghc-flag:`-Wredundant-bang-patterns` diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index afc3b18321..353c1a07ca 100644 --- a/docs/users_guide/using-warnings.rst +++ b/docs/users_guide/using-warnings.rst @@ -1627,6 +1627,47 @@ of ``-W(no-)*``. would report that the ``P{..}`` match is unused. +.. ghc-flag:: -Wredundant-bang-patterns + :shortdesc: Warn about redundant bang patterns. + :type: dynamic + :reverse: -Wno-redundant-bang-patterns + :category: + + :since: 9.2.1 + + .. index:: + single: redundant, warning, bang patterns + + Report dead bang patterns, where dead bangs are bang patterns that under no + circumstances can force a thunk that wasn't already forced. Dead bangs are a + form of redundant bangs. The new check is performed in pattern-match coverage + checker along with other checks (namely, redundant and inaccessible RHSs). + Given :: + + + f :: Bool -> Int + f True = 1 + f !x = 2 + + The bang pattern on ``!x`` is dead. By the time the ``x`` in the second equation + is reached, ``x`` will already have been forced due to the first equation + (``f True = 1``). Moreover, there is no way to reach the second equation without + going through the first one. + + Note that ``-Wredundant-bang-patterns`` will not warn about dead bangs that appear + on a redundant clause. That is because in that case, it is recommended to delete + the clause wholly, including its leading pattern match. + + Dead bang patterns are redundant. But there are bang patterns which are + redundant that aren't dead, for example: :: + + + f !() = 0 + + the bang still forces the argument, before we attempt to match on ``()``. But it is + redundant with the forcing done by the ``()`` match. Currently such redundant bangs + are not considered dead, and ``-Wredundant-bang-patterns`` will not warn about them. + .. ghc-flag:: -Wredundant-record-wildcards :shortdesc: Warn about record wildcard matches when the wildcard binds no patterns. :type: dynamic diff --git a/testsuite/tests/pmcheck/should_compile/T17340.hs b/testsuite/tests/pmcheck/should_compile/T17340.hs new file mode 100644 index 0000000000..fa2ef60812 --- /dev/null +++ b/testsuite/tests/pmcheck/should_compile/T17340.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +module T17340 where + +data A = A { a :: () } +data B = B +newtype C = C Int +pattern P = B + +f_nowarn :: Bool -> Bool +f_nowarn !x = x + +f :: Bool -> Bool +f True = False +f !x = x + +g :: (Int, Int) -> Bool -> () +g (a,b) True = () +g !x False = () + +data T = MkT !Int +h :: T -> () +h (MkT !x) = () + +k :: Bool -> Int +k True = 1 +k !_ = 2 -- clause is accessible, so warn for the bang + +t :: () -> Bool -> Int +t _ True = 1 +t !() True = 2 -- the clause has inaccessible RHS, warn for the bang +t _ False = 3 + +q :: Bool -> Int +q True = 1 +q !True = 2 -- clause is redundant, don't warn for the bang +q False = 3 + +i :: Bool -> Int +i True = 1 +i !x | x = 2 -- redundant + | not x = 3 -- accessible. This one will stay alive, so warn for the bang + +newtype T2 a = T2 a +w :: T2 a -> Bool -> () +w _ True = () +w (T2 _) True = () -- redundant +w !_ True = () -- inaccessible +w _ _ = () + +z :: T2 a -> Bool -> () +z _ True = () +z t2 !x | T2 _ <- t2, x = () -- redundant + | !_ <- t2, x = () -- inaccessable diff --git a/testsuite/tests/pmcheck/should_compile/T17340.stderr b/testsuite/tests/pmcheck/should_compile/T17340.stderr new file mode 100644 index 0000000000..c31fb2a6f5 --- /dev/null +++ b/testsuite/tests/pmcheck/should_compile/T17340.stderr @@ -0,0 +1,48 @@ + +T17340.hs:15:4: warning: [-Wredundant-bang-patterns] + Pattern match has redundant bang + In an equation for ‘f’: f x = ... + +T17340.hs:19:4: warning: [-Wredundant-bang-patterns] + Pattern match has redundant bang + In an equation for ‘g’: g x = ... + +T17340.hs:27:4: warning: [-Wredundant-bang-patterns] + Pattern match has redundant bang + In an equation for ‘k’: k _ = ... + +T17340.hs:31:1: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match has inaccessible right hand side + In an equation for ‘t’: t !() True = ... + +T17340.hs:36:1: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘q’: q !True = ... + +T17340.hs:41:4: warning: [-Wredundant-bang-patterns] + Pattern match has redundant bang + In an equation for ‘i’: i x = ... + +T17340.hs:41:8: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘i’: i !x | x = ... + +T17340.hs:47:1: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘w’: w (T2 _) True = ... + +T17340.hs:48:1: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match has inaccessible right hand side + In an equation for ‘w’: w !_ True = ... + +T17340.hs:53:7: warning: [-Wredundant-bang-patterns] + Pattern match has redundant bang + In an equation for ‘z’: z x = ... + +T17340.hs:53:11: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘z’: z t2 !x | T2 _ <- t2, x = ... + +T17340.hs:54:11: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match has inaccessible right hand side + In an equation for ‘z’: z t2 !x | !_ <- t2, x = ... diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T index 054ad82873..51fb76b078 100644 --- a/testsuite/tests/pmcheck/should_compile/all.T +++ b/testsuite/tests/pmcheck/should_compile/all.T @@ -124,6 +124,8 @@ test('T18478', collect_compiler_stats('bytes allocated',10), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) test('T18533', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) +test('T17340', normal, compile, + ['-Wredundant-bang-patterns']) # Other tests test('pmc001', [], compile, |