[Git][ghc/ghc][wip/T14422] PmCheck: Disattach COMPLETE pragmas from TyCons
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Sep 2 16:48:05 UTC 2020
Sebastian Graf pushed to branch wip/T14422 at Glasgow Haskell Compiler / GHC
Commits:
db173247 by Sebastian Graf at 2020-09-02T18:46:23+02:00
PmCheck: Disattach COMPLETE pragmas from TyCons
By not attaching COMPLETE pragmas with a particular TyCon and instead
assume that every COMPLETE pragma is applicable everywhere, we can
drastically simplify the logic that tries to initialise available
COMPLETE sets of a variable during the pattern-match checking process,
as well as fixing a few bugs.
Of course, we have to make sure not to report any of the
ill-typed/unrelated COMPLETE sets, which came up in a few regression
tests.
In doing so, we fix #17207, #18277 and, most prominently, #14422.
- - - - -
23 changed files:
- compiler/GHC/Driver/Types.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/PmCheck/Oracle.hs
- compiler/GHC/HsToCore/PmCheck/Types.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/IfaceToCore.hs-boot
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Types/Unique/DFM.hs
- docs/users_guide/exts/pragmas.rst
- testsuite/tests/pmcheck/complete_sigs/completesig15.hs → testsuite/tests/pmcheck/complete_sigs/T14422.hs
- + testsuite/tests/pmcheck/complete_sigs/T18277.hs
- testsuite/tests/pmcheck/complete_sigs/all.T
- testsuite/tests/pmcheck/complete_sigs/completesig04.hs
- testsuite/tests/pmcheck/complete_sigs/completesig04.stderr
- − testsuite/tests/pmcheck/complete_sigs/completesig15.stderr
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -61,7 +61,7 @@ module GHC.Driver.Types (
lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule,
PackageInstEnv, PackageFamInstEnv, PackageRuleBase,
- PackageCompleteMatchMap,
+ PackageCompleteMatches,
mkSOName, mkHsSOName, soExt,
@@ -146,8 +146,7 @@ module GHC.Driver.Types (
handleFlagWarnings, printOrThrowWarnings,
-- * COMPLETE signature
- CompleteMatch(..), CompleteMatchMap,
- mkCompleteMatchMap, extendCompleteMatchMap,
+ ConLikeSet, CompleteMatch, CompleteMatches,
-- * Exstensible Iface fields
ExtensibleFields(..), FieldName,
@@ -734,7 +733,7 @@ lookupIfaceByModule hpt pit mod
-- of its own, but it doesn't seem worth the bother.
hptCompleteSigs :: HscEnv -> [CompleteMatch]
-hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details)
+hptCompleteSigs = hptAllThings (md_complete_matches . hm_details)
-- | Find all the instance declarations (of classes and families) from
-- the Home Package Table filtered by the provided predicate function.
@@ -1092,7 +1091,7 @@ data ModIface_ (phase :: ModIfacePhase)
-- itself) but imports some trustworthy modules from its own
-- package (which does require its own package be trusted).
-- See Note [Trust Own Package] in GHC.Rename.Names
- mi_complete_sigs :: [IfaceCompleteMatch],
+ mi_complete_matches :: [IfaceCompleteMatch],
mi_doc_hdr :: Maybe HsDocString,
-- ^ Module header.
@@ -1183,7 +1182,7 @@ instance Binary ModIface where
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg,
- mi_complete_sigs = complete_sigs,
+ mi_complete_matches = complete_matches,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
@@ -1229,7 +1228,7 @@ instance Binary ModIface where
put_ bh hpc_info
put_ bh trust
put_ bh trust_pkg
- put_ bh complete_sigs
+ put_ bh complete_matches
lazyPut bh doc_hdr
lazyPut bh decl_docs
lazyPut bh arg_docs
@@ -1262,7 +1261,7 @@ instance Binary ModIface where
hpc_info <- get bh
trust <- get bh
trust_pkg <- get bh
- complete_sigs <- get bh
+ complete_matches <- get bh
doc_hdr <- lazyGet bh
decl_docs <- lazyGet bh
arg_docs <- lazyGet bh
@@ -1286,7 +1285,7 @@ instance Binary ModIface where
mi_trust = trust,
mi_trust_pkg = trust_pkg,
-- And build the cached values
- mi_complete_sigs = complete_sigs,
+ mi_complete_matches = complete_matches,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
@@ -1331,7 +1330,7 @@ emptyPartialModIface mod
mi_hpc = False,
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False,
- mi_complete_sigs = [],
+ mi_complete_matches = [],
mi_doc_hdr = Nothing,
mi_decl_docs = emptyDeclDocMap,
mi_arg_docs = emptyArgDocMap,
@@ -1387,7 +1386,7 @@ 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_complete_sigs :: [CompleteMatch]
+ md_complete_matches :: [CompleteMatch]
-- ^ Complete match pragmas for this module
}
@@ -1400,7 +1399,7 @@ emptyModDetails
md_rules = [],
md_fam_insts = [],
md_anns = [],
- md_complete_sigs = [] }
+ md_complete_matches = [] }
-- | Records the modules directly imported by a module for extracting e.g.
-- usage information, and also to give better error message
@@ -1463,7 +1462,7 @@ data ModGuts
-- ^ Files to be compiled with the C compiler
mg_warns :: !Warnings, -- ^ Warnings declared in the module
mg_anns :: [Annotation], -- ^ Annotations declared in this module
- mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
+ mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches
mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module
mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module
@@ -2684,7 +2683,7 @@ type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
type PackageFamInstEnv = FamInstEnv
type PackageAnnEnv = AnnEnv
-type PackageCompleteMatchMap = CompleteMatchMap
+type PackageCompleteMatches = CompleteMatches
-- | Information about other packages that we have slurped in by reading
-- their interface files
@@ -2746,8 +2745,8 @@ data ExternalPackageState
-- from all the external-package modules
eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated
-- from all the external-package modules
- eps_complete_matches :: !PackageCompleteMatchMap,
- -- ^ The total 'CompleteMatchMap' accumulated
+ eps_complete_matches :: !PackageCompleteMatches,
+ -- ^ The total 'CompleteMatches' accumulated
-- from all the external-package modules
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external
@@ -3203,36 +3202,13 @@ byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
-------------------------------------------
+type ConLikeSet = UniqDSet ConLike
+
-- | A list of conlikes which represents a complete pattern match.
-- These arise from @COMPLETE@ signatures.
+type CompleteMatch = ConLikeSet
--- See Note [Implementation of COMPLETE signatures]
-data CompleteMatch = CompleteMatch {
- completeMatchConLikes :: [Name]
- -- ^ The ConLikes that form a covering family
- -- (e.g. Nothing, Just)
- , completeMatchTyCon :: Name
- -- ^ The TyCon that they cover (e.g. Maybe)
- }
-
-instance Outputable CompleteMatch where
- ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl
- <+> dcolon <+> ppr ty
-
--- | A map keyed by the 'completeMatchTyCon' which has type Name.
-
--- See Note [Implementation of COMPLETE signatures]
-type CompleteMatchMap = UniqFM Name [CompleteMatch]
-
-mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap
-mkCompleteMatchMap = extendCompleteMatchMap emptyUFM
-
-extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch]
- -> CompleteMatchMap
-extendCompleteMatchMap = foldl' insertMatch
- where
- insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap
- insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c]
+type CompleteMatches = [CompleteMatch]
{-
Note [Implementation of COMPLETE signatures]
@@ -3252,33 +3228,14 @@ function, it gives rise to a total function. An example is:
booleanToInt F = 0
booleanToInt T = 1
-COMPLETE sets are represented internally in GHC with the CompleteMatch data
-type. For example, {-# COMPLETE F, T #-} would be represented as:
-
- CompleteMatch { complateMatchConLikes = [F, T]
- , completeMatchTyCon = Boolean }
-
-Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the
-cases in which it's ambiguous, you can also explicitly specify it in the source
-language by writing this:
-
- {-# COMPLETE F, T :: Boolean #-}
-
-For efficiency purposes, GHC collects all of the CompleteMatches that it knows
-about into a CompleteMatchMap, which is a map that is keyed by the
-completeMatchTyCon. In other words, you could have a multiple COMPLETE sets
-for the same TyCon:
-
- {-# COMPLETE F, T1 :: Boolean #-}
- {-# COMPLETE F, T2 :: Boolean #-}
+COMPLETE sets are represented internally in GHC a set of 'ConLike's. For
+example, {-# COMPLETE F, T #-} would be represented as:
-And looking up the values in the CompleteMatchMap associated with Boolean
-would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean].
-dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup.
+ {F, T}
-Also see Note [Typechecking Complete Matches] in GHC.Tc.Gen.Bind for a more detailed
-explanation for how GHC ensures that all the conlikes in a COMPLETE set are
-consistent.
+GHC collects all COMPLETE pragmas from the current module and from imports
+into a field in the DsM environment, which can be accessed with
+dsGetCompleteMatches from "GHC.HsToCore.Monad".
-}
-- | Foreign language of the phase if the phase deals with a foreign code
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -224,7 +224,7 @@ deSugar hsc_env
mg_modBreaks = modBreaks,
mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports,
- mg_complete_sigs = complete_matches,
+ mg_complete_matches = complete_matches,
mg_doc_hdr = doc_hdr,
mg_decl_docs = decl_docs,
mg_arg_docs = arg_docs
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -88,7 +88,6 @@ import GHC.Driver.Ppr
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Data.FastString
-import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly )
import GHC.Types.Literal ( mkLitString )
import GHC.Types.CostCentre.State
@@ -210,13 +209,15 @@ mkDsEnvsFromTcGbl :: MonadIO m
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
= do { cc_st_var <- liftIO $ newIORef newCostCentreState
+ ; eps <- liftIO $ hscEPS hsc_env
; let dflags = hsc_dflags hsc_env
this_mod = tcg_mod tcg_env
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 = hptCompleteSigs hsc_env
- ++ tcg_complete_matches tcg_env
+ !complete_matches = hptCompleteSigs hsc_env -- from the home package
+ ++ tcg_complete_matches tcg_env -- from the current module
+ ++ eps_complete_matches eps -- from imports
; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var cc_st_var complete_matches
}
@@ -239,13 +240,15 @@ initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts hsc_env guts thing_inside
= do { cc_st_var <- newIORef newCostCentreState
; msg_var <- newIORef emptyMessages
+ ; eps <- liftIO $ hscEPS hsc_env
; let dflags = hsc_dflags hsc_env
type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
rdr_env = mg_rdr_env guts
fam_inst_env = mg_fam_inst_env guts
this_mod = mg_module guts
- complete_matches = hptCompleteSigs hsc_env
- ++ mg_complete_sigs guts
+ !complete_matches = hptCompleteSigs hsc_env -- from the home package
+ ++ mg_complete_matches guts -- from the current module
+ ++ eps_complete_matches eps -- from imports
bindsToIds (NonRec v _) = [v]
bindsToIds (Rec binds) = map fst binds
@@ -281,7 +284,7 @@ initTcDsForSolver thing_inside
thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
- -> IORef Messages -> IORef CostCentreState -> [CompleteMatch]
+ -> IORef Messages -> IORef CostCentreState -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
complete_matches
@@ -290,7 +293,6 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
NotBoot
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)
@@ -299,7 +301,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
(mkHomeUnitFromFlags dflags)
rdr_env
, ds_msgs = msg_var
- , ds_complete_matches = completeMatchMap
+ , ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
@@ -533,18 +535,9 @@ dsGetFamInstEnvs
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
--- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
-dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
-dsGetCompleteMatches tc = do
- eps <- getEps
- env <- getGblEnv
- -- We index into a UniqFM from Name -> elt, for tyCon it holds that
- -- getUnique (tyConName tc) == getUnique tc. So we lookup using the
- -- unique directly instead.
- let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc)
- eps_matches_list = lookup_completes $ eps_complete_matches eps
- env_matches_list = lookup_completes $ ds_complete_matches env
- return $ eps_matches_list ++ env_matches_list
+-- | The @COMPLETE@ pragmas that are in scope.
+dsGetCompleteMatches :: DsM CompleteMatches
+dsGetCompleteMatches = ds_complete_matches <$> getGblEnv
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
=====================================
compiler/GHC/HsToCore/PmCheck/Oracle.hs
=====================================
@@ -66,13 +66,13 @@ import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Tc.Solver (tcNormalise, tcCheckSatisfiability)
import GHC.Core.Unify (tcMatchTy)
-import GHC.Tc.Types (completeMatchConLikes)
import GHC.Core.Coercion
import GHC.Utils.Monad hiding (foldlM)
import GHC.HsToCore.Monad hiding (foldlM)
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
+import Control.Applicative ((<|>))
import Control.Monad (guard, mzero, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict
@@ -80,7 +80,6 @@ import Data.Bifunctor (second)
import Data.Either (partitionEithers)
import Data.Foldable (foldlM, minimumBy, toList)
import Data.List (find)
-import qualified Data.List.NonEmpty as NonEmpty
import Data.Ord (comparing)
import qualified Data.Semigroup as Semigroup
import Data.Tuple (swap)
@@ -105,11 +104,54 @@ mkPmId ty = getUniqueM >>= \unique ->
-----------------------------------------------
-- * Caching possible matches of a COMPLETE set
-markMatched :: ConLike -> PossibleMatches -> PossibleMatches
-markMatched _ NoPM = NoPM
-markMatched con (PM ms) = PM (del_one_con con <$> ms)
+-- | Traverse the COMPLETE sets of 'ResidualCompleteMatches'.
+trvRcm :: Applicative f => (ConLikeSet -> f ConLikeSet) -> ResidualCompleteMatches -> f ResidualCompleteMatches
+trvRcm f (RCM vanilla pragmas) = RCM <$> traverse f vanilla
+ <*> traverse (traverse f) pragmas
+-- | Update the COMPLETE sets of 'ResidualCompleteMatches'.
+updRcm :: (ConLikeSet -> ConLikeSet) -> ResidualCompleteMatches -> ResidualCompleteMatches
+updRcm f (RCM vanilla pragmas) = RCM (f <$> vanilla) (fmap f <$> pragmas)
+
+-- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data
+-- 'TyCon'.
+-- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@
+vanillaCompleteMatchTC :: TyCon -> Maybe ConLikeSet
+vanillaCompleteMatchTC tc =
+ let -- | TYPE acts like an empty data type on the term-level (#14086), but
+ -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a
+ -- special case.
+ mb_dcs | tc == tYPETyCon = Just []
+ | otherwise = tyConDataCons_maybe tc
+ in mkUniqDSet . map RealDataCon <$> mb_dcs
+
+-- | Initialise from 'dsGetCompleteMatches' (containing all COMPLETE pragmas)
+-- if the given 'ResidualCompleteMatches' were empty.
+addCompleteMatches :: ResidualCompleteMatches -> DsM ResidualCompleteMatches
+addCompleteMatches (RCM v Nothing) = RCM v . Just <$> dsGetCompleteMatches
+addCompleteMatches rcm = pure rcm
+
+-- | Adds the declared 'CompleteMatches' from COMPLETE pragmas, as well as the
+-- vanilla data defn if it is a 'DataCon'.
+addConLikeMatches :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
+addConLikeMatches (RealDataCon dc) rcm = addTyConMatches (dataConTyCon dc) rcm
+addConLikeMatches (PatSynCon _) rcm = addCompleteMatches rcm
+
+-- | Adds
+-- * the 'CompleteMatches' from COMPLETE pragmas
+-- * and the /vanilla/ 'CompleteMatch' from the data 'TyCon'
+-- to the 'ResidualCompleteMatches', if not already present.
+addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
+addTyConMatches tc rcm = add_tc_match <$> addCompleteMatches rcm
where
- del_one_con = flip delOneFromUniqDSet
+ -- | Add the vanilla COMPLETE set from the data defn, if any. But only if
+ -- it's not already present.
+ add_tc_match rcm
+ = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc}
+
+markMatched :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
+markMatched cl rcm = do
+ rcm' <- addConLikeMatches cl rcm
+ pure $ updRcm (flip delOneFromUniqDSet cl) rcm'
---------------------------------------------------
-- * Instantiating constructors, types and evidence
@@ -492,7 +534,7 @@ tyOracle (TySt inert) cts
-- | A 'SatisfiabilityCheck' based on new type-level constraints.
-- Returns a new 'Nabla' if the new constraints are compatible with existing
-- ones. Doesn't bother calling out to the type oracle if the bag of new type
--- constraints was empty. Will only recheck 'PossibleMatches' in the term oracle
+-- constraints was empty. Will only recheck 'ResidualCompleteMatches' in the term oracle
-- for emptiness if the first argument is 'True'.
tyIsSatisfiable :: Bool -> Bag PredType -> SatisfiabilityCheck
tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \nabla ->
@@ -544,10 +586,10 @@ of a PatSynCon (Just42,[]), this solution is incomparable to both Nothing and
Just. Hence we retain the info in vi_neg, which eventually allows us to detect
the complete pattern match.
-The Pos/Neg invariant extends to vi_cache, which stores essentially positive
-information. We make sure that vi_neg and vi_cache never overlap. This isn't
-strictly necessary since vi_cache is just a cache, so doesn't need to be
-accurate: Every suggestion of a possible ConLike from vi_cache might be
+The Pos/Neg invariant extends to vi_rcm, which stores essentially positive
+information. We make sure that vi_neg and vi_rcm never overlap. This isn't
+strictly necessary since vi_rcm is just a cache, so doesn't need to be
+accurate: Every suggestion of a possible ConLike from vi_rcm might be
refutable by the type oracle anyway. But it helps to maintain sanity while
debugging traces.
@@ -568,7 +610,7 @@ The term oracle state is never obviously (i.e., without consulting the type
oracle) contradictory. This implies a few invariants:
* Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.
This is implied by the Note [Pos/Neg invariant].
-* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_cache to
+* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_rcm to
detect this, but we could just compare whole COMPLETE sets to vi_neg every
time, if it weren't for performance.
@@ -624,13 +666,16 @@ tmIsSatisfiable new_tm_cs = SC $ \nabla -> runMaybeT $ foldlM addTmCt nabla new_
-----------------------
-- * Looking up VarInfo
+emptyRCM :: ResidualCompleteMatches
+emptyRCM = RCM Nothing Nothing
+
emptyVarInfo :: Id -> VarInfo
-- We could initialise @bot@ to @Just False@ in case of an unlifted type here,
-- but it's cleaner to let the user of the constraint solver take care of this.
-- After all, there are also strict fields, the unliftedness of which isn't
-- evident in the type. So treating unlifted types here would never be
-- sufficient anyway.
-emptyVarInfo x = VI (idType x) [] emptyPmAltConSet MaybeBot NoPM
+emptyVarInfo x = VI (idType x) [] emptyPmAltConSet MaybeBot emptyRCM
lookupVarInfo :: TmState -> Id -> VarInfo
-- (lookupVarInfo tms x) tells what we know about 'x'
@@ -656,85 +701,6 @@ lookupVarInfoNT ts x = case lookupVarInfo ts x of
| isNewDataCon dc = Just y
go _ = Nothing
-initPossibleMatches :: TyState -> VarInfo -> DsM VarInfo
-initPossibleMatches ty_st vi at VI{ vi_ty = ty, vi_cache = NoPM } = do
- -- New evidence might lead to refined info on ty, in turn leading to discovery
- -- of a COMPLETE set.
- res <- pmTopNormaliseType ty_st ty
- let ty' = normalisedSourceType res
- case splitTyConApp_maybe ty' of
- Nothing -> pure vi{ vi_ty = ty' }
- Just (tc, [_])
- | tc == tYPETyCon
- -- TYPE acts like an empty data type on the term-level (#14086), but
- -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a
- -- special case.
- -> pure vi{ vi_ty = ty', vi_cache = PM (pure emptyUniqDSet) }
- Just (tc, tc_args) -> do
- -- See Note [COMPLETE sets on data families]
- (tc_rep, tc_fam) <- case tyConFamInst_maybe tc of
- Just (tc_fam, _) -> pure (tc, tc_fam)
- Nothing -> do
- env <- dsGetFamInstEnvs
- let (tc_rep, _tc_rep_args, _co) = tcLookupDataFamInst env tc tc_args
- pure (tc_rep, tc)
- -- Note that the common case here is tc_rep == tc_fam
- let mb_rdcs = map RealDataCon <$> tyConDataCons_maybe tc_rep
- let rdcs = maybeToList mb_rdcs
- -- NB: tc_fam, because COMPLETE sets are associated with the parent data
- -- family TyCon
- pragmas <- dsGetCompleteMatches tc_fam
- let fams = mapM dsLookupConLike . completeMatchConLikes
- pscs <- mapM fams pragmas
- -- pprTrace "initPossibleMatches" (ppr ty $$ ppr ty' $$ ppr tc_rep <+> ppr tc_fam <+> ppr tc_args $$ ppr (rdcs ++ pscs)) (return ())
- case NonEmpty.nonEmpty (rdcs ++ pscs) of
- Nothing -> pure vi{ vi_ty = ty' } -- Didn't find any COMPLETE sets
- Just cs -> pure vi{ vi_ty = ty', vi_cache = PM (mkUniqDSet <$> cs) }
-initPossibleMatches _ vi = pure vi
-
-{- Note [COMPLETE sets on data families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-User-defined COMPLETE sets involving data families are attached to the family
-TyCon, whereas the built-in COMPLETE set is attached to a data family instance's
-representation TyCon. This matters for COMPLETE sets involving both DataCons
-and PatSyns (from #17207):
-
- data family T a
- data family instance T () = A | B
- pattern C = B
- {-# COMPLETE A, C #-}
- f :: T () -> ()
- f A = ()
- f C = ()
-
-The match on A is actually wrapped in a CoPat, matching impedance between T ()
-and its representation TyCon, which we translate as
- at x | let y = x |> co, A <- y@ in PmCheck.
-
-Which TyCon should we use for looking up the COMPLETE set? The representation
-TyCon from the match on A would only reveal the built-in COMPLETE set, while the
-data family TyCon would only give the user-defined one. But when initialising
-the PossibleMatches for a given Type, we want to do so only once, because
-merging different COMPLETE sets after the fact is very complicated and possibly
-inefficient.
-
-So in fact, we just *drop* the coercion arising from the CoPat when handling
-handling the constraint @y ~ x |> co@ in addCoreCt, just equating @y ~ x at .
-We then handle the fallout in initPossibleMatches, which has to get a hand at
-both the representation TyCon tc_rep and the parent data family TyCon tc_fam.
-It considers three cases after having established that the Type is a TyConApp:
-
-1. The TyCon is a vanilla data type constructor
-2. The TyCon is tc_rep
-3. The TyCon is tc_fam
-
-1. is simple and subsumed by the handling of the other two.
-We check for case 2. by 'tyConFamInst_maybe' and get the tc_fam out.
-Otherwise (3.), we try to lookup the data family instance at that particular
-type to get out the tc_rep. In case 1., this will just return the original
-TyCon, so tc_rep = tc_fam afterwards.
--}
-
------------------------------------------------
-- * Exported utility functions querying 'Nabla'
@@ -897,11 +863,7 @@ addNotConCt :: Nabla -> Id -> PmAltCon -> MaybeT DsM Nabla
addNotConCt _ _ (PmAltConLike (RealDataCon dc))
| isNewDataCon dc = mzero -- (3) in Note [Coverage checking Newtype matches]
addNotConCt nabla at MkNabla{ nabla_tm_st = ts@(TmSt env reps) } x nalt = do
- -- For good performance, it's important to initPossibleMatches here.
- -- Otherwise we can't mark nalt as matched later on, incurring unnecessary
- -- inhabitation tests for nalt.
- vi@(VI _ pos neg _ pm) <- lift $ initPossibleMatches (nabla_ty_st nabla)
- (lookupVarInfo ts x)
+ let vi@(VI _ pos neg _ rcm) = lookupVarInfo ts x
-- 1. Bail out quickly when nalt contradicts a solution
let contradicts nalt (cl, _tvs, _args) = eqPmAltCon cl nalt == Equal
guard (not (any (contradicts nalt) pos))
@@ -917,9 +879,11 @@ addNotConCt nabla at MkNabla{ nabla_tm_st = ts@(TmSt env reps) } x nalt = do
let vi1 = vi{ vi_neg = neg', vi_bot = IsNotBot }
-- 3. Make sure there's at least one other possible constructor
vi2 <- case nalt of
- PmAltConLike cl
- -> ensureInhabited nabla vi1{ vi_cache = markMatched cl pm }
- _ -> pure vi1
+ PmAltConLike cl -> do
+ rcm' <- lift (markMatched cl rcm)
+ ensureInhabited nabla vi1{ vi_rcm = rcm' }
+ _ ->
+ pure vi1
pure nabla{ nabla_tm_st = TmSt (setEntrySDIE env x vi2) reps }
hasRequiredTheta :: PmAltCon -> Bool
@@ -963,13 +927,15 @@ storing required arguments along with the PmAltConLike in 'vi_neg'.
-- its result type. Rather easy for DataCons, but not so much for PatSynCons.
-- See Note [Pattern synonym result type] in "GHC.Core.PatSyn".
guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type]
-guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do
+guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon dc) = do
(tc, tc_args) <- splitTyConApp_maybe res_ty
-- Consider data families: In case of a DataCon, we need to translate to
-- the representation TyCon. For PatSyns, they are relative to the data
-- family TyCon, so we don't need to translate them.
- let (_, tc_args', _) = tcLookupDataFamInst env tc tc_args
- Just tc_args'
+ let (rep_tc, tc_args', _) = tcLookupDataFamInst env tc tc_args
+ if rep_tc == dataConTyCon dc
+ then Just tc_args'
+ else Nothing
guessConLikeUnivTyArgsFromResTy _ res_ty (PatSynCon ps) = do
-- We are successful if we managed to instantiate *every* univ_tv of con.
-- This is difficult and bound to fail in some cases, see
@@ -998,7 +964,7 @@ addNotBotCt nabla at MkNabla{ nabla_tm_st = TmSt env reps } x = do
-- | Returns (Just vi) if at least one member of each ConLike in the COMPLETE
-- set satisfies the oracle
--
--- Internally uses and updates the ConLikeSets in vi_cache.
+-- Internally uses and updates the ConLikeSets in vi_rcm.
--
-- NB: Does /not/ filter each ConLikeSet with the oracle; members may
-- remain that do not statisfy it. This lazy approach just
@@ -1007,17 +973,31 @@ ensureInhabited :: Nabla -> VarInfo -> MaybeT DsM VarInfo
ensureInhabited nabla vi = case vi_bot vi of
MaybeBot -> pure vi -- The |-Bot rule from the paper
IsBot -> pure vi
- IsNotBot -> lift (initPossibleMatches (nabla_ty_st nabla) vi) >>= inst_complete_sets
+ IsNotBot -> lift (add_matches vi) >>= inst_complete_sets
where
+ add_matches :: VarInfo -> DsM VarInfo
+ add_matches vi = do
+ res <- pmTopNormaliseType (nabla_ty_st nabla) (vi_ty vi)
+ rcm <- case reprTyCon_maybe (normalisedSourceType res) of
+ Just tc -> addTyConMatches tc (vi_rcm vi)
+ Nothing -> addCompleteMatches (vi_rcm vi)
+ pure vi{ vi_rcm = rcm }
+
+ reprTyCon_maybe :: Type -> Maybe TyCon
+ reprTyCon_maybe ty = case splitTyConApp_maybe ty of
+ Nothing -> Nothing
+ Just (tc, _args) -> case tyConFamInst_maybe tc of
+ Nothing -> Just tc
+ Just (tc_fam, _) -> Just tc_fam
+
-- | This is the |-Inst rule from the paper (section 4.5). Tries to
-- find an inhabitant in every complete set by instantiating with one their
-- constructors. If there is any complete set where we can't find an
-- inhabitant, the whole thing is uninhabited.
inst_complete_sets :: VarInfo -> MaybeT DsM VarInfo
- inst_complete_sets vi at VI{ vi_cache = NoPM } = pure vi
- inst_complete_sets vi at VI{ vi_cache = PM ms } = do
- ms <- traverse (\cs -> inst_complete_set vi cs (uniqDSetToList cs)) ms
- pure vi{ vi_cache = PM ms }
+ inst_complete_sets vi at VI{ vi_rcm = rcm } = do
+ rcm' <- trvRcm (\cls -> inst_complete_set vi cls (uniqDSetToList cls)) rcm
+ pure vi{ vi_rcm = rcm' }
inst_complete_set :: VarInfo -> ConLikeSet -> [ConLike] -> MaybeT DsM ConLikeSet
-- (inst_complete_set cs cls) iterates over cls, deleting from cs
@@ -1052,7 +1032,7 @@ ensureInhabited nabla vi = case vi_bot vi of
]
-- | Checks if every 'VarInfo' in the term oracle has still an inhabited
--- 'vi_cache', considering the current type information in 'Nabla'.
+-- 'vi_rcm', considering the current type information in 'Nabla'.
-- This check is necessary after having matched on a GADT con to weed out
-- impossible matches.
ensureAllInhabited :: Nabla -> DsM (Maybe Nabla)
@@ -1111,7 +1091,7 @@ equate nabla at MkNabla{ nabla_tm_st = TmSt env reps } x y
-- Do the same for negative info
let add_refut nabla nalt = addNotConCt nabla y nalt
nabla_neg <- foldlM add_refut nabla_pos (pmAltConSetElems (vi_neg vi_x))
- -- vi_cache will be updated in addNotConCt, so we are good to
+ -- vi_rcm will be updated in addNotConCt, so we are good to
-- go!
pure nabla_neg
@@ -1123,7 +1103,7 @@ equate nabla at MkNabla{ nabla_tm_st = TmSt env reps } x y
-- See Note [TmState invariants].
addConCt :: Nabla -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Nabla
addConCt nabla at MkNabla{ nabla_tm_st = ts@(TmSt env reps) } x alt tvs args = do
- let VI ty pos neg bot cache = lookupVarInfo ts x
+ let VI ty pos neg bot rcm = lookupVarInfo ts x
-- First try to refute with a negative fact
guard (not (elemPmAltConSet alt neg))
-- Then see if any of the other solutions (remember: each of them is an
@@ -1142,7 +1122,8 @@ addConCt nabla at MkNabla{ nabla_tm_st = ts@(TmSt env reps) } x alt tvs args = do
MaybeT $ addPmCts nabla (listToBag ty_cts `unionBags` listToBag tm_cts)
Nothing -> do
let pos' = (alt, tvs, args):pos
- let nabla_with bot = nabla{ nabla_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg bot cache)) reps}
+ let nabla_with bot =
+ nabla{ nabla_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg bot rcm)) reps}
-- Do (2) in Note [Coverage checking Newtype matches]
case (alt, args) of
(PmAltConLike (RealDataCon dc), [y]) | isNewDataCon dc ->
@@ -1574,7 +1555,7 @@ provideEvidence = go
try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]
-- Convention: x binds the outer constructor in the chain, y the inner one.
try_instantiate x xs n nabla = do
- (_src_ty, dcs, core_ty) <- tntrGuts <$> pmTopNormaliseType (nabla_ty_st nabla) (idType x)
+ (_src_ty, dcs, rep_ty) <- tntrGuts <$> pmTopNormaliseType (nabla_ty_st nabla) (idType x)
let build_newtype (x, nabla) (_ty, dc, arg_ty) = do
y <- lift $ mkPmId arg_ty
-- Newtypes don't have existentials (yet?!), so passing an empty
@@ -1586,10 +1567,12 @@ provideEvidence = go
Just (y, newty_nabla) -> do
-- Pick a COMPLETE set and instantiate it (n at max). Take care of ⊥.
let vi = lookupVarInfo (nabla_tm_st newty_nabla) y
- vi <- initPossibleMatches (nabla_ty_st newty_nabla) vi
- mb_cls <- pickMinimalCompleteSet newty_nabla (vi_cache vi)
+ rcm <- case splitTyConApp_maybe rep_ty of
+ Nothing -> pure (vi_rcm vi)
+ Just (tc, _) -> addTyConMatches tc (vi_rcm vi)
+ mb_cls <- pickMinimalCompleteSet rep_ty rcm
case uniqDSetToList <$> mb_cls of
- Just cls@(_:_) -> instantiate_cons y core_ty xs n newty_nabla cls
+ Just cls@(_:_) -> instantiate_cons y rep_ty xs n newty_nabla cls
Just [] | vi_bot vi == IsNotBot -> pure []
-- Either ⊥ is still possible (think Void) or there are no COMPLETE
-- sets available, so we can assume it's inhabited
@@ -1631,13 +1614,15 @@ provideEvidence = go
other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls
pure (con_nablas ++ other_cons_nablas)
-pickMinimalCompleteSet :: Nabla -> PossibleMatches -> DsM (Maybe ConLikeSet)
-pickMinimalCompleteSet _ NoPM = pure Nothing
--- TODO: First prune sets with type info in nabla. But this is good enough for
--- now and less costly. See #17386.
-pickMinimalCompleteSet _ (PM clss) = do
- tracePm "pickMinimalCompleteSet" (ppr $ NonEmpty.toList clss)
- pure (Just (minimumBy (comparing sizeUniqDSet) clss))
+pickMinimalCompleteSet :: Type -> ResidualCompleteMatches -> DsM (Maybe ConLikeSet)
+pickMinimalCompleteSet ty rcm = do
+ env <- dsGetFamInstEnvs
+ pure $ case filter (all (is_valid env) . uniqDSetToList) (getRcm rcm) of
+ [] -> Nothing
+ clss' -> Just (minimumBy (comparing sizeUniqDSet) clss')
+ where
+ is_valid :: FamInstEnvs -> ConLike -> Bool
+ is_valid env cl = isJust (guessConLikeUnivTyArgsFromResTy env ty cl)
-- | Finds a representant of the semantic equality class of the given @e at .
-- Which is the @x@ of a @let x = e'@ constraint (with @e@ semantically
=====================================
compiler/GHC/HsToCore/PmCheck/Types.hs
=====================================
@@ -24,8 +24,8 @@ module GHC.HsToCore.PmCheck.Types (
literalToPmLit, negatePmLit, overloadPmLit,
pmLitAsStringLit, coreExprAsPmLit,
- -- * Caching partially matched COMPLETE sets
- ConLikeSet, PossibleMatches(..),
+ -- * Caching residual COMPLETE sets
+ ConLikeSet, ResidualCompleteMatches(..), getRcm,
-- * PmAltConSet
PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,
@@ -69,10 +69,10 @@ import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Tc.Utils.TcType (evVarPred)
+import GHC.Driver.Types (ConLikeSet)
import Numeric (fromRat)
import Data.Foldable (find)
-import qualified Data.List.NonEmpty as NonEmpty
import Data.Ratio
import qualified Data.Semigroup as Semi
@@ -415,21 +415,31 @@ instance Outputable PmAltCon where
instance Outputable PmEquality where
ppr = text . show
-type ConLikeSet = UniqDSet ConLike
+-- | A data type that caches for the 'VarInfo' of @x@ the results of querying
+-- 'dsGetCompleteMatches' and then striking out all occurrences of @K@ for
+-- which we already know @x /~ K@ from these sets.
+--
+-- For motivation, see Section 5.3 in Lower Your Guards.
+data ResidualCompleteMatches
+ = RCM
+ { rcm_vanilla :: !(Maybe ConLikeSet)
+ -- ^ The residual set for the vanilla COMPLETE set from the data defn.
+ -- Tracked separately from 'rcm_pragmas', because it might only be
+ -- known much later (when we have enough type information to see the 'TyCon'
+ -- of the match), or not at all even. Until that happens, it is 'Nothing'.
+ , rcm_pragmas :: !(Maybe [ConLikeSet])
+ -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are
+ -- visible when compiling this module. Querying that set with
+ -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing'
+ -- until first needed in a 'DsM' context.
+ }
--- | A data type caching the results of 'completeMatchConLikes' with support for
--- deletion of constructors that were already matched on.
-data PossibleMatches
- = PM (NonEmpty.NonEmpty ConLikeSet)
- -- ^ Each ConLikeSet is a (subset of) the constructors in a COMPLETE set
- -- 'NonEmpty' because the empty case would mean that the type has no COMPLETE
- -- set at all, for which we have 'NoPM'.
- | NoPM
- -- ^ No COMPLETE set for this type (yet). Think of overloaded literals.
+getRcm :: ResidualCompleteMatches -> [ConLikeSet]
+getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas
-instance Outputable PossibleMatches where
- ppr (PM cs) = ppr (NonEmpty.toList cs)
- ppr NoPM = text "<NoPM>"
+instance Outputable ResidualCompleteMatches where
+ -- formats as "[{Nothing,Just},{P,Q}]"
+ ppr rcm = ppr (getRcm rcm)
-- | Either @Indirect x@, meaning the value is represented by that of @x@, or
-- an @Entry@ containing containing the actual value it represents.
@@ -516,8 +526,8 @@ data TmState
-- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@,
-- and negative ('vi_neg') facts, like "x is not (:)".
--- Also caches the type ('vi_ty'), the 'PossibleMatches' of a COMPLETE set
--- ('vi_cache').
+-- Also caches the type ('vi_ty'), the 'ResidualCompleteMatches' of a COMPLETE set
+-- ('vi_rcm').
--
-- Subject to Note [The Pos/Neg invariant] in "GHC.HsToCore.PmCheck.Oracle".
data VarInfo
@@ -559,7 +569,7 @@ data VarInfo
-- * 'IsBot': @x ~ ⊥@
-- * 'IsNotBot': @x ≁ ⊥@
- , vi_cache :: !PossibleMatches
+ , vi_rcm :: !ResidualCompleteMatches
-- ^ A cache of the associated COMPLETE sets. At any time a superset of
-- possible constructors of each COMPLETE set. So, if it's not in here, we
-- can't possibly match on it. Complementary to 'vi_neg'. We still need it
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -38,7 +38,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.IfaceToCore
( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst
- , tcIfaceAnnotations, tcIfaceCompleteSigs )
+ , tcIfaceAnnotations, tcIfaceCompleteMatches )
import GHC.Driver.Session
import GHC.Driver.Backend
@@ -479,7 +479,7 @@ loadInterface doc_str mod from
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
- ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+ ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; let { final_iface = iface {
mi_decls = panic "No mi_decls in PIT",
@@ -509,9 +509,7 @@ loadInterface doc_str mod from
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
- = extendCompleteMatchMap
- (eps_complete_matches eps)
- new_eps_complete_sigs,
+ = eps_complete_matches eps ++ new_eps_complete_matches,
eps_inst_env = extendInstEnvList (eps_inst_env eps)
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
@@ -1037,9 +1035,8 @@ initExternalPackageState home_unit
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules',
-- Initialise the EPS rule pool with the built-in rules
- eps_mod_fam_inst_env
- = emptyModuleEnv,
- eps_complete_matches = emptyUFM,
+ eps_mod_fam_inst_env = emptyModuleEnv,
+ eps_complete_matches = [],
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
@@ -1181,7 +1178,7 @@ pprModIface iface at ModIface{ mi_final_exts = exts }
, ppr (mi_warns iface)
, pprTrustInfo (mi_trust iface)
, pprTrustPkg (mi_trust_pkg iface)
- , vcat (map ppr (mi_complete_sigs iface))
+ , vcat (map ppr (mi_complete_matches iface))
, text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
, text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
, text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -57,6 +57,7 @@ import GHC.Types.Avail
import GHC.Types.Name.Reader
import GHC.Types.Name.Env
import GHC.Types.Name.Set
+import GHC.Types.Unique.DSet
import GHC.Unit
import GHC.Utils.Error
import GHC.Utils.Outputable
@@ -220,7 +221,7 @@ mkIface_ hsc_env
md_anns = anns,
md_types = type_env,
md_exports = exports,
- md_complete_sigs = complete_sigs }
+ md_complete_matches = complete_matches }
-- 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
@@ -256,7 +257,7 @@ mkIface_ hsc_env
iface_fam_insts = map famInstToIfaceFamInst fam_insts
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
- icomplete_sigs = map mkIfaceCompleteSig complete_sigs
+ icomplete_matches = map mkIfaceCompleteMatch complete_matches
ModIface {
mi_module = this_mod,
@@ -285,7 +286,7 @@ mkIface_ hsc_env
mi_hpc = isHpcUsed hpc_info,
mi_trust = trust_info,
mi_trust_pkg = pkg_trust_req,
- mi_complete_sigs = icomplete_sigs,
+ mi_complete_matches = icomplete_matches,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
@@ -322,8 +323,9 @@ mkIface_ hsc_env
************************************************************************
-}
-mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
-mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
+mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch
+mkIfaceCompleteMatch cls =
+ IfaceCompleteMatch (map conLikeName (uniqDSetToList cls))
{-
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -324,11 +324,11 @@ data IfaceAnnotation
type IfaceAnnTarget = AnnTarget OccName
-data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName
+newtype IfaceCompleteMatch = IfaceCompleteMatch [IfExtName]
instance Outputable IfaceCompleteMatch where
- ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls
- <+> dcolon <+> ppr ty
+ ppr (IfaceCompleteMatch cls) = text "COMPLETE" <> colon <+> ppr cls
+
@@ -2481,8 +2481,8 @@ instance Binary IfaceTyConParent where
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
+ put_ bh (IfaceCompleteMatch cs) = put_ bh cs
+ get bh = IfaceCompleteMatch <$> get bh
{-
@@ -2638,7 +2638,7 @@ instance NFData IfaceConAlt where
IfaceLitAlt lit -> lit `seq` ()
instance NFData IfaceCompleteMatch where
- rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2
+ rnf (IfaceCompleteMatch f1) = rnf f1
instance NFData IfaceRule where
rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) =
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -142,7 +142,7 @@ mkBootModDetailsTc hsc_env
tcg_patsyns = pat_syns,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
- tcg_complete_matches = complete_sigs,
+ tcg_complete_matches = complete_matches,
tcg_mod = this_mod
}
= -- This timing isn't terribly useful since the result isn't forced, but
@@ -150,13 +150,13 @@ mkBootModDetailsTc hsc_env
Err.withTiming dflags
(text "CoreTidy"<+>brackets (ppr this_mod))
(const ()) $
- return (ModDetails { md_types = type_env'
- , md_insts = insts'
- , md_fam_insts = fam_insts
- , md_rules = []
- , md_anns = []
- , md_exports = exports
- , md_complete_sigs = complete_sigs
+ return (ModDetails { md_types = type_env'
+ , md_insts = insts'
+ , md_fam_insts = fam_insts
+ , md_rules = []
+ , md_anns = []
+ , md_exports = exports
+ , md_complete_matches = complete_matches
})
where
dflags = hsc_dflags hsc_env
@@ -345,22 +345,22 @@ three places this is actioned:
-}
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-tidyProgram hsc_env (ModGuts { mg_module = mod
- , mg_exports = exports
- , mg_rdr_env = rdr_env
- , mg_tcs = tcs
- , mg_insts = cls_insts
- , mg_fam_insts = fam_insts
- , mg_binds = binds
- , mg_patsyns = patsyns
- , mg_rules = imp_rules
- , mg_anns = anns
- , mg_complete_sigs = complete_sigs
- , mg_deps = deps
- , mg_foreign = foreign_stubs
- , mg_foreign_files = foreign_files
- , mg_hpc_info = hpc_info
- , mg_modBreaks = modBreaks
+tidyProgram hsc_env (ModGuts { mg_module = mod
+ , mg_exports = exports
+ , mg_rdr_env = rdr_env
+ , mg_tcs = tcs
+ , mg_insts = cls_insts
+ , mg_fam_insts = fam_insts
+ , mg_binds = binds
+ , mg_patsyns = patsyns
+ , mg_rules = imp_rules
+ , mg_anns = anns
+ , mg_complete_matches = complete_matches
+ , mg_deps = deps
+ , mg_foreign = foreign_stubs
+ , mg_foreign_files = foreign_files
+ , mg_hpc_info = hpc_info
+ , mg_modBreaks = modBreaks
})
= Err.withTiming dflags
@@ -465,13 +465,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
cg_modBreaks = modBreaks,
cg_spt_entries = spt_entries },
- ModDetails { md_types = tidy_type_env,
- md_rules = tidy_rules,
- md_insts = tidy_cls_insts,
- md_fam_insts = fam_insts,
- md_exports = exports,
- md_anns = anns, -- are already tidy
- md_complete_sigs = complete_sigs
+ ModDetails { md_types = tidy_type_env,
+ md_rules = tidy_rules,
+ md_insts = tidy_cls_insts,
+ md_fam_insts = fam_insts,
+ md_exports = exports,
+ md_anns = anns, -- are already tidy
+ md_complete_matches = complete_matches
})
}
where
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -17,7 +17,7 @@ module GHC.IfaceToCore (
typecheckIfacesForMerging,
typecheckIfaceForInstantiate,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
- tcIfaceAnnotations, tcIfaceCompleteSigs,
+ tcIfaceAnnotations, tcIfaceCompleteMatches,
tcIfaceExpr, -- Desired by HERMIT (#7683)
tcIfaceGlobal,
tcIfaceOneShot
@@ -67,6 +67,7 @@ import GHC.Types.Name.Set
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Unit.Module
import GHC.Types.Unique.FM
+import GHC.Types.Unique.DSet ( mkUniqDSet )
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Data.Maybe
@@ -180,7 +181,7 @@ typecheckIface iface
; exports <- ifaceExportNames (mi_exports iface)
-- Complete Sigs
- ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+ ; complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
-- Finished
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
@@ -194,7 +195,7 @@ typecheckIface iface
, md_rules = rules
, md_anns = anns
, md_exports = exports
- , md_complete_sigs = complete_sigs
+ , md_complete_matches = complete_matches
}
}
@@ -393,14 +394,14 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
- complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+ complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
- , md_complete_sigs = complete_sigs
+ , md_complete_matches = complete_matches
}
return (global_type_env, details)
@@ -432,14 +433,14 @@ typecheckIfaceForInstantiate nsubst iface =
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
- complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+ complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
- , md_complete_sigs = complete_sigs
+ , md_complete_matches = complete_matches
}
-- Note [Resolving never-exported Names]
@@ -1147,11 +1148,14 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
************************************************************************
-}
-tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
-tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
+tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch
-tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
-tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
+tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch
+tcIfaceCompleteMatch (IfaceCompleteMatch ms) =
+ mkUniqDSet <$> mapM (forkM doc . tcIfaceConLike) ms
+ where
+ doc = text "COMPLETE sig" <+> ppr ms
{-
************************************************************************
@@ -1760,7 +1764,13 @@ tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
AConLike (RealDataCon dc) -> return dc
- _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+ _ -> pprPanic "tcIfaceDataCon" (ppr name$$ ppr thing) }
+
+tcIfaceConLike :: Name -> IfL ConLike
+tcIfaceConLike name = do { thing <- tcIfaceGlobal name
+ ; case thing of
+ AConLike cl -> return cl
+ _ -> pprPanic "tcIfaceConLike" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
=====================================
compiler/GHC/IfaceToCore.hs-boot
=====================================
@@ -11,9 +11,9 @@ import GHC.Core ( CoreRule )
import GHC.Driver.Types ( CompleteMatch )
import GHC.Types.Annotations ( Annotation )
-tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
-tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceInst :: IfaceClsInst -> IfL ClsInst
-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
-tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
-tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
+tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
+tcIfaceInst :: IfaceClsInst -> IfL ClsInst
+tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
+tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -44,9 +44,8 @@ import GHC.Tc.Utils.TcMType
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
-import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
-import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
+import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types( mkBoxedTupleTy )
import GHC.Types.Id
@@ -69,9 +68,9 @@ import GHC.Utils.Panic
import GHC.Builtin.Names( ipClassName )
import GHC.Tc.Validity (checkValidType)
import GHC.Types.Unique.FM
+import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Core.ConLike
import Control.Monad
import Data.Foldable (find)
@@ -197,112 +196,22 @@ tcTopBinds binds sigs
-- 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 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 GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs sigs =
let
- doOne :: Sig GhcRn -> 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 $ mkMatch cls tc
-
- check_complete_match tc_name = do
- ty_con <- tcLookupLocatedTyCon tc_name
- (_, cls) <- checkCLTypes (Fixed Nothing ty_con)
- return $ mkMatch cls ty_con
-
- mkMatch :: [ConLike] -> TyCon -> CompleteMatch
- mkMatch cls ty_con = CompleteMatch {
- -- foldM is a left-fold and will have accumulated the ConLikes in
- -- the reverse order. foldrM would accumulate in the correct order,
- -- but would type-check the last ConLike first, which might also be
- -- confusing from the user's perspective. Hence reverse here.
- completeMatchConLikes = reverse (map conLikeName cls),
- completeMatchTyCon = tyConName ty_con
- }
+ doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)
+ -- We don't need to "type-check" COMPLETE signatures anymore; if their
+ -- combinations are invalid it will be found so at match sites. Hence we
+ -- keep '_mtc' only for backwards compatibility.
+ doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) _mtc))
+ = fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $
+ mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns
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'))
-- For some reason I haven't investigated further, the signatures come in
-- backwards wrt. declaration order. So we reverse them here, because it makes
-- a difference for incomplete match suggestions.
- in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order
+ in mapMaybeM doOne $ reverse sigs
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -45,12 +45,11 @@ module GHC.Tc.Types(
IdBindingInfo(..), ClosedTypeId, RhsNames,
IsGroupClosed(..),
SelfBootInfo(..),
- pprTcTyThingCategory, pprPECategory, CompleteMatch(..),
+ pprTcTyThingCategory, pprPECategory, CompleteMatch,
-- Desugaring types
DsM, DsLclEnv(..), DsGblEnv(..),
- DsMetaEnv, DsMetaVal(..), CompleteMatchMap,
- mkCompleteMatchMap, extendCompleteMatchMap,
+ DsMetaEnv, DsMetaVal(..), CompleteMatches,
-- Template Haskell
ThStage(..), SpliceType(..), PendingStuff(..),
@@ -310,7 +309,7 @@ data DsGblEnv
, ds_msgs :: IORef Messages -- Warning messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
- , ds_complete_matches :: CompleteMatchMap
+ , ds_complete_matches :: CompleteMatches
-- Additional complete pattern matches
, ds_cc_st :: IORef CostCentreState
-- Tracking indices for cost centre annotations
@@ -602,7 +601,7 @@ data TcGblEnv
tcg_static_wc :: TcRef WantedConstraints,
-- ^ Wanted constraints of static forms.
-- See Note [Constraints in static forms].
- tcg_complete_matches :: [CompleteMatch],
+ tcg_complete_matches :: CompleteMatches,
-- ^ Tracking indices for cost centre annotations
tcg_cc_st :: TcRef CostCentreState
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -64,8 +64,8 @@ module GHC.Tc.Utils.Env(
topIdLvl, isBrackStage,
-- New Ids
- newDFunName, newFamInstTyConName,
- newFamInstAxiomName,
+ newDFunName,
+ newFamInstTyConName, newFamInstAxiomName,
mkStableIdFromString, mkStableIdFromName,
mkWrapperName
) where
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -32,6 +32,7 @@ module GHC.Types.Unique.DFM (
addToUDFM_C_Directly,
addToUDFM_Directly,
addListToUDFM,
+ addListToUDFM_C,
delFromUDFM,
delListFromUDFM,
adjustUDFM,
@@ -41,6 +42,7 @@ module GHC.Types.Unique.DFM (
plusUDFM,
plusUDFM_C,
lookupUDFM, lookupUDFM_Directly,
+ lookupWithDefaultUDFM, lookupWithDefaultUDFM_Directly,
elemUDFM,
foldUDFM,
eltsUDFM,
@@ -68,6 +70,7 @@ import GHC.Prelude
import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
import GHC.Utils.Outputable
+import GHC.Data.Maybe ( orElse )
import qualified Data.IntMap as M
import Data.Data
@@ -206,6 +209,10 @@ addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)
addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)
+addListToUDFM_C
+ :: Uniquable key => (elt -> elt -> elt) -> UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt
+addListToUDFM_C f = foldl' (\m (k, v) -> addToUDFM_C f m k v)
+
addListToUDFM_Directly_C
:: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v)
@@ -274,6 +281,12 @@ lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
lookupUDFM_Directly :: UniqDFM key elt -> Unique -> Maybe elt
lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m
+lookupWithDefaultUDFM :: Uniquable key => UniqDFM key elt -> elt -> key -> elt
+lookupWithDefaultUDFM m v k = lookupUDFM m k `orElse` v
+
+lookupWithDefaultUDFM_Directly :: UniqDFM key elt -> elt -> Unique -> elt
+lookupWithDefaultUDFM_Directly m v k = lookupUDFM_Directly m k `orElse` v
+
elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
=====================================
docs/users_guide/exts/pragmas.rst
=====================================
@@ -887,29 +887,6 @@ 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 specifying 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
=====================================
testsuite/tests/pmcheck/complete_sigs/completesig15.hs → testsuite/tests/pmcheck/complete_sigs/T14422.hs
=====================================
@@ -10,3 +10,6 @@ pattern P :: C f => f a
pattern P <- (foo -> ())
{-# COMPLETE P #-}
+
+f :: C f => f a -> ()
+f P = () -- A complete match
=====================================
testsuite/tests/pmcheck/complete_sigs/T18277.hs
=====================================
@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Lib where
+
+type List = []
+
+pattern DefinitelyAString :: String -> String
+pattern DefinitelyAString x = x
+{-# COMPLETE DefinitelyAString #-}
+
+f :: String -> String
+f (DefinitelyAString x) = x
=====================================
testsuite/tests/pmcheck/complete_sigs/all.T
=====================================
@@ -1,7 +1,7 @@
test('completesig01', normal, compile, [''])
test('completesig02', normal, compile, [''])
test('Completesig03', normal, multimod_compile, ['Completesig03', '-Wall'])
-test('completesig04', normal, compile_fail, [''])
+test('completesig04', normal, compile, ['-Wincomplete-patterns'])
test('completesig05', normal, compile, [''])
test('completesig06', normal, compile, [''])
test('completesig07', normal, compile, [''])
@@ -12,7 +12,6 @@ test('completesig11', normal, compile, [''])
test('completesig12', normal, compile, [''])
test('completesig13', normal, compile, [''])
test('completesig14', normal, compile, [''])
-test('completesig15', normal, compile_fail, [''])
test('T13021', normal, compile, [''])
test('T13363a', normal, compile, [''])
test('T13363b', normal, compile, [''])
@@ -22,6 +21,8 @@ test('T13965', normal, compile, [''])
test('T14059a', normal, compile, [''])
test('T14059b', expect_broken('14059'), compile, [''])
test('T14253', normal, compile, [''])
+test('T14422', normal, compile, [''])
test('T14851', normal, compile, [''])
test('T17149', normal, compile, [''])
test('T17386', normal, compile, [''])
+test('T18277', normal, compile, [''])
=====================================
testsuite/tests/pmcheck/complete_sigs/completesig04.hs
=====================================
@@ -1,6 +1,12 @@
--- Test that a COMPLETE pragma over constructors of different types fails.
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+-- Test that a COMPLETE pragma over constructors of different types is a valid
+-- declaration, but that it's not suggested in any warning.
module TyMismatch where
-data E = L | R
+data T = A | B | C
-{-# COMPLETE Just, L #-}
+{-# COMPLETE Just, A #-}
+
+f A = () -- should not suggest 'Just'
+
+g (Just _) = () -- should not suggest 'A'
=====================================
testsuite/tests/pmcheck/complete_sigs/completesig04.stderr
=====================================
@@ -1,4 +1,11 @@
-completesig04.hs:6:1: error:
- • Cannot form a group of complete patterns from patterns ‘Just’ and ‘L’ as they match different type constructors (‘Maybe’ resp. ‘E’)
- • In {-# COMPLETE Just, L #-}
+completesig04.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In an equation for ‘f’:
+ Patterns not matched:
+ B
+ C
+
+completesig04.hs:12:1: warning: [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In an equation for ‘g’: Patterns not matched: Nothing
=====================================
testsuite/tests/pmcheck/complete_sigs/completesig15.stderr deleted
=====================================
@@ -1,4 +0,0 @@
-
-completesig15.hs:12:1: error:
- • A type signature must be provided for a set of polymorphic pattern synonyms.
- • In {-# COMPLETE P #-}
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -88,7 +88,7 @@ test('T17112', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T17207', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
-test('T17207b', expect_broken(17207), compile,
+test('T17207b', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T17208', expect_broken(17208), compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db1732479f7ed43e76663c6032304beb1d2cdb56
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db1732479f7ed43e76663c6032304beb1d2cdb56
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200902/4ba65285/attachment-0001.html>
More information about the ghc-commits
mailing list