diff options
| -rw-r--r-- | compiler/GHC/Rename/Bind.hs | 57 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/T22057.hs | 16 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/T22067.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/T22067.stderr | 6 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/all.T | 2 |
5 files changed, 76 insertions, 14 deletions
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 21789ef89a..7f3edf841c 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -493,18 +493,10 @@ rnBind _ bind@(PatBind { pat_lhs = pat bind' = bind { pat_rhs = grhss' , pat_ext = fvs' } - ok_nobind_pat - = -- See Note [Pattern bindings that bind no variables] - case unLoc pat of - WildPat {} -> True - BangPat {} -> True -- #9127, #13646 - SplicePat {} -> True - _ -> False - -- Warn if the pattern binds no variables -- See Note [Pattern bindings that bind no variables] ; whenWOptM Opt_WarnUnusedPatternBinds $ - when (null bndrs && not ok_nobind_pat) $ + when (null bndrs && not (isOkNoBindPattern pat)) $ addTcRnDiagnostic (TcRnUnusedPatternBinds bind') ; fvs' `seq` -- See Note [Free-variable space leak] @@ -540,29 +532,66 @@ rnBind sig_fn (PatSynBind x bind) rnBind _ b = pprPanic "rnBind" (ppr b) + -- See Note [Pattern bindings that bind no variables] +isOkNoBindPattern :: LPat GhcRn -> Bool +isOkNoBindPattern (L _ pat) = + case pat of + WildPat{} -> True -- Exception (1) + BangPat {} -> True -- Exception (2) #9127, #13646 + p -> patternContainsSplice p -- Exception (3) + + where + lpatternContainsSplice :: LPat GhcRn -> Bool + lpatternContainsSplice (L _ p) = patternContainsSplice p + patternContainsSplice :: Pat GhcRn -> Bool + patternContainsSplice p = + case p of + -- A top-level splice has been evaluated by this point, so we know the pattern it is evaluated to + SplicePat (HsUntypedSpliceTop _ p) _ -> patternContainsSplice p + -- A nested splice isn't evaluated so we can't guess what it will expand to + SplicePat (HsUntypedSpliceNested {}) _ -> True + -- The base cases + VarPat {} -> False + WildPat {} -> False + LitPat {} -> False + NPat {} -> False + NPlusKPat {} -> False + -- Recursive cases + BangPat _ lp -> lpatternContainsSplice lp + LazyPat _ lp -> lpatternContainsSplice lp + AsPat _ _ _ lp -> lpatternContainsSplice lp + ParPat _ _ lp _ -> lpatternContainsSplice lp + ViewPat _ _ lp -> lpatternContainsSplice lp + SigPat _ lp _ -> lpatternContainsSplice lp + ListPat _ lps -> any lpatternContainsSplice lps + TuplePat _ lps _ -> any lpatternContainsSplice lps + SumPat _ lp _ _ -> lpatternContainsSplice lp + ConPat _ _ cpd -> any lpatternContainsSplice (hsConPatArgs cpd) + XPat (HsPatExpanded _orig new) -> patternContainsSplice new + {- Note [Pattern bindings that bind no variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally, we want to warn about pattern bindings like Just _ = e because they don't do anything! But we have three exceptions: -* A wildcard pattern +(1) A wildcard pattern _ = rhs which (a) is not that different from _v = rhs (b) is sometimes used to give a type sig for, or an occurrence of, a variable on the RHS -* A strict pattern binding; that is, one with an outermost bang +(2) A strict pattern binding; that is, one with an outermost bang !Just _ = e This can fail, so unlike the lazy variant, it is not a no-op. Moreover, #13646 argues that even for single constructor types, you might want to write the constructor. See also #9127. -* A splice pattern +(3) A splice pattern $(th-lhs) = rhs It is impossible to determine whether or not th-lhs really - binds any variable. We should disable the warning for any pattern - which contain splices, but that is a more expensive check. + binds any variable. You have to recurse all the way into the pattern to check + it doesn't contain any splices like this. See #22057. Note [Free-variable space leak] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/testsuite/tests/rename/should_compile/T22057.hs b/testsuite/tests/rename/should_compile/T22057.hs new file mode 100644 index 0000000000..fa88f48499 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T22057.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# OPTIONS -Wall #-} +module Thing (thing) where + +import Language.Haskell.TH + +thing :: Q () +thing = do + name <- newName "x" + -- warning: + _ <- [| let ($(pure (VarP name)), _) = (3.0, 4.0) in $(pure (VarE name)) |] + -- warning: + _ <- [| let ($(pure (VarP name)) ) = 3.0 in $(pure (VarE name)) |] + -- no warning: + _ <- [| let $(pure (VarP name)) = 3.0 in $(pure (VarE name)) |] + return () diff --git a/testsuite/tests/rename/should_compile/T22067.hs b/testsuite/tests/rename/should_compile/T22067.hs new file mode 100644 index 0000000000..b171551752 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T22067.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +module TTT where + +a :: () +a = let () = () in () + +b :: () +b = let $([p|()|]) = () in () + diff --git a/testsuite/tests/rename/should_compile/T22067.stderr b/testsuite/tests/rename/should_compile/T22067.stderr new file mode 100644 index 0000000000..aaa6e232a1 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T22067.stderr @@ -0,0 +1,6 @@ + +T22067.hs:5:9: warning: [GHC-61367] [-Wunused-pattern-binds (in -Wextra, -Wunused-binds)] + This pattern-binding binds no variables: () = () + +T22067.hs:8:9: warning: [GHC-61367] [-Wunused-pattern-binds (in -Wextra, -Wunused-binds)] + This pattern-binding binds no variables: (()) = () diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index 1c02db6e6e..9e7d49fa51 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -188,3 +188,5 @@ test('T18862', normal, compile, ['']) test('unused_haddock', normal, compile, ['-haddock -Wall']) test('T19984', normal, compile, ['-fwarn-unticked-promoted-constructors']) test('T21654', normal, compile, ['-Wunused-top-binds']) +test('T22057', normal, compile, ['-Wall']) +test('T22067', normal, compile, ['-Wall']) |