summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2020-12-03 16:00:13 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-01-29 04:01:52 -0500
commit7105cda81c525afc62df5e798813350729b1db9b (patch)
tree66388aa4c7658928f3bf75da88d66cc518be826a
parent0249974e7622e35927060da21f9231cb1e6357b9 (diff)
downloadhaskell-7105cda81c525afc62df5e798813350729b1db9b.tar.gz
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.
-rw-r--r--compiler/GHC/Hs/Pat.hs46
-rw-r--r--compiler/GHC/Rename/Expr.hs35
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs13
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs4
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']