Commit e8e9f6a7 authored by Tao He's avatar Tao He Committed by Ben Gamari

Improve exhaustive checking for guards in pattern bindings and MultiIf.

Previously we didn't do exhaustive checking on MultiIf expressions
and guards in pattern bindings.

We can construct the `LMatch` directly from GRHSs or [LHsExpr]
(MultiIf's alts) then feed it to checkMatches, without construct the
MatchGroup and using function `matchWrapper`.
Signed-off-by: Tao He's avatarHE, Tao <sighingnow@gmail.com>

Test Plan: make test TEST="T14773a T14773b"

Reviewers: bgamari, RyanGlScott, simonpj

Reviewed By: bgamari, simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14773

Differential Revision: https://phabricator.haskell.org/D4400
parent 8c7a1551
......@@ -9,7 +9,7 @@ Pattern Matching Coverage Checking.
module Check (
-- Checking and printing
checkSingle, checkMatches, isAnyPmCheckEnabled,
checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,
-- See Note [Type and Term Equality Propagation]
genCaseTmCs1, genCaseTmCs2,
......@@ -52,7 +52,7 @@ import TyCoRep
import Type
import UniqSupply
import DsGRHSs (isTrueLHsExpr)
import Maybes ( expectJust )
import Maybes (expectJust)
import Data.List (find)
import Data.Maybe (isJust, fromMaybe)
......@@ -342,6 +342,21 @@ checkSingle' locn var p = do
(NotCovered, Diverged ) -> PmResult prov [] us' m -- inaccessible rhs
where m = [L locn [L locn p]]
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions.
checkGuardMatches :: HsMatchContext Name -- Match context
-> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
-> DsM ()
checkGuardMatches hs_ctx guards@(GRHSs grhss _) = do
dflags <- getDynFlags
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc
match = L combinedLoc $
Match { m_ctxt = hs_ctx
, m_pats = []
, m_grhss = guards }
checkMatches dflags dsMatchContext [] [match]
-- | Check a matchgroup (case, functions, etc.)
checkMatches :: DynFlags -> DsMatchContext
-> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()
......@@ -368,7 +383,7 @@ checkMatches' vars matches
| otherwise = do
liftD resetPmIterDs -- set the iter-no to zero
missing <- mkInitialUncovered vars
tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))
(prov, rs,us,ds) <- go matches missing
return $ PmResult {
pmresultProvenance = prov
......@@ -1893,9 +1908,10 @@ exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag IfAlt = Nothing
exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
exhaustiveWarningFlag ThPatSplice = Nothing
......
......@@ -27,6 +27,7 @@ import {-# SOURCE #-} Match( matchWrapper )
import DsMonad
import DsGRHSs
import DsUtils
import Check ( checkGuardMatches )
import HsSyn -- lots of things
import CoreSyn -- lots of things
......@@ -165,6 +166,7 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_rhs_ty = ty
, pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
; checkGuardMatches PatBindGuards grhss
; let body' = mkOptTickBox rhs_tick body_expr
pat' = decideBangHood dflags pat
; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
......
......@@ -24,6 +24,7 @@ import DsListComp
import DsUtils
import DsArrows
import DsMonad
import Check ( checkGuardMatches )
import Name
import NameEnv
import FamInstEnv( topNormaliseType )
......@@ -203,6 +204,7 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
= -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body
do { rhs <- dsGuarded grhss ty
; checkGuardMatches PatBindGuards grhss
; let upat = unLoc pat
eqn = EqnInfo { eqn_pats = [upat],
eqn_rhs = cantFailMatchResult body }
......@@ -437,6 +439,7 @@ ds_expr _ (HsMultiIf res_ty alts)
| otherwise
= do { match_result <- liftM (foldr1 combineMatchResults)
(mapM (dsGRHS IfAlt res_ty) alts)
; checkGuardMatches IfAlt (GRHSs alts (noLoc emptyLocalBinds))
; error_expr <- mkErrorExpr
; extractMatchResult match_result error_expr }
where
......
......@@ -33,7 +33,7 @@ import SrcLoc
import Outputable
{-
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
@dsGuarded@ is used for pattern bindings.
It desugars:
\begin{verbatim}
| g1 -> e1
......@@ -46,7 +46,6 @@ necessary. The type argument gives the type of the @ei@.
-}
dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
dsGuarded grhss rhs_ty = do
match_result <- dsGRHSs PatBindRhs grhss rhs_ty
error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
......
......@@ -1564,8 +1564,10 @@ pprMatch match
LambdaExpr -> (char '\\', m_pats match)
_ -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
(ppr pat1, []) -- No parens around the single pat
_ -> if null (m_pats match)
then (empty, [])
else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
(ppr pat1, []) -- No parens around the single pat
(pat1:pats1) = m_pats match
(pat2:pats2) = pats1
......@@ -2411,6 +2413,9 @@ data HsMatchContext id -- Not an extensible tag
| IfAlt -- ^Guards of a multi-way if alternative
| ProcExpr -- ^Patterns of a proc
| PatBindRhs -- ^A pattern binding eg [y] <- e = e
| PatBindGuards -- ^Guards of pattern bindings, e.g.,
-- (Just b) | Just _ <- x = e
-- | otherwise = e'
| RecUpd -- ^Record update [used only in DsExpr to
-- tell matchWrapper what sort of
......@@ -2432,6 +2437,7 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where
ppr IfAlt = text "IfAlt"
ppr ProcExpr = text "ProcExpr"
ppr PatBindRhs = text "PatBindRhs"
ppr PatBindGuards = text "PatBindGuards"
ppr RecUpd = text "RecUpd"
ppr (StmtCtxt _) = text "StmtCtxt _"
ppr ThPatSplice = text "ThPatSplice"
......@@ -2483,14 +2489,15 @@ isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
isMonadFailStmtContext _ = False -- ListComp, PArrComp, PatGuard, ArrowExpr
matchSeparator :: HsMatchContext id -> SDoc
matchSeparator (FunRhs {}) = text "="
matchSeparator CaseAlt = text "->"
matchSeparator IfAlt = text "->"
matchSeparator LambdaExpr = text "->"
matchSeparator ProcExpr = text "->"
matchSeparator PatBindRhs = text "="
matchSeparator (StmtCtxt _) = text "<-"
matchSeparator RecUpd = text "=" -- This can be printed by the pattern
matchSeparator (FunRhs {}) = text "="
matchSeparator CaseAlt = text "->"
matchSeparator IfAlt = text "->"
matchSeparator LambdaExpr = text "->"
matchSeparator ProcExpr = text "->"
matchSeparator PatBindRhs = text "="
matchSeparator PatBindGuards = text "="
matchSeparator (StmtCtxt _) = text "<-"
matchSeparator RecUpd = text "=" -- This can be printed by the pattern
-- match checker trace
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
......@@ -2517,6 +2524,7 @@ pprMatchContextNoun RecUpd = text "record-update construct"
pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
pprMatchContextNoun PatBindRhs = text "pattern binding"
pprMatchContextNoun PatBindGuards = text "pattern binding guards"
pprMatchContextNoun LambdaExpr = text "lambda abstraction"
pprMatchContextNoun ProcExpr = text "arrow abstraction"
pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
......@@ -2571,6 +2579,7 @@ matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding"
matchContextErrString PatBindGuards = text "pattern binding guards"
matchContextErrString RecUpd = text "record update"
matchContextErrString LambdaExpr = text "lambda"
matchContextErrString ProcExpr = text "proc"
......
......@@ -31,6 +31,22 @@ Language
The grammar is invalid in Haskell2010. Previously it could be compiled successfully
without ``GADTs``. As of GHC 8.6.1, this is a parse error.
- Incomplete patterns warning :ghc-flag:`-Wincomplete-patterns` is extended to
guards in pattern bindings and ``if`` alternatives of :extension:`MultiWayIf`.
For instance, consider the following, ::
foo :: Bool -> Int
foo b = if | b -> 1
In GHC 8.6.1, it will raise the warning: ::
<interactive>:2:12: warning: [-Wincomplete-patterns]
Pattern match(es) are non-exhaustive
In a multi-way if alternative:
Guards do not cover entire pattern space
See :ghc-ticket:`14773`.
Compiler
~~~~~~~~
......
{-# LANGUAGE MultiWayIf #-}
module T14773a where
foo :: Bool -> Int
foo b = if | b -> 1
bar :: Bool -> Int
bar b = if | b -> 1
| otherwise -> 2
T14773a.hs:6:12: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In a multi-way if alternative:
Guards do not cover entire pattern space
module T14773b where
b :: Bool
(Just b) | False = Nothing
c :: Bool
(Just c) | False = Nothing
| True = Just True
T14773b.hs:4:10: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In a pattern binding guards:
Guards do not cover entire pattern space
......@@ -100,3 +100,5 @@ test('T13290', normal, compile, [''])
test('T13257', normal, compile, [''])
test('T13870', normal, compile, [''])
test('T14135', normal, compile, [''])
test('T14773a', normal, compile, ['-Wincomplete-patterns'])
test('T14773b', normal, compile, ['-Wincomplete-patterns'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment