typecheck: Account for -XStrict in irrefutability checkwip/T19027

When -XStrict is enabled the rules for irrefutability are slightly modified.
Specifically, the pattern in a program like

    do ~(Just hi) <- expr

cannot be considered irrefutable. The ~ here merely disables the bang that
-XStrict would usually apply, rendering the program equivalent to the following
without -XStrict

    do Just hi <- expr

To achieve make this pattern irrefutable with -XStrict the user would rather
need to write

    do ~(~(Just hi)) <- expr

Failing to account for this resulted in #19027. To fix this isIrrefutableHsPat
takes care to check for two the irrefutability of the inner pattern when it
encounters a LazyPat and -XStrict is enabled.

2 files changed, 10 insertions, 7 deletions

diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index fb8d58c520..0a85147309 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -65,6 +65,7 @@ import GHC.Builtin.Types.Prim
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Misc
+import GHC.Driver.Session ( getDynFlags )
 
 import GHC.Types.Fixity (LexicalFixity(..))
 import GHC.Types.Name
@@ -947,12 +948,12 @@ tcMonadFailOp :: CtOrigin
 -- match can't fail (so the fail op is Nothing), however, it seems that the
 -- isIrrefutableHsPat test is still required here for some reason I haven't
 -- yet determined.
-tcMonadFailOp orig pat fail_op res_ty
-  | isIrrefutableHsPat pat
-  = return Nothing
-  | otherwise
-  = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
-                             (mkCheckExpType res_ty) $ \_ _ -> return ())
+tcMonadFailOp orig pat fail_op res_ty = do
+    dflags <- getDynFlags
+    if isIrrefutableHsPat dflags pat
+      then return Nothing
+      else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
+                            (mkCheckExpType res_ty) $ \_ _ -> return ())
 
 {-
 Note [Treat rebindable syntax first]
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 2fd0669f91..593226db5c 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -61,6 +61,7 @@ import GHC.Rename.Env
 import GHC.Data.Bag
 import GHC.Utils.Misc
 import GHC.Utils.Error
+import GHC.Driver.Session ( getDynFlags )
 import Data.Maybe( mapMaybe )
 import Control.Monad ( zipWithM )
 import Data.List( partition, mapAccumL )
@@ -770,6 +771,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
        ; cont         <- newSysLocalId (fsLit "cont")  Many cont_ty
        ; fail         <- newSysLocalId (fsLit "fail")  Many fail_ty
 
+       ; dflags       <- getDynFlags
        ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
@@ -782,7 +784,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
 
              args = map nlVarPat [scrutinee, cont, fail]
              lwpat = noLoc $ WildPat pat_ty
-             cases = if isIrrefutableHsPat lpat
+             cases = if isIrrefutableHsPat dflags lpat
                      then [mkHsCaseAlt lpat  cont']
                      else [mkHsCaseAlt lpat  cont',
                            mkHsCaseAlt lwpat fail']