Fix long distance info for record updateswip/T17783

For record updates where the `record_expr` is a variable, as in #17783:

```hs
data PartialRec = No
                | Yes { a :: Int, b :: Bool }
update No = No
update r@(Yes {}) = r { b = False }
```

We should make use of long distance info in
`-Wincomplete-record-updates` checking. But the call to `matchWrapper`
in the `RecUpd` case didn't specify a scrutinee expression, which would
correspond to the `record_expr` `r` here. That is fixed now.

Fixes #17783.

4 files changed, 49 insertions, 6 deletions

diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index a7845de8bd..934967f055 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -1159,7 +1159,7 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result
   = when (flag_i || flag_u) $ do
       unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered
       let exists_r = flag_i && notNull redundant
-          exists_i = flag_i && notNull inaccessible && not is_rec_upd
+          exists_i = flag_i && notNull inaccessible
           exists_u = flag_u && notNull unc_examples
           approx   = precision == Approximate
 
@@ -1182,13 +1182,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result
       , cr_approx  = precision } = result
     (redundant, inaccessible) = redundantAndInaccessibleRhss clauses
 
-    flag_i = wopt Opt_WarnOverlappingPatterns dflags
+    flag_i = overlapping dflags kind
     flag_u = exhaustive dflags kind
     flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
 
-    is_rec_upd = case kind of { RecUpd -> True; _ -> False }
-       -- See Note [Inaccessible warnings for record updates]
-
     maxPatterns = maxUncoveredPatterns dflags
 
     -- Print a single clause (for redundant/with-inaccessible-rhs)
@@ -1244,6 +1241,17 @@ it's impossible:
 
 We don't want to warn about the inaccessible branch because the programmer
 didn't put it there!  So we filter out the warning here.
+
+The same can happen for long distance term constraints instead of type
+constraints (#17783):
+
+  data T = A { x :: Int } | B { x :: Int }
+  f r@A{} = r { x = 3 }
+  f _     = B 0
+
+Here, the long distance info from the FunRhs match (@r ~ A x@) will make the
+clause matching on @B@ of the desugaring to @case@ redundant. It's generated
+code that we don't want to warn about.
 -}
 
 dots :: Int -> [a] -> SDoc
@@ -1260,6 +1268,12 @@ allPmCheckWarnings =
   , Opt_WarnOverlappingPatterns
   ]
 
+-- | Check whether the redundancy checker should run (redundancy only)
+overlapping :: DynFlags -> HsMatchContext id -> Bool
+-- See Note [Inaccessible warnings for record updates]
+overlapping _      RecUpd = False
+overlapping dflags _      = wopt Opt_WarnOverlappingPatterns dflags
+
 -- | Check whether the exhaustiveness checker should run (exhaustiveness only)
 exhaustive :: DynFlags -> HsMatchContext id -> Bool
 exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 0f1386d76d..45d208b3db 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -601,7 +601,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
         -- constructor arguments.
         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
         ; ([discrim_var], matching_code)
-                <- matchWrapper RecUpd Nothing
+                <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]
                                       (MG { mg_alts = noLoc alts
                                           , mg_ext = MatchGroupTc [in_ty] out_ty
                                           , mg_origin = FromSource })
@@ -707,6 +707,24 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                                          , pat_wrap = req_wrap }
            ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
 
+{- Note [Scrutinee in Record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider #17783:
+
+  data PartialRec = No
+                  | Yes { a :: Int, b :: Bool }
+  update No = No
+  update r@(Yes {}) = r { b = False }
+
+In the context of pattern-match checking, the occurrence of @r@ in
+@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by
+the following desugaring:
+
+  r { b = False } ==> case r of Yes a b -> Yes a False
+
+Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
+-}
+
 -- Here is where we desugar the Template Haskell brackets and escapes
 
 -- Template Haskell stuff
diff --git a/testsuite/tests/pmcheck/should_compile/T17783.hs b/testsuite/tests/pmcheck/should_compile/T17783.hs
new file mode 100644
index 0000000000..8ac9246000
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17783.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -Wincomplete-record-updates #-}
+
+module Bug where
+
+data PartialRec = No
+                | Yes { a :: Int, b :: Bool }
+
+update No = No
+update r@(Yes {}) = r { b = False }
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 9d37f36fe5..dcb9ca4081 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -112,6 +112,8 @@ test('T17646', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T17703', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17783', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 
 # Other tests
 test('pmc001', [], compile,