Commit 1a3f1eeb authored by Matthew Pickering's avatar Matthew Pickering

COMPLETE pragmas for enhanced pattern exhaustiveness checking

This patch adds a new pragma so that users can specify `COMPLETE` sets of
`ConLike`s in order to sate the pattern match checker.

A function which matches on all the patterns in a complete grouping
will not cause the exhaustiveness checker to emit warnings.

```
pattern P :: ()
pattern P = ()

{-# COMPLETE P #-}

foo P = ()
```

This example would previously have caused the checker to warn that
all cases were not matched even though matching on `P` is sufficient to
make `foo` covering. With the addition of the pragma, the compiler
will recognise that matching on `P` alone is enough and not emit
any warnings.

Reviewers: goldfire, gkaracha, alanz, austin, bgamari

Reviewed By: alanz

Subscribers: lelf, nomeata, gkaracha, thomie

Differential Revision: https://phabricator.haskell.org/D2669

GHC Trac Issues: #8779
parent 078c2114
......@@ -21,6 +21,7 @@ module ConLike (
, conLikeResTy
, conLikeFieldType
, conLikesWithFields
, conLikeIsInfix
) where
#include "HsVersions.h"
......@@ -185,3 +186,7 @@ conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields con_likes lbls = filter has_flds con_likes
where has_flds dc = all (has_fld dc) lbls
has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps
......@@ -5,6 +5,7 @@ Pattern Matching Coverage Checking.
-}
{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
{-# LANGUAGE TupleSections #-}
module Check (
-- Checking and printing
......@@ -23,7 +24,6 @@ import HsSyn
import TcHsSyn
import Id
import ConLike
import DataCon
import Name
import FamInstEnv
import TysWiredIn
......@@ -32,6 +32,8 @@ import SrcLoc
import Util
import Outputable
import FastString
import DataCon
import HscTypes (CompleteMatch(..))
import DsMonad
import TcSimplify (tcCheckSatisfiability)
......@@ -49,8 +51,9 @@ import Control.Monad (forM, when, forM_)
import Coercion
import TcEvidence
import IOEnv
import Data.Monoid ( Monoid(mappend) )
import ListT (ListT(..), fold)
import ListT (ListT(..), fold, select)
{-
This module checks pattern matches for:
......@@ -87,12 +90,39 @@ type PmM a = ListT DsM a
liftD :: DsM a -> PmM a
liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk
myRunListT :: PmM a -> DsM [a]
myRunListT pm = fold pm go (return [])
-- Pick the first match complete covered match or otherwise the "best" match.
-- The best match is the one with the least uncovered clauses, ties broken
-- by the number of inaccessible clauses followed by number of redudant
-- clauses
getResult :: PmM PmResult -> DsM PmResult
getResult ls = do
res <- fold ls goM (pure Nothing)
case res of
Nothing -> panic "getResult is empty"
Just a -> return a
where
go a mas =
mas >>= \as -> return (a:as)
goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)
goM mpm dpm = do
pmr <- dpm
return $ go pmr mpm
-- Careful not to force unecessary results
go :: Maybe PmResult -> PmResult -> Maybe PmResult
go Nothing rs = Just rs
go old@(Just (PmResult prov rs us is)) new
| null us && null rs && null is = old
| otherwise =
let PmResult prov' rs' us' is' = new
lr = length rs
lr' = length rs'
li = length is
li' = length is'
in case compare (length us) (length us')
`mappend` (compare li li')
`mappend` (compare lr lr')
`mappend` (compare prov prov') of
GT -> Just new
EQ -> Just new
LT -> old
data PatTy = PAT | VA -- Used only as a kind, to index PmPat
......@@ -100,7 +130,7 @@ data PatTy = PAT | VA -- Used only as a kind, to index PmPat
-- the number of p1..pn that are not Guards
data PmPat :: PatTy -> * where
PmCon :: { pm_con_con :: DataCon
PmCon :: { pm_con_con :: ConLike
, pm_con_arg_tys :: [Type]
, pm_con_tvs :: [TyVar]
, pm_con_dicts :: [EvVar]
......@@ -171,20 +201,42 @@ instance Monoid Diverged where
_ `mappend` Diverged = Diverged
NotDiverged `mappend` NotDiverged = NotDiverged
-- | When we learned that a given match group is complete
data Provenance =
FromBuiltin -- ^ From the original definition of the type
-- constructor.
| FromComplete -- ^ From a user-provided @COMPLETE@ pragma
deriving (Show, Eq, Ord)
instance Outputable Provenance where
ppr = text . show
instance Monoid Provenance where
mempty = FromBuiltin
FromComplete `mappend` _ = FromComplete
_ `mappend` FromComplete = FromComplete
_ `mappend` _ = FromBuiltin
data PartialResult = PartialResult {
presultCovered :: Covered
presultProvenence :: Provenance
-- keep track of provenance because we don't want
-- to warn about redundant matches if the result
-- is contaiminated with a COMPLETE pragma
, presultCovered :: Covered
, presultUncovered :: Uncovered
, presultDivergent :: Diverged }
instance Outputable PartialResult where
ppr (PartialResult c vsa d) = text "PartialResult" <+> ppr c
ppr (PartialResult prov c vsa d)
= text "PartialResult" <+> ppr prov <+> ppr c
<+> ppr d <+> ppr vsa
instance Monoid PartialResult where
mempty = PartialResult mempty [] mempty
(PartialResult cs1 vsa1 ds1)
`mappend` (PartialResult cs2 vsa2 ds2)
= PartialResult (cs1 `mappend` cs2)
mempty = PartialResult mempty mempty [] mempty
(PartialResult prov1 cs1 vsa1 ds1)
`mappend` (PartialResult prov2 cs2 vsa2 ds2)
= PartialResult (prov1 `mappend` prov2)
(cs1 `mappend` cs2)
(vsa1 `mappend` vsa2)
(ds1 `mappend` ds2)
......@@ -197,7 +249,8 @@ instance Monoid PartialResult where
-- * Clauses with inaccessible RHS
data PmResult =
PmResult {
pmresultRedundant :: [Located [LPat Id]]
pmresultProvenance :: Provenance
, pmresultRedundant :: [Located [LPat Id]]
, pmresultUncovered :: Uncovered
, pmresultInaccessible :: [Located [LPat Id]] }
......@@ -213,7 +266,7 @@ data PmResult =
checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
mb_pm_res <- tryM (head <$> myRunListT (checkSingle' locn var p))
mb_pm_res <- tryM (getResult (checkSingle' locn var p))
case mb_pm_res of
Left _ -> warnPmIters dflags ctxt
Right res -> dsPmWarn dflags ctxt res
......@@ -226,11 +279,12 @@ checkSingle' locn var p = do
clause <- liftD $ translatePat fam_insts p
missing <- mkInitialUncovered [var]
tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))
PartialResult cs us ds <- runMany (pmcheckI clause []) missing -- no guards
-- no guards
PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing
return $ case (cs,ds) of
(Covered, _ ) -> PmResult [] us [] -- useful
(NotCovered, NotDiverged) -> PmResult m us [] -- redundant
(NotCovered, Diverged ) -> PmResult [] us m -- inaccessible rhs
(Covered, _ ) -> PmResult prov [] us [] -- useful
(NotCovered, NotDiverged) -> PmResult prov m us [] -- redundant
(NotCovered, Diverged ) -> PmResult prov [] us m -- inaccessible rhs
where m = [L locn [L locn p]]
-- | Check a matchgroup (case, functions, etc.)
......@@ -242,7 +296,7 @@ checkMatches dflags ctxt vars matches = do
, text "Matches:"])
2
(vcat (map ppr matches)))
mb_pm_res <- tryM (head <$> myRunListT (checkMatches' vars matches))
mb_pm_res <- tryM (getResult (checkMatches' vars matches))
case mb_pm_res of
Left _ -> warnPmIters dflags ctxt
Right res -> dsPmWarn dflags ctxt res
......@@ -250,29 +304,37 @@ checkMatches dflags ctxt vars matches = do
-- | Check a matchgroup (case, functions, etc.)
checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult
checkMatches' vars matches
| null matches = return $ PmResult [] [] []
| null matches = return $ PmResult FromBuiltin [] [] []
| otherwise = do
liftD resetPmIterDs -- set the iter-no to zero
missing <- mkInitialUncovered vars
tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
(rs,us,ds) <- go matches missing
return $ PmResult (map hsLMatchToLPats rs) us (map hsLMatchToLPats ds)
(prov, rs,us,ds) <- go matches missing
return
$ PmResult prov (map hsLMatchToLPats rs) us (map hsLMatchToLPats ds)
where
go :: [LMatch Id (LHsExpr Id)] -> Uncovered
-> PmM ([LMatch Id (LHsExpr Id)] , Uncovered , [LMatch Id (LHsExpr Id)])
go [] missing = return ([], missing, [])
-> PmM (Provenance
, [LMatch Id (LHsExpr Id)]
, Uncovered
, [LMatch Id (LHsExpr Id)])
go [] missing = return (mempty, [], missing, [])
go (m:ms) missing = do
tracePm "checMatches': go" (ppr m $$ ppr missing)
fam_insts <- liftD dsGetFamInstEnvs
(clause, guards) <- liftD $ translateMatch fam_insts m
r@(PartialResult cs missing' ds)
r@(PartialResult prov cs missing' ds)
<- runMany (pmcheckI clause guards) missing
tracePm "checMatches': go: res" (ppr r)
(rs, final_u, is) <- go ms missing'
(ms_prov, rs, final_u, is) <- go ms missing'
let final_prov = prov `mappend` ms_prov
return $ case (cs, ds) of
(Covered, _ ) -> ( rs, final_u, is) -- useful
(NotCovered, NotDiverged) -> (m:rs, final_u, is) -- redundant
(NotCovered, Diverged ) -> ( rs, final_u, m:is) -- inaccessible
-- useful
(Covered, _ ) -> (final_prov, rs, final_u, is)
-- redundant
(NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)
-- inaccessible
(NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is)
hsLMatchToLPats :: LMatch id body -> Located [LPat id]
hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
......@@ -288,7 +350,7 @@ checkMatches' vars matches
-- -----------------------------------------------------------------------
-- * Utilities
nullaryConPattern :: DataCon -> Pattern
nullaryConPattern :: ConLike -> Pattern
-- Nullary data constructor and nullary type constructor
nullaryConPattern con =
PmCon { pm_con_con = con, pm_con_arg_tys = []
......@@ -296,7 +358,7 @@ nullaryConPattern con =
{-# INLINE nullaryConPattern #-}
truePattern :: Pattern
truePattern = nullaryConPattern trueDataCon
truePattern = nullaryConPattern (RealDataCon trueDataCon)
{-# INLINE truePattern #-}
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
......@@ -307,7 +369,7 @@ fake_pat = PmGrd { pm_grd_pv = [truePattern]
-- | Check whether a guard pattern is generated by the checker (unhandled)
isFakeGuard :: [Pattern] -> PmExpr -> Bool
isFakeGuard [PmCon { pm_con_con = c }] (PmExprOther EWildPat)
isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
| c == trueDataCon = True
| otherwise = False
isFakeGuard _pats _e = False
......@@ -318,7 +380,7 @@ mkCanFailPmPat ty = do
var <- mkPmVar ty
return [var, fake_pat]
vanillaConPattern :: DataCon -> [Type] -> PatVec -> Pattern
vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
-- ADT constructor pattern => no existentials, no local constraints
vanillaConPattern con arg_tys args =
PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
......@@ -328,13 +390,13 @@ vanillaConPattern con arg_tys args =
-- | Create an empty list pattern of a given type
nilPattern :: Type -> Pattern
nilPattern ty =
PmCon { pm_con_con = nilDataCon, pm_con_arg_tys = [ty]
PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]
, pm_con_tvs = [], pm_con_dicts = []
, pm_con_args = [] }
{-# INLINE nilPattern #-}
mkListPatVec :: Type -> PatVec -> PatVec -> PatVec
mkListPatVec ty xs ys = [PmCon { pm_con_con = consDataCon
mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon
, pm_con_arg_tys = [ty]
, pm_con_tvs = [], pm_con_dicts = []
, pm_con_args = xs++ys }]
......@@ -410,26 +472,21 @@ translatePat fam_insts pat = case pat of
-- See Note [Guards and Approximation]
| otherwise -> mkCanFailPmPat pat_ty
ConPatOut { pat_con = L _ (PatSynCon _) } ->
-- Pattern synonyms have a "matcher"
-- (see Note [Pattern synonym representation] in PatSyn.hs
-- We should be able to transform (P x y)
-- to v (Just (x, y) <- matchP v (\x y -> Just (x,y)) Nothing
-- That is, a combination of a variable pattern and a guard
-- But there are complications with GADTs etc, and this isn't done yet
mkCanFailPmPat (hsPatType pat)
ConPatOut { pat_con = L _ (RealDataCon con)
ConPatOut { pat_con = L _ con
, pat_arg_tys = arg_tys
, pat_tvs = ex_tvs
, pat_dicts = dicts
, pat_args = ps } -> do
args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
return [PmCon { pm_con_con = con
, pm_con_arg_tys = arg_tys
, pm_con_tvs = ex_tvs
, pm_con_dicts = dicts
, pm_con_args = args }]
groups <- allCompleteMatches con arg_tys
case groups of
[] -> mkCanFailPmPat (conLikeResTy con arg_tys)
_ -> do
args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
return [PmCon { pm_con_con = con
, pm_con_arg_tys = arg_tys
, pm_con_tvs = ex_tvs
, pm_con_dicts = dicts
, pm_con_args = args }]
NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
......@@ -442,17 +499,17 @@ translatePat fam_insts pat = case pat of
PArrPat ps ty -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let fake_con = parrFakeCon (length ps)
let fake_con = RealDataCon (parrFakeCon (length ps))
return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
TuplePat ps boxity tys -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let tuple_con = tupleDataCon boxity (length ps)
let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
return [vanillaConPattern tuple_con tys (concat tidy_ps)]
SumPat p alt arity ty -> do
tidy_p <- translatePat fam_insts (unLoc p)
let sum_con = sumDataCon alt arity
let sum_con = RealDataCon (sumDataCon alt arity)
return [vanillaConPattern sum_con ty tidy_p]
-- --------------------------------------------------------------------------
......@@ -486,7 +543,7 @@ translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
-- | Translate a constructor pattern
translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
-> DataCon -> HsConPatDetails Id -> DsM PatVec
-> ConLike -> HsConPatDetails Id -> DsM PatVec
translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
= concat <$> translatePatVec fam_insts (map unLoc ps)
translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
......@@ -525,10 +582,10 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
return (arg_var_pats ++ guards)
where
-- The actual argument types (instantiated)
arg_tys = dataConInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
-- Some label information
orig_lbls = map flSelector $ dataConFieldLabels c
orig_lbls = map flSelector $ conLikeFieldLabels c
matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
| L _ x <- fs]
matched_lbls = [ name | (name, _pat) <- matched_pats ]
......@@ -579,7 +636,7 @@ translateGuards fam_insts guards = do
shouldKeep :: Pattern -> Bool
shouldKeep p
| PmVar {} <- p = True
| PmCon {} <- p = length (allConstructors (pm_con_con p)) == 1
| PmCon {} <- p = singleConstructor (pm_con_con p)
&& all shouldKeep (pm_con_args p)
shouldKeep (PmGrd pv e)
| all shouldKeep pv = True
......@@ -590,7 +647,7 @@ translateGuards fam_insts guards = do
cantFailPattern :: Pattern -> Bool
cantFailPattern p
| PmVar {} <- p = True
| PmCon {} <- p = length (allConstructors (pm_con_con p)) == 1
| PmCon {} <- p = singleConstructor (pm_con_con p)
&& all cantFailPattern (pm_con_args p)
cantFailPattern (PmGrd pv _e)
= all cantFailPattern pv
......@@ -739,7 +796,7 @@ families is not really efficient.
-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern
pmPatType :: PmPat p -> Type
pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })
= mkTyConApp (dataConTyCon con) tys
= conLikeResTy con tys
pmPatType (PmVar { pm_var_id = x }) = idType x
pmPatType (PmLit { pm_lit_lit = l }) = pmLitType l
pmPatType (PmNLit { pm_lit_id = x }) = idType x
......@@ -749,7 +806,7 @@ pmPatType (PmGrd { pm_grd_pv = pv })
-- | Generate a value abstraction for a given constructor (generate
-- fresh variables of the appropriate type for arguments)
mkOneConFull :: Id -> DataCon -> DsM (ValAbs, ComplexEq, Bag EvVar)
mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar)
-- * x :: T tys, where T is an algebraic data type
-- NB: in the case of a data familiy, T is the *representation* TyCon
-- e.g. data instance T (a,b) = T1 a b
......@@ -766,12 +823,12 @@ mkOneConFull :: Id -> DataCon -> DsM (ValAbs, ComplexEq, Bag EvVar)
-- ComplexEq: x ~ K y1..yn
-- [EvVar]: Q
mkOneConFull x con = do
let -- res_ty == TyConApp (dataConTyCon cabs_con) cabs_arg_tys
let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys
res_ty = idType x
(univ_tvs, ex_tvs, eq_spec, thetas, arg_tys, _) = dataConFullSig con
data_tc = dataConTyCon con -- The representation TyCon
(univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _)
= conLikeFullSig con
tc_args = case splitTyConApp_maybe res_ty of
Just (tc, tys) -> ASSERT( tc == data_tc ) tys
Just (_, tys) -> tys
Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)
subst1 = zipTvSubst univ_tvs tc_args
......@@ -866,9 +923,38 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
, pm_con_args = coercePatVec args }]
coercePmPat (PmGrd {}) = [] -- drop the guards
-- | Get all constructors in the family (including given)
allConstructors :: DataCon -> [DataCon]
allConstructors = tyConDataCons . dataConTyCon
-- | Check whether a data constructor is the only way to construct
-- a data type.
singleConstructor :: ConLike -> Bool
singleConstructor (RealDataCon dc) =
case tyConDataCons (dataConTyCon dc) of
[_] -> True
_ -> False
singleConstructor _ = False
-- | For a given conlike, finds all the sets of patterns which could
-- be relevant to that conlike by consulting the result type.
--
-- These come from two places.
-- 1. From data constructors defined with the result type constructor.
-- 2. From `COMPLETE` pragmas which have the same type as the result
-- type constructor.
allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]
allCompleteMatches cl tys = do
let fam = case cl of
RealDataCon dc ->
[(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]
PatSynCon _ -> []
from_pragma <- map ((FromComplete,) . completeMatch) <$>
case splitTyConApp_maybe (conLikeResTy cl tys) of
Just (tc, _) -> dsGetCompleteMatches tc
Nothing -> return []
let final_groups = fam ++ from_pragma
tracePmD "allCompleteMatches" (ppr final_groups)
return final_groups
-- -----------------------------------------------------------------------
-- * Types and constraints
......@@ -962,11 +1048,8 @@ Main functions are:
-- value set abstraction, but calling it on every vector and the combining the
-- results.
runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)
runMany _ [] = return $ PartialResult mempty mempty mempty
runMany pm (m:ms) = do
(PartialResult c v d) <- pm m
(PartialResult cs vs ds) <- runMany pm ms
return (PartialResult (c `mappend` cs) (v `mappend` vs) (d `mappend` ds))
runMany _ [] = return mempty
runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms
{-# INLINE runMany #-}
-- | Generate the initial uncovered set. It initializes the
......@@ -1005,7 +1088,8 @@ pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva
-- | Increase the counter for elapsed algorithm iterations, check that the
-- limit is not exceeded and call `pmcheckHd`
pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM PartialResult
pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
-> PmM PartialResult
pmcheckHdI p ps guards va vva = do
n <- liftD incrCheckPmIterDs
tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p
......@@ -1050,14 +1134,18 @@ pmcheck (p:ps) guards (ValVec (va:vva) delta)
pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
pmcheckGuards [] vva = return (usimple [vva])
pmcheckGuards (gv:gvs) vva = do
(PartialResult cs vsa ds) <- pmcheckI gv [] vva
(PartialResult css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
return $ PartialResult (cs `mappend` css) vsas (ds `mappend` dss)
(PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva
(PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
return $ PartialResult (prov1 `mappend` prov2)
(cs `mappend` css)
vsas
(ds `mappend` dss)
-- | Worker function: Implements all cases described in the paper for all three
-- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`
-- cases which are handled by `pmcheck`
pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM PartialResult
pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
-> PmM PartialResult
-- Var
pmcheckHd (PmVar x) ps guards va (ValVec vva delta)
......@@ -1081,9 +1169,12 @@ pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =
False -> return $ ucon va (usimple [vva])
-- ConVar
pmcheckHd (p@(PmCon { pm_con_con = con })) ps guards
pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))
ps guards
(PmVar x) (ValVec vva delta) = do
cons_cs <- mapM (liftD . mkOneConFull x) (allConstructors con)
(prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)
cons_cs <- mapM (liftD . mkOneConFull x) complete_match
inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do
let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state
......@@ -1093,8 +1184,9 @@ pmcheckHd (p@(PmCon { pm_con_con = con })) ps guards
(True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)]
_ty_or_tm_failed -> []
force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
runMany (pmcheckI (p:ps) guards) inst_vsa
set_provenance prov .
force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
runMany (pmcheckI (p:ps) guards) inst_vsa
-- LitVar
pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)
......@@ -1187,10 +1279,10 @@ ucon va = updateVsa upd
-- value vector abstractions of length `(a+n)`, pass the first `n` value
-- abstractions to the constructor (Hence, the resulting value vector
-- abstractions will have length `n+1`)
kcon :: DataCon -> [Type] -> [TyVar] -> [EvVar]
kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]
-> PartialResult -> PartialResult
kcon con arg_tys ex_tvs dicts
= let n = dataConSourceArity con
= let n = conLikeArity con
upd vsa =
[ ValVec (va:vva) delta
| ValVec vva' delta <- vsa
......@@ -1223,6 +1315,9 @@ force_if :: Bool -> PartialResult -> PartialResult
force_if True pres = forces pres
force_if False pres = pres
set_provenance :: Provenance -> PartialResult -> PartialResult
set_provenance prov pr = pr { presultProvenence = prov }
-- ----------------------------------------------------------------------------
-- * Propagation of term constraints inwards when checking nested matches
......@@ -1360,8 +1455,8 @@ wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)
dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
= when (flag_i || flag_u) $ do
let exists_r = flag_i && notNull redundant
exists_i = flag_i && notNull inaccessible
let exists_r = flag_i && notNull redundant && onlyBuiltin
exists_i = flag_i && notNull inaccessible && onlyBuiltin
exists_u = flag_u && notNull uncovered
when exists_r $ forM_ redundant $ \(L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
......@@ -1373,7 +1468,8 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
putSrcSpanDs loc (warnDs flag_u_reason (pprEqns uncovered))
where
PmResult
{ pmresultRedundant = redundant
{ pmresultProvenance = prov
, pmresultRedundant = redundant
, pmresultUncovered = uncovered
, pmresultInaccessible = inaccessible } = pm_result
......@@ -1381,6 +1477,8 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
flag_u = exhaustive dflags kind
flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
onlyBuiltin = prov == FromBuiltin
maxPatterns = maxUncoveredPatterns dflags
-- Print a single clause (for redundant/with-inaccessible-rhs)
......
......@@ -296,7 +296,9 @@ deSugar hsc_env
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info})
tcg_hpc = other_hpc_info,
tcg_complete_matches = complete_matches
})
= do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
......@@ -313,8 +315,9 @@ deSugar hsc_env
then addTicksToBinds hsc_env mod mod_loc
export_set (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, Nothing)
; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
; (msgs, mb_res)
<- initDs hsc_env mod rdr_env type_env
fam_inst_env complete_matches $
do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
......@@ -396,7 +399,8 @@ deSugar hsc_env
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo,