Commit 86966d48 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

PmCheck: Properly handle constructor-bound type variables

In ghc/ghc!2192 (comment 246551)
Simon convinced me that ignoring type variables existentially bound by
data constructors have to be the same way as value binders.

Sadly I couldn't think of a regression test, but I'm confident that this
change strictly improves on the status quo.
parent 8038cbd9
......@@ -95,6 +95,7 @@ data PmGrd
PmCon {
pm_id :: !Id,
pm_con_con :: !PmAltCon,
pm_con_tvs :: ![TyVar],
pm_con_dicts :: ![EvVar],
pm_con_args :: ![Id]
}
......@@ -113,7 +114,7 @@ data PmGrd
-- | Should not be user-facing.
instance Outputable PmGrd where
ppr (PmCon x alt _con_dicts con_args)
ppr (PmCon x alt _tvs _con_dicts con_args)
= hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x]
ppr (PmBang x) = char '!' <> ppr x
ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr]
......@@ -354,7 +355,7 @@ mkPmLetVar x y = [PmLet x (Var y)]
vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd scrut con arg_ids =
PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)
, pm_con_dicts = [], pm_con_args = arg_ids }
, pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids }
-- | Creates a 'GrdVec' refining a match var of list type to a list,
-- where list fields are matched against the incoming tagged 'GrdVec's.
......@@ -389,6 +390,7 @@ mkPmLitGrds x (PmLit _ (PmLitString s)) = do
mkPmLitGrds x lit = do
let grd = PmCon { pm_id = x
, pm_con_con = PmAltLit lit
, pm_con_tvs = []
, pm_con_dicts = []
, pm_con_args = [] }
pure [grd]
......@@ -585,7 +587,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case
-- 1. the constructor pattern match itself
arg_ids <- zipWithM get_pat_id [0..] arg_tys
let con_grd = PmCon x (PmAltConLike con) dicts arg_ids
let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids
-- 2. bang strict fields
let arg_is_banged = map isBanged $ conLikeImplBangs con
......@@ -935,14 +937,14 @@ checkGrdTree' (Guard (PmBang x) tree) deltas = do
pure res{ cr_clauses = applyWhen has_diverged mayDiverge (cr_clauses res) }
-- Con: Diverge on x ~ ⊥, fall through on x /~ K and refine with x ~ K ys
-- and type info
checkGrdTree' (Guard (PmCon x con dicts args) tree) deltas = do
checkGrdTree' (Guard (PmCon x con tvs dicts args) tree) deltas = do
has_diverged <-
if conMatchForces con
then addPmCtDeltas deltas (PmBotCt x) >>= isInhabited
else pure False
unc_this <- addPmCtDeltas deltas (PmNotConCt x con)
deltas' <- addPmCtsDeltas deltas $
listToBag (PmTyCt . evVarPred <$> dicts) `snocBag` PmConCt x con args
listToBag (PmTyCt . evVarPred <$> dicts) `snocBag` PmConCt x con tvs args
CheckResult tree' unc_inner prec <- checkGrdTree' tree deltas'
limit <- maxPmCheckModels <$> getDynFlags
let (prec', unc') = throttle limit deltas (unc_this Semi.<> unc_inner)
......@@ -1032,10 +1034,10 @@ addScrutTmCs (Just scr) [x] k = do
locallyExtendPmDelta (\delta -> addPmCts delta (unitBag (PmCoreCt x scr_e))) k
addScrutTmCs _ _ _ = panic "addScrutTmCs: HsCase with more than one case binder"
addPmConCts :: Delta -> Id -> PmAltCon -> [EvVar] -> [Id] -> DsM (Maybe Delta)
addPmConCts delta x con dicts fields = runMaybeT $ do
addPmConCts :: Delta -> Id -> PmAltCon -> [TyVar] -> [EvVar] -> [Id] -> DsM (Maybe Delta)
addPmConCts delta x con tvs dicts fields = runMaybeT $ do
delta_ty <- MaybeT $ addPmCts delta (listToBag (PmTyCt . evVarPred <$> dicts))
delta_tm_ty <- MaybeT $ addPmCts delta_ty (unitBag (PmConCt x con fields))
delta_tm_ty <- MaybeT $ addPmCts delta_ty (unitBag (PmConCt x con tvs fields))
pure delta_tm_ty
-- | Add equalities to the local 'DsM' environment when checking the RHS of a
......@@ -1068,9 +1070,9 @@ computeCovered (PmLet { pm_id = x, pm_let_expr = e } : ps) delta = do
computeCovered (PmBang{} : ps) delta = do
computeCovered ps delta
computeCovered (p : ps) delta
| PmCon{ pm_id = x, pm_con_con = con, pm_con_args = args
| PmCon{ pm_id = x, pm_con_con = con, pm_con_tvs = tvs, pm_con_args = args
, pm_con_dicts = dicts } <- p
= addPmConCts delta x con dicts args >>= \case
= addPmConCts delta x con tvs dicts args >>= \case
Nothing -> pure Nothing
Just delta' -> computeCovered ps delta'
......
This diff is collapsed.
......@@ -143,7 +143,7 @@ pprPmVar :: PprPrec -> Id -> PmPprM SDoc
pprPmVar prec x = do
delta <- ask
case lookupSolution delta x of
Just (alt, args) -> pprPmAltCon prec alt args
Just (alt, _tvs, args) -> pprPmAltCon prec alt args
Nothing -> fromMaybe typed_wildcard <$> checkRefuts x
where
-- if we have no info about the parameter and would just print a
......@@ -203,7 +203,7 @@ pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList delta = go_con []
where
go_var rev_pref x
| Just (alt, args) <- lookupSolution delta x
| Just (alt, _tvs, args) <- lookupSolution delta x
= go_con rev_pref alt args
go_var rev_pref x
| Just pref <- nonEmpty (reverse rev_pref)
......
......@@ -465,7 +465,7 @@ data VarInfo
-- ^ The type of the variable. Important for rejecting possible GADT
-- constructors or incompatible pattern synonyms (@Just42 :: Maybe Int@).
, vi_pos :: ![(PmAltCon, [Id])]
, vi_pos :: ![(PmAltCon, [TyVar], [Id])]
-- ^ Positive info: 'PmAltCon' apps it is (i.e. @x ~ [Just y, PatSyn z]@), all
-- at the same time (i.e. conjunctive). We need a list because of nested
-- pattern matches involving pattern synonym
......
......@@ -323,21 +323,21 @@ zipWith4Equal _ = zipWith4
#else
zipEqual _ [] [] = []
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)
zipEqual msg _ _ = panic ("zipEqual: unequal lists: "++msg)
zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
zipWithEqual _ _ [] [] = []
zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists: "++msg)
zipWith3Equal msg z (a:as) (b:bs) (c:cs)
= z a b c : zipWith3Equal msg z as bs cs
zipWith3Equal _ _ [] [] [] = []
zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists: "++msg)
zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
= z a b c d : zipWith4Equal msg z as bs cs ds
zipWith4Equal _ _ [] [] [] [] = []
zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg)
#endif
-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
......
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