typecheck: Account for -XStrict in irrefutability check

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.

1 files changed, 7 insertions, 6 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]