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.

4 files changed, 71 insertions, 27 deletions

diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 7f9cecda1b..cbd1675603 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -79,6 +79,8 @@ import GHC.Types.SrcLoc
 import GHC.Data.Bag -- collect ev vars from pats
 import GHC.Data.Maybe
 import GHC.Types.Name (Name)
+import GHC.Driver.Session
+import qualified GHC.LanguageExtensions as LangExt
 
 
 data ListPatTc
@@ -421,7 +423,8 @@ looksLazyPat (VarPat {})   = False
 looksLazyPat (WildPat {})  = False
 looksLazyPat _             = True
 
-isIrrefutableHsPat :: forall p. (OutputableBndrId p) => LPat (GhcPass p) -> Bool
+isIrrefutableHsPat :: forall p. (OutputableBndrId p)
+                   => DynFlags -> LPat (GhcPass p) -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
 --      (NB: this is not quite the same as the (silly) defn
@@ -434,8 +437,40 @@ isIrrefutableHsPat :: forall p. (OutputableBndrId p) => LPat (GhcPass p) -> Bool
 -- tuple patterns are considered irrefutable at the renamer stage.
 --
 -- But if it returns True, the pattern is definitely irrefutable
-isIrrefutableHsPat
-  = goL
+isIrrefutableHsPat dflags =
+    isIrrefutableHsPat' (xopt LangExt.Strict dflags)
+
+{-
+Note [-XStrict and irrefutability]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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.
+
+See also Note [decideBangHood] in GHC.HsToCore.Utils.
+-}
+
+isIrrefutableHsPat' :: forall p. (OutputableBndrId p)
+                    => Bool -- ^ Are we in a @-XStrict@ context?
+                            -- See Note [-XStrict and irrefutability]
+                    -> LPat (GhcPass p) -> Bool
+isIrrefutableHsPat' is_strict = goL
   where
     goL :: LPat (GhcPass p) -> Bool
     goL = go . unLoc
@@ -443,7 +478,10 @@ isIrrefutableHsPat
     go :: Pat (GhcPass p) -> Bool
     go (WildPat {})        = True
     go (VarPat {})         = True
-    go (LazyPat {})        = True
+    go (LazyPat _ p')
+      | is_strict
+      = isIrrefutableHsPat' False p'
+      | otherwise          = True
     go (BangPat _ pat)     = goL pat
     go (ParPat _ pat)      = goL pat
     go (AsPat _ _ pat)     = goL pat
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 55618978a5..aabbbb14de 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -1707,10 +1707,11 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
 
 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
    pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
+   dflags <- getDynFlags
    let (stmts', fvss) = unzip pairs
    let (need_join, tail') =
      -- See Note [ApplicativeDo and refutable patterns]
-         if any hasRefutablePattern stmts'
+         if any (hasRefutablePattern dflags) stmts'
          then (True, tail)
          else needJoin monad_names tail
 
@@ -1865,10 +1866,11 @@ of a refutable pattern, in order for the types to work out.
 
 -}
 
-hasRefutablePattern :: ApplicativeArg GhcRn -> Bool
-hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat
-                                       , is_body_stmt = False}) = not (isIrrefutableHsPat pat)
-hasRefutablePattern _ = False
+hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
+hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat
+                                              , is_body_stmt = False}) =
+                                         not (isIrrefutableHsPat dflags pat)
+hasRefutablePattern _ _ = False
 
 isLetStmt :: LStmt (GhcPass a) b -> Bool
 isLetStmt (L _ LetStmt{}) = True
@@ -2155,17 +2157,18 @@ badIpBinds what binds
 monadFailOp :: LPat GhcPs
             -> HsStmtContext GhcRn
             -> RnM (FailOperator GhcRn, FreeVars)
-monadFailOp pat ctxt
-  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
-  -- we should not need to fail.
-  | isIrrefutableHsPat pat = return (Nothing, emptyFVs)
-
-  -- For non-monadic contexts (e.g. guard patterns, list
-  -- comprehensions, etc.) we should not need to fail, or failure is handled in
-  -- a different way. See Note [Failing pattern matches in Stmts].
-  | not (isMonadStmtContext ctxt) = return (Nothing, emptyFVs)
-
-  | otherwise = getMonadFailOp ctxt
+monadFailOp pat ctxt = do
+    dflags <- getDynFlags
+        -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
+        -- we should not need to fail.
+    if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)
+
+        -- For non-monadic contexts (e.g. guard patterns, list
+        -- comprehensions, etc.) we should not need to fail, or failure is handled in
+        -- a different way. See Note [Failing pattern matches in Stmts].
+       | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs)
+
+       | otherwise -> getMonadFailOp ctxt
 
 {-
 Note [Monad fail : Rebindable syntax, overloaded strings]
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']