-Wunused-pattern-binds: Recurse into patterns to check whether there's a splice

See the examples in #22057 which show we have to traverse deeply into a
pattern to determine whether it contains a splice or not. The original
implementation pointed this out but deemed this very shallow traversal
"too expensive".

Fixes #22057

I also fixed an oversight in !7821 which meant we lost a warning which
was present in 9.2.2.

Fixes #22067

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'])