diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2017-01-18 13:25:30 +0000 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2017-01-26 00:22:46 +0000 |
| commit | 1a3f1eebf81952accb6340252816211c7d391300 (patch) | |
| tree | 03fbe6fac6518c3da73282266833941d76b34736 | |
| parent | 078c21140d4f27e586c9fa893d4ac94d28d6013c (diff) | |
| download | haskell-1a3f1eebf81952accb6340252816211c7d391300.tar.gz | |
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
51 files changed, 959 insertions, 154 deletions
diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs index b8bab31297..aa6a362f68 100644 --- a/compiler/basicTypes/ConLike.hs +++ b/compiler/basicTypes/ConLike.hs @@ -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 diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 04ba5681b0..80f7fa50e3 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 1e117b3c00..1cd7979128 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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, mg_safe_haskell = safe_mode, - mg_trust_pkg = imp_trust_own_pkg imports + mg_trust_pkg = imp_trust_own_pkg imports, + mg_complete_sigs = complete_matches } ; return (msgs, Just mod_guts) }}}} @@ -451,7 +455,7 @@ deSugarExpr hsc_env tc_expr -- Do desugaring ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env - type_env fam_inst_env $ + type_env fam_inst_env [] $ dsLExpr tc_expr ; case mb_core_expr of diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 27106a2c8b..049c226a0b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -737,6 +737,7 @@ rep_sig (L loc (SpecSig nm tys ispec)) rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (L _ (CompleteMatchSig {})) = notHandled "CompleteMatchSig" empty rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name -> DsM (SrcSpan, Core TH.DecQ) diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 24cca5d8b2..f9533e391a 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -35,7 +35,7 @@ module DsMonad ( getDictsDs, addDictsDs, getTmCsDs, addTmCsDs, -- Iterations for pm checking - incrCheckPmIterDs, resetPmIterDs, + incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches, -- Warnings and errors DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, @@ -83,6 +83,7 @@ import FastString import Maybes import Var (EvVar) import qualified GHC.LanguageExtensions as LangExt +import UniqFM ( lookupWithDefaultUFM ) import Data.IORef import Control.Monad @@ -152,17 +153,19 @@ type DsWarning = (SrcSpan, SDoc) initDs :: HscEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> [CompleteMatch] -> DsM a -> IO (Messages, Maybe a) -- Print errors and warnings, if any arise -initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside +initDs hsc_env mod rdr_env type_env fam_inst_env complete_matches thing_inside = do { msg_var <- newIORef (emptyBag, emptyBag) + ; let all_matches = (hptCompleteSigs hsc_env) ++ complete_matches ; pm_iter_var <- newIORef 0 ; let dflags = hsc_dflags hsc_env (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var - pm_iter_var + pm_iter_var all_matches ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ loadDAP $ @@ -241,8 +244,9 @@ initDsTc thing_inside ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env fam_inst_env = tcg_fam_inst_env tcg_env + complete_matches = tcg_complete_matches tcg_env ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env - msg_var pm_iter_var + msg_var pm_iter_var complete_matches ; setEnvs ds_envs thing_inside } @@ -270,13 +274,15 @@ initTcDsForSolver thing_inside thing_inside } mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar + -> IORef Messages -> IORef Int -> [CompleteMatch] + -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) False -- not boot! real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) + completeMatchMap = mkCompleteMatchMap complete_matches gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env , ds_if_env = (if_genv, if_lenv) @@ -284,6 +290,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar , ds_msgs = msg_var , ds_dph_env = emptyGlobalRdrEnv , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" + , ds_complete_matches = completeMatchMap } lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span @@ -293,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar } in (gbl_env, lcl_env) + -- Attempt to load the given module and return its exported entities if successful. -- loadModule :: SDoc -> Module -> DsM GlobalRdrEnv @@ -608,6 +616,12 @@ dsGetFamInstEnvs dsGetMetaEnv :: DsM (NameEnv DsMetaVal) dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } +-- | The @COMPLETE@ pragams provided by the user for a given `TyCon`. +dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch] +dsGetCompleteMatches tc = do + env <- getGblEnv + return $ (lookupWithDefaultUFM (ds_complete_matches env) [] tc) + dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index e35358fba5..8c3df9689e 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -53,11 +53,15 @@ refer to variables that are otherwise substituted away. -- | Lifted expressions for pattern match checking. data PmExpr = PmExprVar Name - | PmExprCon DataCon [PmExpr] + | PmExprCon ConLike [PmExpr] | PmExprLit PmLit | PmExprEq PmExpr PmExpr -- Syntactic equality | PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr] + +mkPmExprData :: DataCon -> [PmExpr] -> PmExpr +mkPmExprData dc args = PmExprCon (RealDataCon dc) args + -- | Literals (simple and overloaded ones) for pattern match checking. data PmLit = PmSLit HsLit -- simple | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded @@ -148,11 +152,11 @@ toComplex (x,e) = (PmExprVar (idName x), e) -- | Expression `True' truePmExpr :: PmExpr -truePmExpr = PmExprCon trueDataCon [] +truePmExpr = mkPmExprData trueDataCon [] -- | Expression `False' falsePmExpr :: PmExpr -falsePmExpr = PmExprCon falseDataCon [] +falsePmExpr = mkPmExprData falseDataCon [] -- ---------------------------------------------------------------------------- -- ** Predicates on PmExpr @@ -169,17 +173,17 @@ isNegatedPmLit _other_lit = False -- | Check whether a PmExpr is syntactically equal to term `True'. isTruePmExpr :: PmExpr -> Bool -isTruePmExpr (PmExprCon c []) = c == trueDataCon +isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon isTruePmExpr _other_expr = False -- | Check whether a PmExpr is syntactically equal to term `False'. isFalsePmExpr :: PmExpr -> Bool -isFalsePmExpr (PmExprCon c []) = c == falseDataCon +isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon isFalsePmExpr _other_expr = False -- | Check whether a PmExpr is syntactically e isNilPmExpr :: PmExpr -> Bool -isNilPmExpr (PmExprCon c _) = c == nilDataCon +isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon isNilPmExpr _other_expr = False -- | Check whether a PmExpr is syntactically equal to (x == y). @@ -242,7 +246,7 @@ hsExprToPmExpr e@(NegApp _ neg_e) hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e hsExprToPmExpr e@(ExplicitTuple ps boxity) - | all tupArgPresent ps = PmExprCon tuple_con tuple_args + | all tupArgPresent ps = mkPmExprData tuple_con tuple_args | otherwise = PmExprOther e where tuple_con = tupleDataCon boxity (length ps) @@ -252,11 +256,12 @@ hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems) | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) | otherwise = PmExprOther e {- overloaded list: No PmExprApp -} where - cons x xs = PmExprCon consDataCon [x,xs] - nil = PmExprCon nilDataCon [] + cons x xs = mkPmExprData consDataCon [x,xs] + nil = mkPmExprData nilDataCon [] hsExprToPmExpr (ExplicitPArr _elem_ty elems) - = PmExprCon (parrFakeCon (length elems)) (map lhsExprToPmExpr elems) + = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems) + -- we want this but we would have to make everything monadic :/ -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon @@ -388,30 +393,22 @@ needsParens (PmExprVar {}) = False needsParens (PmExprLit l) = isNegatedPmLit l needsParens (PmExprEq {}) = False -- will become a wildcard needsParens (PmExprOther {}) = False -- will become a wildcard -needsParens (PmExprCon c es) +needsParens (PmExprCon (RealDataCon c) es) | isTupleDataCon c || isPArrFakeCon c || isConsDataCon c || null es = False | otherwise = True +needsParens (PmExprCon (PatSynCon _) es) = not (null es) pprPmExprWithParens :: PmExpr -> PmPprM SDoc pprPmExprWithParens expr | needsParens expr = parens <$> pprPmExpr expr | otherwise = pprPmExpr expr -pprPmExprCon :: DataCon -> [PmExpr] -> PmPprM SDoc -pprPmExprCon con args +pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc +pprPmExprCon (RealDataCon con) args | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args | isConsDataCon con = pretty_list - | dataConIsInfix con = case args of - [x, y] -> do x' <- pprPmExprWithParens x - y' <- pprPmExprWithParens y - return (x' <+> ppr con <+> y') - -- can it be infix but have more than two arguments? - list -> pprPanic "pprPmExprCon:" (ppr list) - | null args = return (ppr con) - | otherwise = do args' <- mapM pprPmExprWithParens args - return (fsep (ppr con : args')) where mkTuple, mkPArr :: [SDoc] -> SDoc mkTuple = parens . fsep . punctuate comma @@ -426,10 +423,22 @@ pprPmExprCon con args list = list_elements args list_elements [x,y] - | PmExprCon c es <- y, nilDataCon == c = ASSERT(null es) [x,y] - | PmExprCon c es <- y, consDataCon == c = x : list_elements es + | PmExprCon c es <- y, RealDataCon nilDataCon == c + = ASSERT(null es) [x,y] + | PmExprCon c es <- y, RealDataCon consDataCon == c + = x : list_elements es | otherwise = [x,y] list_elements list = pprPanic "list_elements:" (ppr list) +pprPmExprCon cl args + | conLikeIsInfix cl = case args of + [x, y] -> do x' <- pprPmExprWithParens x + y' <- pprPmExprWithParens y + return (x' <+> ppr cl <+> y') + -- can it be infix but have more than two arguments? + list -> pprPanic "pprPmExprCon:" (ppr list) + | null args = return (ppr cl) + | otherwise = do args' <- mapM pprPmExprWithParens args + return (fsep (ppr cl : args')) instance Outputable PmLit where ppr (PmSLit l) = pmPprHsLit l diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs index 05966cd858..64f20e2121 100644 --- a/compiler/deSugar/TmOracle.hs +++ b/compiler/deSugar/TmOracle.hs @@ -26,7 +26,6 @@ import PmExpr import Id import Name -import TysWiredIn import Type import HsLit import TcHsSyn @@ -113,12 +112,12 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of (PmExprCon c1 ts1, PmExprCon c2 ts2) | c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2) | otherwise -> Nothing - (PmExprCon c [], PmExprEq t1 t2) - | c == trueDataCon -> solveComplexEq solver_state (t1, t2) - | c == falseDataCon -> Just (eq:standby, (unhandled, env)) - (PmExprEq t1 t2, PmExprCon c []) - | c == trueDataCon -> solveComplexEq solver_state (t1, t2) - | c == falseDataCon -> Just (eq:standby, (unhandled, env)) + (PmExprCon _ [], PmExprEq t1 t2) + | isTruePmExpr e1 -> solveComplexEq solver_state (t1, t2) + | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env)) + (PmExprEq t1 t2, PmExprCon _ []) + | isTruePmExpr e2 -> solveComplexEq solver_state (t1, t2) + | isFalsePmExpr e2 -> Just (eq:standby, (unhandled, env)) (PmExprVar x, PmExprVar y) | x == y -> Just solver_state diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index e04dc89559..1f38c387df 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -853,6 +853,7 @@ data Sig name | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes (Located name) -- Function name (Maybe StringLiteral) + | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name)) deriving instance (DataId name) => Data (Sig name) @@ -920,6 +921,7 @@ isPragLSig :: LSig name -> Bool isPragLSig (L _ (SpecSig {})) = True isPragLSig (L _ (InlineSig {})) = True isPragLSig (L _ (SCCFunSig {})) = True +isPragLSig (L _ (CompleteMatchSig {})) = True isPragLSig _ = False isInlineLSig :: LSig name -> Bool @@ -935,6 +937,10 @@ isSCCFunSig :: LSig name -> Bool isSCCFunSig (L _ (SCCFunSig {})) = True isSCCFunSig _ = False +isCompleteMatchSig :: LSig name -> Bool +isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True +isCompleteMatchSig _ = False + hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = text "type signature" hsSigDoc (PatSynSig {}) = text "pattern synonym signature" @@ -948,6 +954,7 @@ hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" hsSigDoc (FixSig {}) = text "fixity declaration" hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" {- Check if signatures overlap; this is used when checking for duplicate @@ -983,6 +990,12 @@ ppr_sig (PatSynSig names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) ppr_sig (SCCFunSig src fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) +ppr_sig (CompleteMatchSig src cs mty) + = pragSrcBrackets src "{-# COMPLETE" + ((hsep (punctuate comma (map ppr (unLoc cs)))) + <+> opt_sig) + where + opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty instance OutputableBndr name => Outputable (FixitySig name) where ppr (FixitySig names fixity) = sep [ppr fixity, pprops] diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 72a5b57f43..7a1d427397 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -19,6 +19,7 @@ module IfaceSyn ( IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), IfaceAxBranch(..), IfaceTyConParent(..), + IfaceCompleteMatch(..), -- * Binding names IfaceTopBndr, @@ -295,6 +296,11 @@ data IfaceAnnotation type IfaceAnnTarget = AnnTarget OccName +data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName + + + + -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O @@ -2090,3 +2096,7 @@ instance Binary IfaceTyConParent where pr <- get bh ty <- get bh return $ IfDataInstance ax pr ty + +instance Binary IfaceCompleteMatch where + put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts + get bh = IfaceCompleteMatch <$> get bh <*> get bh diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index bdc9f0ffe5..5215965aa4 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -206,7 +206,8 @@ mkIface_ hsc_env maybe_old_fingerprint md_anns = anns, md_vect_info = vect_info, md_types = type_env, - md_exports = exports } + md_exports = exports, + md_complete_sigs = complete_sigs } -- NB: notice that mkIface does not look at the bindings -- only at the TypeEnv. The previous Tidy phase has -- put exactly the info into the TypeEnv that we want @@ -241,6 +242,7 @@ mkIface_ hsc_env maybe_old_fingerprint iface_vect_info = flattenVectInfo vect_info trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns + icomplete_sigs = map mkIfaceCompleteSig complete_sigs intermediate_iface = ModIface { mi_module = this_mod, @@ -285,7 +287,8 @@ mkIface_ hsc_env maybe_old_fingerprint -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities } + mi_fix_fn = mkIfaceFixCache fixities, + mi_complete_sigs = icomplete_sigs } (new_iface, no_change_at_all) <- {-# SCC "versioninfo" #-} @@ -993,6 +996,19 @@ mkOrphMap get_key decls {- ************************************************************************ * * + COMPLETE Pragmas +* * +************************************************************************ +-} + +mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch +mkIfaceCompleteSig (CompleteMatch cls tc) = + IfaceCompleteMatch (map conLikeName cls) (tyConName tc) + + +{- +************************************************************************ +* * Keeping track of what we've slurped, and fingerprints * * ************************************************************************ diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index c0b84640b0..e08a3d71f6 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -177,6 +177,9 @@ typecheckIface iface -- Exports ; exports <- ifaceExportNames (mi_exports iface) + -- Complete Sigs + ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + -- Finished ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), -- Careful! If we tug on the TyThing thunks too early @@ -190,6 +193,7 @@ typecheckIface iface , md_anns = anns , md_vect_info = vect_info , md_exports = exports + , md_complete_sigs = complete_sigs } } @@ -327,6 +331,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var = anns <- tcIfaceAnnotations (mi_anns iface) vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) exports <- ifaceExportNames (mi_exports iface) + complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) return $ ModDetails { md_types = type_env , md_insts = insts , md_fam_insts = fam_insts @@ -334,6 +339,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var = , md_anns = anns , md_vect_info = vect_info , md_exports = exports + , md_complete_sigs = complete_sigs } return (global_type_env, details) @@ -366,6 +372,7 @@ typecheckIfaceForInstantiate nsubst iface = anns <- tcIfaceAnnotations (mi_anns iface) vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) exports <- ifaceExportNames (mi_exports iface) + complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) return $ ModDetails { md_types = type_env , md_insts = insts , md_fam_insts = fam_insts @@ -373,6 +380,7 @@ typecheckIfaceForInstantiate nsubst iface = , md_anns = anns , md_vect_info = vect_info , md_exports = exports + , md_complete_sigs = complete_sigs } -- Note [Resolving never-exported Names in TcIface] @@ -1016,6 +1024,21 @@ tcIfaceAnnTarget (ModuleTarget mod) = do {- ************************************************************************ * * + Complete Match Pragmas +* * +************************************************************************ +-} + +tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] +tcIfaceCompleteSigs = mapM tcIfaceCompleteSig + +tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch +tcIfaceCompleteSig (IfaceCompleteMatch ms t) = + CompleteMatch <$> (mapM tcIfaceConLike ms) <*> tcIfaceTyConByName t + +{- +************************************************************************ +* * Vectorisation information * * ************************************************************************ @@ -1668,6 +1691,14 @@ tcIfaceDataCon name = do { thing <- tcIfaceGlobal name AConLike (RealDataCon dc) -> return dc _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } +tcIfaceConLike :: Name -> IfL ConLike +tcIfaceConLike name = + do { thing <- tcIfaceGlobal name + ; case thing of + AConLike cl -> return cl + _ -> pprPanic "tcIfaceExtCL" (ppr name$$ ppr thing) } + + tcIfaceExtId :: Name -> IfL Id tcIfaceExtId name = do { thing <- tcIfaceGlobal name ; case thing of diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 51cec26006..0fcf58229b 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -37,6 +37,7 @@ module HscTypes ( HomePackageTable, HomeModInfo(..), emptyHomePackageTable, lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, addToHpt, addListToHpt, lookupHptDirectly, listToHpt, + hptCompleteSigs, hptInstances, hptRules, hptVectInfo, pprHPT, hptObjs, @@ -131,6 +132,9 @@ module HscTypes ( SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, throwOneError, handleSourceError, handleFlagWarnings, printOrThrowWarnings, + + -- * COMPLETE signature + CompleteMatch(..) ) where #include "HsVersions.h" @@ -614,6 +618,8 @@ lookupIfaceByModule _dflags hpt pit mod -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. +hptCompleteSigs :: HscEnv -> [CompleteMatch] +hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) -- | Find all the instance declarations (of classes and families) from -- the Home Package Table filtered by the provided predicate function. @@ -916,13 +922,14 @@ data ModIface mi_trust :: !IfaceTrustInfo, -- ^ Safe Haskell Trust information for this module. - mi_trust_pkg :: !Bool + mi_trust_pkg :: !Bool, -- ^ Do we require the package this module resides in be trusted -- to trust this module? This is used for the situation where a -- module is Safe (so doesn't require the package be trusted -- itself) but imports some trustworthy modules from its own -- package (which does require its own package be trusted). -- See Note [RnNames . Trust Own Package] + mi_complete_sigs :: [IfaceCompleteMatch] } -- | Old-style accessor for whether or not the ModIface came from an hs-boot @@ -997,7 +1004,8 @@ instance Binary ModIface where mi_vect_info = vect_info, mi_hpc = hpc_info, mi_trust = trust, - mi_trust_pkg = trust_pkg }) = do + mi_trust_pkg = trust_pkg, + mi_complete_sigs = complete_sigs }) = do put_ bh mod put_ bh sig_of put_ bh hsc_src @@ -1023,6 +1031,7 @@ instance Binary ModIface where put_ bh hpc_info put_ bh trust put_ bh trust_pkg + put_ bh complete_sigs get bh = do mod <- get bh @@ -1050,6 +1059,7 @@ instance Binary ModIface where hpc_info <- get bh trust <- get bh trust_pkg <- get bh + complete_sigs <- get bh return (ModIface { mi_module = mod, mi_sig_of = sig_of, @@ -1080,7 +1090,8 @@ instance Binary ModIface where -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, - mi_hash_fn = mkIfaceHashCache decls }) + mi_hash_fn = mkIfaceHashCache decls, + mi_complete_sigs = complete_sigs }) -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo @@ -1116,7 +1127,8 @@ emptyModIface mod mi_hash_fn = emptyIfaceHashCache, mi_hpc = False, mi_trust = noIfaceTrustInfo, - mi_trust_pkg = False } + mi_trust_pkg = False, + mi_complete_sigs = [] } -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' @@ -1148,7 +1160,9 @@ data ModDetails md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently -- they only annotate things also declared in this module - md_vect_info :: !VectInfo -- ^ Module vectorisation information + md_vect_info :: !VectInfo, -- ^ Module vectorisation information + md_complete_sigs :: [CompleteMatch] + -- ^ Complete match pragmas for this module } -- | Constructs an empty ModDetails @@ -1160,7 +1174,8 @@ emptyModDetails md_rules = [], md_fam_insts = [], md_anns = [], - md_vect_info = noVectInfo } + md_vect_info = noVectInfo, + md_complete_sigs = [] } -- | Records the modules directly imported by a module for extracting e.g. -- usage information, and also to give better error message @@ -1207,6 +1222,7 @@ data ModGuts mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_warns :: !Warnings, -- ^ Warnings declared in the module mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module @@ -2965,3 +2981,17 @@ nameOfObject other = pprPanic "nameOfObject" (ppr other) byteCodeOfObject :: Unlinked -> CompiledByteCode byteCodeOfObject (BCOs bc) = bc byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) + + +------------------------------------------- + +-- | A list of conlikes which represents a complete pattern match. +-- These arise from @COMPLETE@ signatures. +data CompleteMatch = CompleteMatch { + completeMatch :: [ConLike] + , completeMatchType :: TyCon + } + +instance Outputable CompleteMatch where + ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl + <+> dcolon <+> ppr ty diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index cbf7038187..c546e5c257 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -163,6 +163,7 @@ mkBootModDetailsTc hsc_env , md_anns = [] , md_exports = exports , md_vect_info = noVectInfo + , md_complete_sigs = [] }) } where @@ -318,6 +319,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_rules = imp_rules , mg_vect_info = vect_info , mg_anns = anns + , mg_complete_sigs = complete_sigs , mg_deps = deps , mg_foreign = foreign_stubs , mg_hpc_info = hpc_info @@ -425,7 +427,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod md_vect_info = tidy_vect_info, md_fam_insts = fam_insts, md_exports = exports, - md_anns = anns -- are already tidy + md_anns = anns, -- are already tidy + md_complete_sigs = complete_sigs }) } where diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 6c4abe047a..63715a08a8 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -636,6 +636,7 @@ data Token | ITunpack_prag SourceText | ITnounpack_prag SourceText | ITann_prag SourceText + | ITcomplete_prag SourceText | ITclose_prag | IToptions_prag String | ITinclude_prag String @@ -2716,7 +2717,7 @@ ignoredPrags = Map.fromList (map ignored pragmas) -- CFILES is a hugs-only thing. pragmas = options_pragmas ++ ["cfiles", "contract"] -oneWordPrags = Map.fromList([ +oneWordPrags = Map.fromList [ ("rules", rulePrag), ("inline", strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), @@ -2744,7 +2745,9 @@ oneWordPrags = Map.fromList([ ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), - ("ctype", strtoken (\s -> ITctype (SourceText s)))]) + ("ctype", strtoken (\s -> ITctype (SourceText s))), + ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))) + ] twoWordPrags = Map.fromList([ ("inline conlike", diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 222867483c..2b70fb7999 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -441,6 +441,7 @@ are the most common patterns, rewritten as regular expressions for clarity: '{-# OVERLAPPABLE' { L _ (IToverlappable_prag _) } '{-# OVERLAPS' { L _ (IToverlaps_prag _) } '{-# INCOHERENT' { L _ (ITincoherent_prag _) } + '{-# COMPLETE' { L _ (ITcomplete_prag _) } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -1672,6 +1673,10 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) } : {- empty -} { ([],Nothing) } | '::' atype { ([mu AnnDcolon $1],Just $2) } +opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } + : {- empty -} { ([], Nothing) } + | '::' gtycon { ([mu AnnDcolon $1], Just $2) } + sigtype :: { LHsType RdrName } : ctype { $1 } @@ -2248,6 +2253,13 @@ sigdecl :: { LHsDecl RdrName } | pattern_synonym_sig { sLL $1 $> . SigD . unLoc $ $1 } + | '{-# COMPLETE' con_list opt_tyconsig '#-}' + {% let (dcolon, tc) = $3 + in ams + (sLL $1 $> + (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc))) + ([ mo $1 ] ++ dcolon ++ [mc $4]) } + -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvar '#-}' {% ams ((sLL $1 $> $ SigD (InlineSig $3 @@ -3393,6 +3405,7 @@ getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) +getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x getDOCNEXT (L _ (ITdocCommentNext x)) = x getDOCPREV (L _ (ITdocCommentPrev x)) = x diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 2c9600427c..64a60c4841 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -7,7 +7,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -module RdrHsSyn ( +module RdrHsSyn ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkSpliceDecl, diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index c232e76ea0..f6a22f5df2 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -950,6 +950,13 @@ renameSig ctxt sig@(SCCFunSig st v s) = do { new_v <- lookupSigOccRn ctxt sig v ; return (SCCFunSig st new_v s, emptyFVs) } +-- COMPLETE Sigs can refer to imported IDs which is why we use +-- lookupLocatedOccRn rather than lookupSigOccRn +renameSig _ctxt (CompleteMatchSig s (L l bf) mty) + = do new_bf <- traverse lookupLocatedOccRn bf + new_mty <- traverse lookupLocatedOccRn mty + return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs) + ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) @@ -991,6 +998,9 @@ okHsSig ctxt (L _ sig) (SCCFunSig {}, HsBootCtxt {}) -> False (SCCFunSig {}, _) -> True + (CompleteMatchSig {}, TopSigCtxt {} ) -> True + (CompleteMatchSig {}, _) -> False + ------------------- findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] -- Check for duplicates on RdrName version, diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 2ad00d50e3..25c40618f2 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -37,7 +37,7 @@ import FamInstEnv( normaliseType ) import FamInst( tcGetFamInstEnvs ) import TyCon import TcType -import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder ) +import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe) import TysPrim import TysWiredIn( cTupleTyConName ) import Id @@ -62,6 +62,7 @@ import TcValidity (checkValidType) import Unique (getUnique) import UniqFM import qualified GHC.LanguageExtensions as LangExt +import ConLike import Control.Monad @@ -185,13 +186,115 @@ tcTopBinds binds sigs ; return (gbl, lcl) } ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids - ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } + ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs + ; traceTc "complete_matches" (ppr binds $$ ppr sigs) + ; traceTc "complete_matches" (ppr complete_matches) + + ; let { tcg_env' = tcg_env { tcg_imp_specs + = specs ++ tcg_imp_specs tcg_env + , tcg_complete_matches + = complete_matches + ++ tcg_complete_matches tcg_env } `addTypecheckedBinds` map snd binds' } ; return (tcg_env', tcl_env) } -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive LHsBinds + +-- Note [Typechecking Complete Matches] +-- Much like when a user bundled a pattern synonym, the result types of +-- all the constructors in the match pragma must be consistent. +-- +-- If we allowed pragmas with inconsistent types then it would be +-- impossible to ever match every constructor in the list and so +-- the pragma would be useless. + + + + + +-- This is only used in `tcCompleteSig`. We fold over all the conlikes, +-- this accumulator keeps track of the first `ConLike` with a concrete +-- return type. After fixing the return type, all other constructors with +-- a fixed return type must agree with this. +-- +-- The fields of `Fixed` cache the first conlike and its return type so +-- that that we can compare all the other conlikes to it. The conlike is +-- stored for error messages. +-- +-- `Nothing` in the case that the type is fixed by a type signature +data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon + +tcCompleteSigs :: [LSig Name] -> TcM [CompleteMatch] +tcCompleteSigs sigs = + let + doOne :: Sig Name -> TcM (Maybe CompleteMatch) + doOne c@(CompleteMatchSig _ lns mtc) + = fmap Just $ do + addErrCtxt (text "In" <+> ppr c) $ + case mtc of + Nothing -> infer_complete_match + Just tc -> check_complete_match tc + where + + checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) + + infer_complete_match = do + (res, cls) <- checkCLTypes AcceptAny + case res of + AcceptAny -> failWithTc ambiguousError + Fixed _ tc -> return $ CompleteMatch cls tc + + check_complete_match tc_name = do + ty_con <- tcLookupLocatedTyCon tc_name + (_, cls) <- checkCLTypes (Fixed Nothing ty_con) + return $ CompleteMatch cls ty_con + doOne _ = return Nothing + + ambiguousError :: SDoc + ambiguousError = + text "A type signature must be provided for a set of polymorphic" + <+> text "pattern synonyms." + + + -- See note [Typechecking Complete Matches] + checkCLType :: (CompleteSigType, [ConLike]) -> Located Name + -> TcM (CompleteSigType, [ConLike]) + checkCLType (cst, cs) n = do + cl <- addLocM tcLookupConLike n + let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl + res_ty_con = fst <$> splitTyConApp_maybe res_ty + case (cst, res_ty_con) of + (AcceptAny, Nothing) -> return (AcceptAny, cl:cs) + (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs) + (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs) + (Fixed mfcl tc, Just tc') -> + if tc == tc' + then return (Fixed mfcl tc, cl:cs) + else case mfcl of + Nothing -> + addErrCtxt (text "In" <+> ppr cl) $ + failWithTc typeSigErrMsg + Just cl -> failWithTc (errMsg cl) + where + typeSigErrMsg :: SDoc + typeSigErrMsg = + text "Couldn't match expected type" + <+> quotes (ppr tc) + <+> text "with" + <+> quotes (ppr tc') + + errMsg :: ConLike -> SDoc + errMsg fcl = + text "Cannot form a group of complete patterns from patterns" + <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl) + <+> text "as they match different type constructors" + <+> parens (quotes (ppr tc) + <+> text "resp." + <+> quotes (ppr tc')) + in mapMaybeM (addLocM doOne) sigs + tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv tcRecSelBinds (ValBindsOut binds sigs) = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 2d35e96851..28ca41b078 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -253,7 +253,7 @@ tcRnModuleTcRnM hsc_env hsc_src tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ; traceRn "rn4b: after exports" empty ; - -- Check that main is exported (must be after rnExports) + -- Check that main is exported (must be after tcRnExports) checkMainExported tcg_env ; -- Compare the hi-boot iface (if any) with the real thing diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 4388b4431c..3c6a6c432d 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -297,7 +297,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], tcg_top_loc = loc, - tcg_static_wc = static_wc_var + tcg_static_wc = static_wc_var, + tcg_complete_matches = [] } ; lcl_env = TcLclEnv { tcl_errs = errs_var, diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index a998e49632..9e3ed5b4aa 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -43,11 +43,11 @@ module TcRnTypes( IdBindingInfo(..), IsGroupClosed(..), SelfBootInfo(..), - pprTcTyThingCategory, pprPECategory, + pprTcTyThingCategory, pprPECategory, CompleteMatch(..), -- Desugaring types DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..), - DsMetaEnv, DsMetaVal(..), + DsMetaEnv, DsMetaVal(..), CompleteMatchMap, mkCompleteMatchMap, -- Template Haskell ThStage(..), SpliceType(..), PendingStuff(..), @@ -174,6 +174,7 @@ import FastString import qualified GHC.LanguageExtensions as LangExt import Fingerprint import Util +import UniqFM ( emptyUFM, addToUFM_C, UniqFM ) import Control.Monad (ap, liftM, msum) #if __GLASGOW_HASKELL__ > 710 @@ -181,12 +182,14 @@ import qualified Control.Monad.Fail as MonadFail #endif import Data.Set ( Set ) -import Data.Map ( Map ) +import Data.Map ( Map ) import Data.Dynamic ( Dynamic ) import Data.Typeable ( TypeRep ) import GHCi.Message import GHCi.RemoteTypes +import Data.List (foldl') + import qualified Language.Haskell.TH as TH -- | A 'NameShape' is a substitution on 'Name's that can be used @@ -376,8 +379,18 @@ data DsGblEnv -- exported entities of 'Data.Array.Parallel' iff -- '-XParallelArrays' was given; otherwise, empty , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' + , ds_complete_matches :: CompleteMatchMap + -- Additional complete pattern matches } +type CompleteMatchMap = UniqFM [CompleteMatch] + +mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap +mkCompleteMatchMap cms = foldl' insertMatch emptyUFM cms + where + insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap + insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] + instance ContainsModule DsGblEnv where extractModule = ds_mod @@ -651,9 +664,10 @@ data TcGblEnv tcg_top_loc :: RealSrcSpan, -- ^ The RealSrcSpan this module came from - tcg_static_wc :: TcRef WantedConstraints - -- ^ Wanted constraints of static forms. + tcg_static_wc :: TcRef WantedConstraints, + -- ^ Wanted constraints of static forms. -- See Note [Constraints in static forms]. + tcg_complete_matches :: [CompleteMatch] } -- NB: topModIdentity, not topModSemantic! diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 7c04dfe0b1..c7909ef6cb 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -58,7 +58,7 @@ initV hsc_env guts info thing_inside ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) ; (_, Just res) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) type_env - (mg_fam_inst_env guts) go + (mg_fam_inst_env guts) [] go ; case res of Nothing diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 52163b976f..2f322d5153 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -4512,6 +4512,10 @@ synonyms, there is no restriction on the right-hand side pattern. Pattern synonyms cannot be defined recursively. +:ref:`complete-pragma` can be specified in order to tell +the pattern match exhaustiveness checker that a set of pattern synonyms is +complete. + .. _patsyn-impexp: Import and export of pattern synonyms @@ -12759,6 +12763,80 @@ The ``{-# SOURCE #-}`` pragma is used only in ``import`` declarations, to break a module loop. It is described in detail in :ref:`mutual-recursion`. +.. _complete-pragma: + +``COMPLETE`` pragmas +-------------------- + +The ``COMPLETE`` pragma is used to inform the pattern match checker that a +certain set of patterns is complete and that any function which matches +on all the specified patterns is total. + +The most common usage of ``COMPLETE`` pragmas is with +:ref:`pattern-synonyms`. +On its own, the checker is very naive and assumes that any match involving +a pattern synonym will fail. As a result, any pattern match on a +pattern synonym is regarded as +incomplete unless the user adds a catch-all case. + +For example, the data types ``2 * A`` and ``A + A`` are isomorphic but some +computations are more naturally expressed in terms of one or the other. To +get the best of both worlds, we can choose one as our implementation and then +provide a set of pattern synonyms so that users can use the other representation +if they desire. We can then specify a ``COMPLETE`` pragma in order to +inform the pattern match checker that a function which matches on both ``LeftChoice`` +and ``RightChoice`` is total. + +:: + + data Choice a = Choice Bool a + + pattern LeftChoice :: a -> Choice a + pattern LeftChoice a = Choice False a + + pattern RightChoice :: a -> Choice a + pattern RightChoice a = Choice True a + + {-# COMPLETE LeftChoice, RightChoice #-} + + foo :: Choice Int -> Int + foo (LeftChoice n) = n * 2 + foo (RightChoice n) = n - 2 + +``COMPLETE`` pragmas are only used by the pattern match checker. If a function +definition matches on all the constructors specified in the pragma then the +compiler will produce no warning. + +``COMPLETE`` pragmas can contain any data constructors or pattern synonyms +which are in scope. Once defined, they are automatically imported and exported +from modules. ``COMPLETE`` pragmas should be thought of as asserting a universal +truth about a set of patterns and as a result, should not be used to silence +context specific incomplete match warnings. + +When specifing a ``COMPLETE`` pragma, the result types of all patterns must +be consistent with each other. This is a sanity check as it would be impossible +to match on all the patterns if the types were inconsistent. + +The result type must also be unambiguous. Usually this can be inferred but +when all the pattern synonyms in a group are polymorphic in the constructor +the user must provide a type signature. + +:: + class LL f where + go :: f a -> () + + instance LL [] where + go _ = () + + pattern T :: LL f => f a + pattern T <- (go -> ()) + + {-# COMPLETE T :: [] #-} + + -- No warning + foo :: [a] -> Int + foo T = 5 + .. _overlap-pragma: ``OVERLAPPING``, ``OVERLAPPABLE``, ``OVERLAPS``, and ``INCOHERENT`` pragmas diff --git a/testsuite/tests/pmcheck/complete_sigs/Completesig03.hs b/testsuite/tests/pmcheck/complete_sigs/Completesig03.hs new file mode 100644 index 0000000000..5c6752a6be --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/Completesig03.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall #-} +module Module where + +import Completesig03A + +foo :: A -> () +foo A = () diff --git a/testsuite/tests/pmcheck/complete_sigs/Completesig03.stderr b/testsuite/tests/pmcheck/complete_sigs/Completesig03.stderr new file mode 100644 index 0000000000..05dcb92856 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/Completesig03.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling Completesig03A ( Completesig03A.hs, Completesig03A.o ) +[2 of 2] Compiling Module ( Completesig03.hs, Completesig03.o ) diff --git a/testsuite/tests/pmcheck/complete_sigs/Completesig03A.hs b/testsuite/tests/pmcheck/complete_sigs/Completesig03A.hs new file mode 100644 index 0000000000..c1b83dfb06 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/Completesig03A.hs @@ -0,0 +1,5 @@ +module Completesig03A where + +data A = A | B + +{-# COMPLETE A #-} diff --git a/testsuite/tests/pmcheck/complete_sigs/Makefile b/testsuite/tests/pmcheck/complete_sigs/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/pmcheck/complete_sigs/all.T b/testsuite/tests/pmcheck/complete_sigs/all.T new file mode 100644 index 0000000000..4e8c33d9be --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/all.T @@ -0,0 +1,15 @@ +test('completesig01', normal, compile, ['']) +test('completesig02', normal, compile, ['']) +test('Completesig03', normal, multimod_compile, ['Completesig03', '-Wall']) +test('completesig04', normal, compile_fail, ['']) +test('completesig05', normal, compile, ['']) +test('completesig06', normal, compile, ['']) +test('completesig07', normal, compile, ['']) +test('completesig08', normal, compile, ['']) +test('completesig09', normal, compile, ['']) +test('completesig10', normal, compile, ['']) +test('completesig11', normal, compile, ['']) +test('completesig12', normal, compile, ['']) +test('completesig13', normal, compile, ['']) +test('completesig14', normal, compile, ['']) +test('completesig15', normal, compile_fail, ['']) diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig01.hs b/testsuite/tests/pmcheck/complete_sigs/completesig01.hs new file mode 100644 index 0000000000..9598aa6462 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig01.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} +module Simple where + +pattern Foo :: () +pattern Foo = () + +a :: () -> () +a Foo = () + +data A = B | C | D + +{-# COMPLETE Foo #-} +{-# COMPLETE B,C #-} +{-# COMPLETE B #-} + +b :: A -> A +b B = B +b C = C diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig02.hs b/testsuite/tests/pmcheck/complete_sigs/completesig02.hs new file mode 100644 index 0000000000..282378b2de --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig02.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} +module Empty where + +pattern Foo :: () +pattern Foo = () + +a :: () -> () +a Foo = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig02.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig02.stderr new file mode 100644 index 0000000000..25b24fd836 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig02.stderr @@ -0,0 +1,4 @@ + +completesig02.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘a’: Patterns not matched: _ diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig04.hs b/testsuite/tests/pmcheck/complete_sigs/completesig04.hs new file mode 100644 index 0000000000..0d8eb81660 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig04.hs @@ -0,0 +1,3 @@ +module TyMismatch where + +{-# COMPLETE Just, Left #-} diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig04.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig04.stderr new file mode 100644 index 0000000000..b72cf6e9b4 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig04.stderr @@ -0,0 +1,4 @@ + +completesig04.hs:3:1: error: + • Cannot form a group of complete patterns from patterns ‘Just’ and ‘Left’ as they match different type constructors (‘Maybe’ resp. ‘Either’) + • In {-# COMPLETE Just, Left #-} diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig05.hs b/testsuite/tests/pmcheck/complete_sigs/completesig05.hs new file mode 100644 index 0000000000..c277604714 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig05.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Wall #-} +module Completesig05 where + +-- Matching against multiple arguments + +data T = A | B | C +data S = D | E | F + +{-# COMPLETE A, B #-} +{-# COMPLETE D #-} + +match :: T -> S -> () +match A D = () +match B D = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig06.hs b/testsuite/tests/pmcheck/complete_sigs/completesig06.hs new file mode 100644 index 0000000000..c3f1c75807 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig06.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wall #-} +module Completesig06 where + +-- Some non-exhaustive examples + +data T = A | B | C +data S = D | E | F + +{-# COMPLETE A, B #-} +{-# COMPLETE D #-} + +m1 :: T -> () +m1 A = () + +m2 :: T -> () +m2 B = () +m2 C = () + +m3 :: T -> () +m3 C = () + +m4 :: T -> S -> () +m4 A E = () +m4 A F = () +m4 B F = () +m4 B E = () + +m5 :: T -> S -> () +m5 C D = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig06.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig06.stderr new file mode 100644 index 0000000000..50bc9bfebf --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig06.stderr @@ -0,0 +1,29 @@ + +completesig06.hs:13:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m1’: Patterns not matched: B + +completesig06.hs:16:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m2’: Patterns not matched: A + +completesig06.hs:20:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m3’: + Patterns not matched: + A + B + +completesig06.hs:23:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m4’: + Patterns not matched: + B D + A D + +completesig06.hs:29:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m5’: + Patterns not matched: + A _ + B _ diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig07.hs b/testsuite/tests/pmcheck/complete_sigs/completesig07.hs new file mode 100644 index 0000000000..fb155a5460 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig07.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wall #-} +module Completesig07 where + +-- Some overlapping examples + +data T = A | B | C +data S = D | E | F + +{-# COMPLETE A, B #-} +{-# COMPLETE D #-} + +m1 :: T -> () +m1 A = () +m1 A = () +m1 B = () + +m2 :: T -> S -> () +m2 A D = () +m2 B D = () +m2 A D = () + +m3 :: T -> () +m3 C = () +m3 C = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig07.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig07.stderr new file mode 100644 index 0000000000..bf5edb9205 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig07.stderr @@ -0,0 +1,11 @@ + +completesig07.hs:23:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m3’: + Patterns not matched: + A + B + +completesig07.hs:24:1: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘m3’: m3 C = ... diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig08.hs b/testsuite/tests/pmcheck/complete_sigs/completesig08.hs new file mode 100644 index 0000000000..323b13984c --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig08.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -Wall #-} +module Completesig08 where + +-- Some redundant examples + +data T = A | B | C +data S = D | E | F + +{-# COMPLETE A, B #-} +{-# COMPLETE D #-} + +m1 :: T -> () +m1 A = () +m1 B = () +m1 C = () + +m2 :: T -> S -> () +m2 A D = () +m2 B D = () +m2 C D = () + +m3 :: T -> S -> () +m3 A D = () +m3 B D = () +m3 A E = () +m3 A F = () + +m4 :: S -> () +m4 D = () +m4 E = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig09.hs b/testsuite/tests/pmcheck/complete_sigs/completesig09.hs new file mode 100644 index 0000000000..b02aefede4 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig09.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wall #-} +module Completesig08 where + +-- Nested matching + +data T = A S | B +data S = D | E + +{-# COMPLETE A #-} +{-# COMPLETE D #-} + +m1 :: T -> () +m1 (A D) = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig10.hs b/testsuite/tests/pmcheck/complete_sigs/completesig10.hs new file mode 100644 index 0000000000..66c446b6ef --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig10.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -Wall #-} +module Completesig10 where + +-- Multiple competing COMPLETE sigs AHHH!! + +data T = A | B | C | D | E + +{-# COMPLETE A,B #-} +{-# COMPLETE C,D #-} + +-- Completely overlapping +m1 :: T -> () +m1 A = () +m1 B = () +m1 C = () +m1 D = () + +-- Incomplete overlap +m2 :: T -> () +m2 B = () +m2 D = () + +-- Redudant incomplete overlap +m3 :: T -> () +m3 B = () +m3 C = () +m3 D = () + +-- One matches + +m4 :: T -> () +m4 C = () +m4 D = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig10.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig10.stderr new file mode 100644 index 0000000000..3d97bb47d7 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig10.stderr @@ -0,0 +1,4 @@ + +completesig10.hs:20:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m2’: Patterns not matched: A diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig11.hs b/testsuite/tests/pmcheck/complete_sigs/completesig11.hs new file mode 100644 index 0000000000..69a386ca66 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig11.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE PatternSynonyms #-} +module Completesig11 where + +data T = A | B | C +{-# COMPLETE A,B #-} +{-# COMPLETE A,C #-} + +pattern BS :: T +pattern BS = B +{-# COMPLETE A,BS #-} + +m1 :: T -> () +m1 A = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig11.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig11.stderr new file mode 100644 index 0000000000..8107071008 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig11.stderr @@ -0,0 +1,4 @@ + +completesig11.hs:14:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘m1’: Patterns not matched: BS diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig12.hs b/testsuite/tests/pmcheck/complete_sigs/completesig12.hs new file mode 100644 index 0000000000..a6bf400b42 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig12.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} +{-# OPTIONS_GHC -Wall #-} +module Completesig11 where +data G a where + G1' :: G Int + G2' :: G Bool + +pattern G1 :: () => (a ~ Int) => G a +pattern G1 = G1' + +pattern G2 :: () => (a ~ Bool) => G a +pattern G2 = G2' + +{-# COMPLETE G1, G2 #-} + +fa :: G a -> Int -- exhaustive function +fa G1 = 1 +fa G2 = 2 + +fb :: G Int -> Int -- exhaustive function +fb G1 = 1 +-- fb G2 = 2 -- inaccessible clause diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig13.hs b/testsuite/tests/pmcheck/complete_sigs/completesig13.hs new file mode 100644 index 0000000000..ac87baf9f0 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig13.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall #-} +module Completesig11 where + +class LL f where + go :: f a -> () + +instance LL [] where + go _ = () + +pattern T :: LL f => f a +pattern T <- (go -> ()) + +{-# COMPLETE T :: [] #-} + +foo :: [a] -> Int +foo T = 5 diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig14.hs b/testsuite/tests/pmcheck/complete_sigs/completesig14.hs new file mode 100644 index 0000000000..00331c9370 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig14.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall #-} +module Completesig11 where + +data A = A | B + +{-# COMPLETE A, B #-} + +foo :: A -> () +foo A = () +foo B = () +foo A = () diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig14.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig14.stderr new file mode 100644 index 0000000000..06e9da88ce --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig14.stderr @@ -0,0 +1,4 @@ + +completesig14.hs:11:1: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘foo’: foo A = ... diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig15.hs b/testsuite/tests/pmcheck/complete_sigs/completesig15.hs new file mode 100644 index 0000000000..5936379aa7 --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig15.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module Completesig15 where + +class C f where + foo :: f a -> () + +pattern P :: C f => f a +pattern P <- (foo -> ()) + +{-# COMPLETE P #-} diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig15.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig15.stderr new file mode 100644 index 0000000000..3bff495ebe --- /dev/null +++ b/testsuite/tests/pmcheck/complete_sigs/completesig15.stderr @@ -0,0 +1,4 @@ + +completesig15.hs:12:1: error: + • A type signature must be provided for a set of polymorphic pattern synonyms. + • In {-# COMPLETE P #-} diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T index 94d351e07a..3f4e0c8af8 100644 --- a/testsuite/tests/pmcheck/should_compile/all.T +++ b/testsuite/tests/pmcheck/should_compile/all.T @@ -40,7 +40,7 @@ test('T11303', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping- test('T11276', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS']) test('T11303b', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS']) test('T11374', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS']) -test('T11195', compile_timeout_multiplier(0.40), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS']) +test('T11195', compile_timeout_multiplier(0.40), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M2G -RTS']) # Other tests test('pmc001', [], compile, |