PmCheck: Long-distance information for LocalBinds (#18626)wip/T18626

Now `desugarLocalBind` (formerly `desugarLet`) reasons about

  * `FunBind`s that
    * Have no pattern matches (so which aren't functions)
    * Have a singleton match group with a single GRHS
    * (which may have guards)
  * and looks through trivial post-typechecking `AbsBinds` in doing so
    to pick up the introduced renamings.

And desugars to `PmLet` LYG-style guards. Since GRHSs are no longer
denoted simply by `NonEmpty PmGRHS`, but also need to carry a `[PmGrd]`
for the `PmLet`s from `LocalBind`s, I added `PmGRHSs` to capture that.

Since we call out to the desugarer more often, I found that there were
superfluous warnings emitted when desugaring e.g. case expressions.
Thus, I made sure that we deactivate any warnings in the LYG desugaring
steps by the new wrapper function `noCheckDs`.

There's a regression test in `T18626`. Fixes #18626.

6 files changed, 138 insertions, 26 deletions

diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index d621e65c4b..6a6e8175bc 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -59,6 +59,7 @@ import GHC.HsToCore.Pmc.Ppr
 import GHC.Types.Basic (Origin(..))
 import GHC.Core (CoreExpr)
 import GHC.Driver.Session
+import GHC.Driver.Types
 import GHC.Hs
 import GHC.Types.Id
 import GHC.Types.SrcLoc
@@ -66,11 +67,12 @@ import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Types.Var (EvVar)
+import GHC.Tc.Types
 import GHC.Tc.Utils.TcType (evVarPred)
 import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
 import GHC.HsToCore.Monad
 import GHC.Data.Bag
-import GHC.Data.IOEnv (unsafeInterleaveM)
+import GHC.Data.IOEnv (updEnv, unsafeInterleaveM)
 import GHC.Data.OrdList
 import GHC.Utils.Monad (mapMaybeM)
 
@@ -95,12 +97,22 @@ getLdiNablas = do
     True  -> pure nablas
     False -> pure initNablas
 
+-- | We need to call the Hs desugarer to get the Core of a let-binding or where
+-- clause. We don't want to run the coverage checker when doing so! Efficiency
+-- is one concern, but also a lack of properly set up long-distance information
+-- might trigger warnings that we normally wouldn't emit.
+noCheckDs :: DsM a -> DsM a
+noCheckDs k = do
+  dflags <- getDynFlags
+  let dflags' = foldl' wopt_unset dflags allPmCheckWarnings
+  updEnv (\env -> env{env_top = (env_top env) {hsc_dflags = dflags'} }) k
+
 -- | Check a pattern binding (let, where) for exhaustiveness.
 pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()
 -- See Note [pmcPatBind only checks PatBindRhs]
 pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do
-  missing   <- getLdiNablas
-  pat_bind <- desugarPatBind loc var p
+  !missing <- getLdiNablas
+  pat_bind <- noCheckDs $ desugarPatBind loc var p
   tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing])
   result <- unCA (checkPatBind pat_bind) missing
   tracePm "}: " (ppr (cr_uncov result))
@@ -117,8 +129,8 @@ pmcGRHSs
 pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
   let combined_loc = foldl1 combineSrcSpans (map getLoc grhss)
       ctxt = DsMatchContext hs_ctxt combined_loc
-  matches <- desugarGRHSs combined_loc empty guards
-  missing   <- getLdiNablas
+  !missing <- getLdiNablas
+  matches  <- noCheckDs $ desugarGRHSs combined_loc empty guards
   tracePm "pmcGRHSs" (hang (vcat [ppr ctxt
                                 , text "Guards:"])
                                 2
@@ -126,7 +138,7 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
   result <- unCA (checkGRHSs matches) missing
   tracePm "}: " (ppr (cr_uncov result))
   formatReportWarnings cirbsGRHSs ctxt [] result
-  return (ldiGRHS <$> cr_ret result)
+  return (ldiGRHSs (cr_ret result))
 
 -- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each
 -- with a 'Pat' and one or more 'GRHSs':
@@ -153,7 +165,7 @@ pmcMatches ctxt vars matches = do
   -- We have to force @missing@ before printing out the trace message,
   -- otherwise we get interleaved output from the solver. This function
   -- should be strict in @missing@ anyway!
-  !missing   <- getLdiNablas
+  !missing <- getLdiNablas
   tracePm "pmcMatches {" $
           hang (vcat [ppr ctxt, ppr vars, text "Matches:"])
                2
@@ -162,13 +174,13 @@ pmcMatches ctxt vars matches = do
     Nothing -> do
       -- This must be an -XEmptyCase. See Note [Checking EmptyCase]
       let var = only vars
-      empty_case <- desugarEmptyCase var
+      empty_case <- noCheckDs $ desugarEmptyCase var
       result <- unCA (checkEmptyCase empty_case) missing
       tracePm "}: " (ppr (cr_uncov result))
       formatReportWarnings cirbsEmptyCase ctxt vars result
       return []
     Just matches -> do
-      matches <- desugarMatches vars matches
+      matches <- noCheckDs $ desugarMatches vars matches
       result <- unCA (checkMatchGroup matches) missing
       tracePm "}: " (ppr (cr_uncov result))
       formatReportWarnings cirbsMatchGroup ctxt vars result
@@ -201,7 +213,10 @@ ldiMatchGroup (PmMatchGroup matches) = ldiMatch <$> matches
 
 ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas)
 ldiMatch (PmMatch { pm_pats = red, pm_grhss = grhss }) =
-  (rs_cov red, ldiGRHS <$> grhss)
+  (rs_cov red, ldiGRHSs grhss)
+
+ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas
+ldiGRHSs (PmGRHSs { pgs_grhss = grhss }) = ldiGRHS <$> grhss
 
 ldiGRHS :: PmGRHS Post -> Nablas
 ldiGRHS (PmGRHS { pg_grds = red }) = rs_cov red
@@ -277,8 +292,8 @@ cirbsMatch PmMatch { pm_pats = red, pm_grhss = grhss } = do
        $ applyWhen (not is_covered) markAllRedundant
        $ cirb
 
-cirbsGRHSs :: NonEmpty (PmGRHS Post) -> DsM CIRB
-cirbsGRHSs grhss = Semi.sconcat <$> traverse cirbsGRHS grhss
+cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
+cirbsGRHSs (PmGRHSs { pgs_grhss = grhss }) = Semi.sconcat <$> traverse cirbsGRHS grhss
 
 cirbsGRHS :: PmGRHS Post -> DsM CIRB
 cirbsGRHS PmGRHS { pg_grds = red, pg_rhs = info } = do
diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs
index 49cf79965e..f228e4471a 100644
--- a/compiler/GHC/HsToCore/Pmc/Check.hs
+++ b/compiler/GHC/HsToCore/Pmc/Check.hs
@@ -167,8 +167,9 @@ checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)
 checkMatch (PmMatch { pm_pats = GrdVec grds, pm_grhss = grhss }) =
   leftToRight PmMatch (checkGrds grds) (checkGRHSs grhss)
 
-checkGRHSs :: NonEmpty (PmGRHS Pre) -> CheckAction (NonEmpty (PmGRHS Post))
-checkGRHSs = checkSequence checkGRHS
+checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)
+checkGRHSs (PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss }) =
+  leftToRight PmGRHSs (checkGrds lcls) (checkSequence checkGRHS grhss)
 
 checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)
 checkGRHS (PmGRHS { pg_grds = GrdVec grds, pg_rhs = rhs_info }) =
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 07b0095dd2..fa87eae8f0 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -26,6 +26,7 @@ import GHC.HsToCore.Pmc.Types
 import GHC.HsToCore.Pmc.Utils
 import GHC.Core (Expr(Var,App))
 import GHC.Data.FastString (unpackFS, lengthFS)
+import GHC.Data.Bag (bagToList)
 import GHC.Driver.Session
 import GHC.Hs
 import GHC.Tc.Utils.Zonk (shortCutLit)
@@ -36,6 +37,7 @@ import GHC.Builtin.Types
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
+import GHC.Utils.Misc
 import GHC.Core.DataCon
 import GHC.Types.Var (EvVar)
 import GHC.Core.Coercion
@@ -326,12 +328,14 @@ desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do
   -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])
   return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }
 
-desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty (PmGRHS Pre))
-desugarGRHSs match_loc pp_pats grhss
-  = traverse (desugarLGRHS match_loc pp_pats)
-  . expectJust "desugarGRHSs"
-  . NE.nonEmpty
-  $ grhssGRHSs grhss
+desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
+desugarGRHSs match_loc pp_pats grhss = do
+  lcls <- desugarLocalBinds (grhssLocalBinds grhss)
+  grhss' <- traverse (desugarLGRHS match_loc pp_pats)
+              . expectJust "desugarGRHSs"
+              . NE.nonEmpty
+              $ grhssGRHSs grhss
+  return PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss' }
 
 -- | Desugar a guarded right-hand side to a single 'GrdTree'
 desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)
@@ -351,7 +355,7 @@ desugarLGRHS match_loc pp_pats (L _loc (GRHS _ gs _)) = do
 desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd]
 desugarGuard guard = case guard of
   BodyStmt _   e _ _ -> desugarBoolGuard e
-  LetStmt  _   binds -> desugarLet (unLoc binds)
+  LetStmt  _   binds -> desugarLocalBinds binds
   BindStmt _ p e     -> desugarBind p e
   LastStmt        {} -> panic "desugarGuard LastStmt"
   ParStmt         {} -> panic "desugarGuard ParStmt"
@@ -359,9 +363,39 @@ desugarGuard guard = case guard of
   RecStmt         {} -> panic "desugarGuard RecStmt"
   ApplicativeStmt {} -> panic "desugarGuard ApplicativeLastStmt"
 
--- | Desugar let-bindings
-desugarLet :: HsLocalBinds GhcTc -> DsM [PmGrd]
-desugarLet _binds = return []
+-- | Desugar local bindings to a bunch of 'PmLet' guards.
+-- Deals only with simple @let@ or @where@ bindings without any polymorphism,
+-- recursion, pattern bindings etc.
+-- See Note [Long-distance information for HsLocalBinds].
+desugarLocalBinds :: LHsLocalBinds GhcTc -> DsM [PmGrd]
+desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = do
+  concatMapM (concatMapM go . bagToList) (map snd binds)
+  where
+    go :: LHsBind GhcTc -> DsM [PmGrd]
+    go (L _ FunBind{fun_id = L _ x, fun_matches = mg})
+      -- See Note [Long-distance information for HsLocalBinds] for why this
+      -- pattern match is so very specific.
+      | L _ [L _ Match{m_pats = [], m_grhss = grhss}] <- mg_alts mg
+      , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do
+          core_rhs <- dsLExpr rhs
+          return [PmLet x core_rhs]
+    go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = []
+                    , abs_exports=exports, abs_binds = binds }) = do
+      -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry
+      -- renamings. See Note [Long-distance information for HsLocalBinds]
+      -- for the details.
+      let go_export :: ABExport GhcTc -> Maybe PmGrd
+          go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}
+            | isIdHsWrapper wrap
+            = ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y))
+              Just $ PmLet x (Var y)
+            | otherwise
+            = Nothing
+      let exps = mapMaybe go_export exports
+      bs <- concatMapM go (bagToList binds)
+      return (exps ++ bs)
+    go _ = return []
+desugarLocalBinds _binds = return []
 
 -- | Desugar a pattern guard
 --   @pat <- e ==>  let x = e;  <guards for pat <- x>@
@@ -447,4 +481,43 @@ a lot of false warnings.
 
 But we can check whether the coercion is a hole or if it is just refl, in
 which case we can drop it.
+
+Note [Long-distance information for HsLocalBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#18626)
+
+  f :: Int -> ()
+  f x | y = ()
+    where
+      y = True
+
+  x :: ()
+  x | let y = True, y = ()
+
+Both definitions are exhaustive, but to make the necessary long-distance
+connection from @y@'s binding to its use site in a guard, we have to collect
+'PmLet' guards for the 'HsLocalBinds' which contain @y@'s definitions.
+
+In principle, we are only interested in desugaring local binds that are
+'FunBind's, that
+
+  * Have no pattern matches. If @y@ above had any patterns, it would be a
+    function and we can't reason about them anyway.
+  * Have singleton match group with a single GRHS.
+    Otherwise, what expression to pick in the generated guard @let y = <rhs>@?
+
+It turns out that desugaring type-checked local binds in this way is a bit
+more complex than expected: Apparently, all bindings are wrapped in 'AbsBinds'
+Nfter type-checking. See Note [AbsBinds] in "GHC.Hs.Binds".
+
+We make sure that there is no polymorphism in the way by checking that there
+are no 'abs_tvs' or 'abs_ev_vars' (we don't reason about
+@y :: forall a. Eq a => ...@) and that the exports carry no 'HsWrapper's. In
+this case, the exports are a simple renaming substitution that we can capture
+with 'PmLet'. Ultimately we'll hit those renamed 'FunBind's, though, which is
+the whole point.
+
+The place to store the 'PmLet' guards for @where@ clauses (which are per
+'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of
+@x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'.
 -}
diff --git a/compiler/GHC/HsToCore/Pmc/Types.hs b/compiler/GHC/HsToCore/Pmc/Types.hs
index 793485ae39..99aeaff85e 100644
--- a/compiler/GHC/HsToCore/Pmc/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Types.hs
@@ -22,7 +22,7 @@ module GHC.HsToCore.Pmc.Types (
         SrcInfo(..), PmGrd(..), GrdVec(..),
 
         -- ** Guard tree language
-        PmMatchGroup(..), PmMatch(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),
+        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),
 
         -- * Coverage Checking types
         RedSets (..), Precision (..), CheckResult (..),
@@ -112,7 +112,13 @@ newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p))
 
 -- | A guard tree denoting 'Match': A payload describing the pats and a bunch of
 -- GRHS.
-data PmMatch p = PmMatch { pm_pats :: !p, pm_grhss :: !(NonEmpty (PmGRHS p)) }
+data PmMatch p = PmMatch { pm_pats :: !p, pm_grhss :: !(PmGRHSs p) }
+
+-- | A guard tree denoting 'GRHSs': A bunch of 'PmLet' guards for local
+-- bindings from the 'GRHSs's @where@ clauses and the actual list of 'GRHS'.
+-- See Note [Long-distance information for HsLocalBinds] in
+-- "GHC.HsToCore.Pmc.Desugar".
+data PmGRHSs p = PmGRHSs { pgs_lcls :: !p, pgs_grhss :: !(NonEmpty (PmGRHS p))}
 
 -- | A guard tree denoting 'GRHS': A payload describing the grds and a 'SrcInfo'
 -- useful for printing out in warnings messages.
@@ -149,6 +155,10 @@ instance Outputable p => Outputable (PmMatch p) where
   ppr (PmMatch { pm_pats = grds, pm_grhss = grhss }) =
     ppr grds <+> ppr grhss
 
+instance Outputable p => Outputable (PmGRHSs p) where
+  ppr (PmGRHSs { pgs_lcls = _lcls, pgs_grhss = grhss }) =
+    ppr grhss
+
 instance Outputable p => Outputable (PmGRHS p) where
   ppr (PmGRHS { pg_grds = grds, pg_rhs = rhs }) =
     ppr grds <+> text "->" <+> ppr rhs
diff --git a/testsuite/tests/pmcheck/should_compile/T18626.hs b/testsuite/tests/pmcheck/should_compile/T18626.hs
new file mode 100644
index 0000000000..c0e70de5ad
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18626.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+
+module Lib where
+
+x :: ()
+x | let y = True, y = ()
+
+f :: Int -> ()
+f _ | y = ()
+  where
+    y = True
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index ff56bdf0ba..e7f3667ea7 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -148,6 +148,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('T18626', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T18572', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-overlapping-patterns'])
 test('T18609', normal, compile,