diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/Check.hs | 49 |
1 files changed, 22 insertions, 27 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 8496786a8e..e87eb39d26 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -157,7 +157,9 @@ data PmPat :: PatTy -> * where PmNLit :: { pm_lit_id :: Id , pm_lit_not :: [PmLit] } -> PmPat 'VA PmGrd :: { pm_grd_pv :: PatVec - , pm_grd_expr :: PmExpr } -> PmPat 'PAT + , pm_grd_expr :: PmExpr } -> PmPat 'PAT + -- | A fake guard pattern (True <- _) used to represent cases we cannot handle. + PmFake :: PmPat 'PAT instance Outputable (PmPat a) where ppr = pprPmPatDebug @@ -928,24 +930,11 @@ truePattern :: Pattern truePattern = nullaryConPattern (RealDataCon trueDataCon) {-# INLINE truePattern #-} --- | A fake guard pattern (True <- _) used to represent cases we cannot handle -fake_pat :: Pattern -fake_pat = PmGrd { pm_grd_pv = [truePattern] - , pm_grd_expr = PmExprOther (EWildPat noExt) } -{-# INLINE fake_pat #-} - --- | Check whether a guard pattern is generated by the checker (unhandled) -isFakeGuard :: [Pattern] -> PmExpr -> Bool -isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _)) - | c == trueDataCon = True - | otherwise = False -isFakeGuard _pats _e = False - -- | Generate a `canFail` pattern vector of a specific type mkCanFailPmPat :: Type -> DsM PatVec mkCanFailPmPat ty = do var <- mkPmVar ty - return [var, fake_pat] + return [var, PmFake] vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern -- ADT constructor pattern => no existentials, no local constraints @@ -1295,7 +1284,7 @@ translateGuards fam_insts guards = do then pure all_guards else do kept <- filterM shouldKeep all_guards - pure (fake_pat : kept) + pure (PmFake : kept) -- | Check whether a pattern can fail to match cantFailPattern :: Pattern -> DsM Bool @@ -1377,7 +1366,7 @@ cases: expressivity in our warnings. Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy* - @fake_pat@: @True <- _@. That is, we record that there is a possibility + @PmFake@: @True <- _@. That is, we record that there is a possibility of failure but we minimize it to a True/False. This generates a single warning and much smaller uncovered sets. @@ -1421,7 +1410,7 @@ in the pattern bind case). Hence, we safely drop them. Additionally, top-level guard translation (performed by @translateGuards@) replaces guards that cannot be reasoned about (like the ones we described in -1-4) with a single @fake_pat@ to record the possibility of failure to match. +1-4) with a single @PmFake@ to record the possibility of failure to match. Note [Translate CoPats] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -1457,6 +1446,7 @@ pmPatType (PmNLit { pm_lit_id = x }) = idType x pmPatType (PmGrd { pm_grd_pv = pv }) = ASSERT(patVecArity pv == 1) (pmPatType p) where Just p = find ((==1) . patternArity) pv +pmPatType PmFake = pmPatType truePattern -- | Information about a conlike that is relevant to coverage checking. -- It is called an \"inhabitation candidate\" since it is a value which may @@ -1679,7 +1669,7 @@ mkGuard pv e = do let expr = hsExprToPmExpr e tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr]) if | res -> pure (PmGrd pv expr) - | PmExprOther {} <- expr -> pure fake_pat + | PmExprOther {} <- expr -> pure PmFake | otherwise -> pure (PmGrd pv expr) -- | Create a term equality of the form: `(False ~ (x ~ lit))` @@ -1753,6 +1743,7 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys , pm_con_tvs = tvs, pm_con_dicts = dicts , pm_con_args = coercePatVec args }] coercePmPat (PmGrd {}) = [] -- drop the guards +coercePmPat PmFake = [] -- drop the guards -- | Check whether a 'ConLike' has the /single match/ property, i.e. whether -- it is the only possible match in the given context. See also @@ -1765,7 +1756,7 @@ singleMatchConstructor cl tys = Note [Single match constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When translating pattern guards for consumption by the checker, we desugar -every pattern guard that might fail ('cantFailPattern') to 'fake_pat' +every pattern guard that might fail ('cantFailPattern') to 'PmFake' (True <- _). Which patterns can't fail? Exactly those that only match on 'singleMatchConstructor's. @@ -2023,13 +2014,15 @@ pmcheck [] guards vva@(ValVec [] _) | otherwise = pmcheckGuardsI guards vva -- Guard -pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta) - -- short-circuit if the guard pattern is useless. - -- we just have two possible outcomes: fail here or match and recurse - -- none of the two contains any useful information about the failure - -- though. So just have these two cases but do not do all the boilerplate - | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva - | otherwise = do +pmcheck (PmFake : ps) guards vva = + -- short-circuit if the guard pattern is useless. + -- we just have two possible outcomes: fail here or match and recurse + -- none of the two contains any useful information about the failure + -- though. So just have these two cases but do not do all the boilerplate + forces . mkCons vva <$> pmcheckI ps guards vva +pmcheck (p : ps) guards (ValVec vas delta) + | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p + = do y <- liftD $ mkPmId (pmPatType p) let tm_state = extendSubst y e (delta_tm_cs delta) delta' = delta { delta_tm_cs = tm_state } @@ -2182,6 +2175,7 @@ pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva = pmcheckHdI p ps guards (PmVar x) vva -- Impossible: handled by pmcheck +pmcheckHd PmFake _ _ _ _ = panic "pmcheckHd: Fake" pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard" {- @@ -2742,6 +2736,7 @@ pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv) <+> ppr ge +pprPmPatDebug PmFake = text "PmFake" pprPatVec :: PatVec -> SDoc pprPatVec ps = hang (text "Pattern:") 2 |