From 53449cd7237909e93051c5273be5bd587a649db2 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Thu, 3 Dec 2020 16:00:13 -0500 Subject: 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. --- compiler/GHC/Hs/Pat.hs | 46 ++++++++++++++++++++++++++++++++++++++---- compiler/GHC/Rename/Expr.hs | 35 +++++++++++++++++--------------- compiler/GHC/Tc/Gen/Match.hs | 13 ++++++------ compiler/GHC/Tc/TyCl/PatSyn.hs | 4 +++- 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 bfa773ed9f..63cd0a79ae 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -1708,10 +1708,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 @@ -1866,10 +1867,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 @@ -2156,17 +2158,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'] -- cgit v1.2.1