Fix #15385 by using addDictsDs in matchGuards

Summary:
When coverage checking pattern-matches, we rely on the call
sites in the desugarer to populate the local dictionaries and term
evidence in scope using `addDictsDs` and `addTmCsDs`. But it turns
out that only the call site for desugaring `case` expressions was
actually doing this properly. In another part of the desugarer,
`matchGuards` (which handles pattern guards), it did not update the
local dictionaries in scope at all, leading to #15385.

Fixing this is relatively straightforward: just augment the
`BindStmt` case of `matchGuards` to use `addDictsDs` and `addTmCsDs`.
Accomplishing this took a little bit of import/export tweaking:

* We now need to export `collectEvVarsPat` from `HsPat.hs`.
* To avoid an import cycle with `Check.hs`, I moved `isTrueLHsExpr`
  from `DsGRHSs.hs` to `DsUtils.hs`, which resides lower on the
  import chain.

Test Plan: make test TEST=T15385

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15385

Differential Revision: https://phabricator.haskell.org/D4968

5 files changed, 49 insertions, 40 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 201ed12571..8acb38b8d4 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -51,7 +51,7 @@ import Var           (EvVar)
 import TyCoRep
 import Type
 import UniqSupply
-import DsGRHSs       (isTrueLHsExpr)
+import DsUtils       (isTrueLHsExpr)
 import Maybes        (expectJust)
 import qualified GHC.LanguageExtensions as LangExt
 
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index 0fe4828dc3..00658539d3 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -15,18 +15,17 @@ module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
 import GhcPrelude
 
 import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
-import {-# SOURCE #-} Match   ( matchSinglePat )
+import {-# SOURCE #-} Match   ( matchSinglePatVar )
 
 import HsSyn
 import MkCore
 import CoreSyn
+import CoreUtils (bindNonRec)
 
+import Check (genCaseTmCs2)
 import DsMonad
 import DsUtils
-import TysWiredIn
-import PrelNames
 import Type   ( Type )
-import Module
 import Name
 import Util
 import SrcLoc
@@ -118,9 +117,18 @@ matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
         --         body expression in hand
 
 matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
-    match_result <- matchGuards stmts ctx rhs rhs_ty
+    let upat = unLoc pat
+        dicts = collectEvVarsPat upat
+    match_var <- selectMatchVar upat
+    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
+    match_result <- addDictsDs dicts $
+                    addTmCsDs tm_cs  $
+                      -- See Note [Type and Term Equality Propagation] in Check
+                    matchGuards stmts ctx rhs rhs_ty
     core_rhs <- dsLExpr bind_rhs
-    matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result
+    match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
+                                       match_result
+    pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
 
 matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"
 matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"
@@ -131,35 +139,6 @@ matchGuards (ApplicativeStmt {} : _) _ _ _ =
 matchGuards (XStmtLR {} : _) _ _ _ =
   panic "matchGuards XStmtLR"
 
-isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-
--- Returns Just {..} if we're sure that the expression is True
--- I.e.   * 'True' datacon
---        * 'otherwise' Id
---        * Trivial wappings of these
--- The arguments to Just are any HsTicks that we have found,
--- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar _ (L _ v))) |  v `hasKey` otherwiseIdKey
-                                      || v `hasKey` getUnique trueDataConId
-                                              = Just return
-        -- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut _ con))
-  | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick _ tickish e))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do wrapped <- ticks x
-                     return (Tick tickish wrapped))
-   -- This encodes that the result is constant True for Hpc tick purposes;
-   -- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do e <- ticks x
-                     this_mod <- getModule
-                     return (Tick (HpcTick this_mod ixT) e))
-
-isTrueLHsExpr (L _ (HsPar _ e))         = isTrueLHsExpr e
-isTrueLHsExpr _                       = Nothing
-
 {-
 Should {\em fail} if @e@ returns @D@
 \begin{verbatim}
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index f74be0b092..897e9eba37 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -37,7 +37,8 @@ module DsUtils (
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
+        isTrueLHsExpr
     ) where
 
 #include "HsVersions.h"
@@ -966,3 +967,32 @@ addBang = go
                                   -- Should we bring the extension value over?
            BangPat _ _   -> lp
            _             -> L l (BangPat noExt lp)
+
+isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
+
+-- Returns Just {..} if we're sure that the expression is True
+-- I.e.   * 'True' datacon
+--        * 'otherwise' Id
+--        * Trivial wappings of these
+-- The arguments to Just are any HsTicks that we have found,
+-- because we still want to tick then, even it they are always evaluated.
+isTrueLHsExpr (L _ (HsVar _ (L _ v))) |  v `hasKey` otherwiseIdKey
+                                      || v `hasKey` getUnique trueDataConId
+                                              = Just return
+        -- trueDataConId doesn't have the same unique as trueDataCon
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
+  | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (L _ (HsTick _ tickish e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do wrapped <- ticks x
+                     return (Tick tickish wrapped))
+   -- This encodes that the result is constant True for Hpc tick purposes;
+   -- which is specifically what isTrueLHsExpr is trying to find out.
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do e <- ticks x
+                     this_mod <- getModule
+                     return (Tick (HpcTick this_mod ixT) e))
+
+isTrueLHsExpr (L _ (HsPar _ e))         = isTrueLHsExpr e
+isTrueLHsExpr _                       = Nothing
diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot
index bd23e1a795..e77ad548b6 100644
--- a/compiler/deSugar/Match.hs-boot
+++ b/compiler/deSugar/Match.hs-boot
@@ -28,8 +28,8 @@ matchSimply
         -> CoreExpr
         -> DsM CoreExpr
 
-matchSinglePat
-        :: CoreExpr
+matchSinglePatVar
+        :: Id
         -> HsMatchContext Name
         -> LPat GhcTc
         -> Type
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index faefb84203..6f65487411 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -34,7 +34,7 @@ module HsPat (
         patNeedsParens, parenthesizePat,
         isIrrefutableHsPat,
 
-        collectEvVarsPats,
+        collectEvVarsPat, collectEvVarsPats,
 
         pprParendLPat, pprConArgs
     ) where