summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver/Types.hs9
-rw-r--r--compiler/GHC/HsToCore/Quote.hs10
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/GHC/Iface/Make.hs4
-rw-r--r--compiler/GHC/Iface/Syntax.hs10
-rw-r--r--compiler/GHC/IfaceToCore.hs6
-rw-r--r--compiler/GHC/Parser.y10
-rw-r--r--compiler/GHC/Rename/Bind.hs29
-rw-r--r--compiler/GHC/Rename/HsType.hs20
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs33
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs2
-rw-r--r--compiler/GHC/Tc/Validity.hs3
-rw-r--r--compiler/GHC/ThToHs.hs4
-rw-r--r--compiler/GHC/Types/CompleteMatch.hs22
14 files changed, 94 insertions, 70 deletions
diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
index 7516a56995..64e880b375 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
@@ -62,9 +62,8 @@ import GHC.Builtin.Types.Prim
import GHC.Tc.Solver.Monad (InertSet, emptyInert)
import GHC.Tc.Utils.TcType (isStringTy)
import GHC.Types.CompleteMatch (CompleteMatch(..))
-import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit
- , fractionalLitFromRational
- , FractionalExponentBase(..))
+import GHC.Types.SourceText (mkFractionalLit, FractionalLit, fractionalLitFromRational,
+ FractionalExponentBase(..), SourceText(..))
import Numeric (fromRat)
import Data.Foldable (find)
import Data.Ratio
@@ -379,8 +378,8 @@ isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits
-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to
-- the given 'PmAltCon' according to 'eqPmAltCon'.
elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool
-elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls
-elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits
+elemPmAltConSet (PmAltConLike cl) (PACS cls _) = elementOfUniqDSet cl cls
+elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits
extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet
extendPmAltConSet (PACS cls lits) (PmAltConLike cl)
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index d3453fcd56..13865103b6 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1133,11 +1133,13 @@ repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
repPhases _ = dataCon allPhasesDataConName
rep_complete_sig :: Located [Located Name]
- -> Maybe (Located Name)
+ -> Maybe (HsPatSigType GhcRn)
-> SrcSpan
-> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_complete_sig (L _ cls) mty loc
- = do { mty' <- repMaybe nameTyConName lookupLOcc mty
+ = do { qTyCon <- lift $ dsLookupTyCon qTyConName
+ ; typeTy <- lookupType typeTyConName
+ ; mty' <- repMaybeT (mkTyConApp qTyCon [typeTy]) (repLTy . hsPatSigType) mty
; cls' <- repList nameTyConName lookupLOcc cls
; sig <- repPragComplete cls' mty'
; return [(loc, sig)] }
@@ -2595,7 +2597,7 @@ repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
-repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec))
+repPragComplete :: Core [TH.Name] -> Core (Maybe (M TH.Type)) -> MetaM (Core (M TH.Dec))
repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
repPragRule :: Core String -> Core (Maybe [(M (TH.TyVarBndr ()))])
@@ -2945,11 +2947,13 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------------- Maybe ------------------
+{- -- Presently unused.
repMaybe :: Name -> (a -> MetaM (Core b))
-> Maybe a -> MetaM (Core (Maybe b))
repMaybe tc_name f m = do
t <- lookupType tc_name
repMaybeT t f m
+-}
repMaybeT :: Type -> (a -> MetaM (Core b))
-> Maybe a -> MetaM (Core (Maybe b))
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 3fe14085a9..8f7482fa9e 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1638,7 +1638,7 @@ instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where
CompleteMatchSig _ _ (L ispan names) typ ->
[ locOnly ispan
, toHie $ map (C Use) names
- , toHie $ fmap (C Use) typ
+ , toHie $ fmap (TS (ResolvedScopes [])) typ
]
instance ToHie (TScoped (Located (HsSigType GhcRn))) where
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 53f0032f28..5c06edbfd9 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -348,8 +348,8 @@ mkIface_ hsc_env
-}
mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch
-mkIfaceCompleteMatch (CompleteMatch cls mtc) =
- IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc)
+mkIfaceCompleteMatch (CompleteMatch cls mty) =
+ IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (fmap toIfaceType mty)
{-
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 21b4274cc7..baaa4c28a3 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -325,12 +325,12 @@ data IfaceAnnotation
type IfaceAnnTarget = AnnTarget OccName
-data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfaceTyCon)
+data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfaceType)
instance Outputable IfaceCompleteMatch where
- ppr (IfaceCompleteMatch cls mtc) = text "COMPLETE" <> colon <+> ppr cls <+> case mtc of
+ ppr (IfaceCompleteMatch cls mty) = text "COMPLETE" <> colon <+> ppr cls <+> case mty of
Nothing -> empty
- Just tc -> dcolon <+> ppr tc
+ Just ty -> dcolon <+> ppr ty
-- Here's a tricky case:
-- * Compile with -O module A, and B which imports A.f
@@ -2491,7 +2491,7 @@ instance Binary IfaceTyConParent where
return $ IfDataInstance ax pr ty
instance Binary IfaceCompleteMatch where
- put_ bh (IfaceCompleteMatch cs mtc) = put_ bh cs >> put_ bh mtc
+ put_ bh (IfaceCompleteMatch cs mty) = put_ bh cs >> put_ bh mty
get bh = IfaceCompleteMatch <$> get bh <*> get bh
@@ -2651,7 +2651,7 @@ instance NFData IfaceConAlt where
IfaceLitAlt lit -> lit `seq` ()
instance NFData IfaceCompleteMatch where
- rnf (IfaceCompleteMatch f1 mtc) = rnf f1 `seq` rnf mtc
+ rnf (IfaceCompleteMatch f1 mty) = rnf f1 `seq` rnf mty
instance NFData IfaceRule where
rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) =
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 76079ae8ff..99e89b0fd1 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1281,10 +1281,10 @@ tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch
tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch
-tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = do
+tcIfaceCompleteMatch (IfaceCompleteMatch ms mty) = do
conlikes <- mkUniqDSet <$> mapM (forkM doc . tcIfaceConLike) ms
- mtc' <- traverse tcIfaceTyCon mtc
- return (CompleteMatch conlikes mtc')
+ mty' <- traverse tcIfaceType mty
+ return (CompleteMatch conlikes mty')
where
doc = text "COMPLETE sig" <+> ppr ms
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index ff380f8c75..c8cf8c6c6a 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1978,10 +1978,6 @@ opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) }
: {- empty -} { ([],Nothing) }
| '::' ctype { ([mu AnnDcolon $1],Just $2) }
-opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
- : {- empty -} { ([], Nothing) }
- | '::' gtycon { ([mu AnnDcolon $1], Just $2) }
-
-- Like ktype, but for types that obey the forall-or-nothing rule.
-- See Note [forall-or-nothing rule] in GHC.Hs.Type.
sigktype :: { LHsSigType GhcPs }
@@ -1997,6 +1993,10 @@ sigktype :: { LHsSigType GhcPs }
sigtype :: { LHsSigType GhcPs }
: ctype { hsTypeToHsSigType $1 }
+opt_patsigtype :: { ([AddAnn], Maybe (HsPatSigType GhcPs)) }
+ : {- empty -} { ([], Nothing) }
+ | '::' type { ([mu AnnDcolon $1], Just (mkHsPatSigType $2)) }
+
sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
: sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1)
AnnComma (gl $2)
@@ -2521,7 +2521,7 @@ sigdecl :: { LHsDecl GhcPs }
| pattern_synonym_sig { sLL $1 $> . SigD noExtField . unLoc $ $1 }
- | '{-# COMPLETE' con_list opt_tyconsig '#-}'
+ | '{-# COMPLETE' con_list opt_patsigtype '#-}'
{% let (dcolon, tc) = $3
in ams
(sLL $1 $>
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index fdcf89104f..385fc52ce8 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1032,29 +1032,19 @@ renameSig ctxt sig@(SCCFunSig _ st v s)
-- COMPLETE Sigs can refer to imported IDs which is why we use
-- lookupLocatedOccRn rather than lookupSigOccRn
-renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
+renameSig _ctxt (CompleteMatchSig _ s (L l bf) mty)
= do new_bf <- traverse lookupLocatedOccRn bf
- new_mty <- traverse lookupLocatedOccRn mty
-
- this_mod <- fmap tcg_mod getGblEnv
- unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $
- -- Why 'any'? See Note [Orphan COMPLETE pragmas]
- addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
-
+ let doc = GenericCtx (text "the scrutinee type signature of a COMPLETE pragma")
+ new_mty <- traverse (rnHsCompletePragType doc) mty
return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs)
- where
- orphanError :: SDoc
- orphanError =
- text "Orphan COMPLETE pragmas not supported" $$
- text "A COMPLETE pragma must mention at least one data constructor" $$
- text "or pattern synonym defined in the same module."
{-
Note [Orphan COMPLETE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We define a COMPLETE pragma to be a non-orphan if it includes at least
-one conlike defined in the current module. Why is this sufficient?
-Well if you have a pattern match
+one conlike defined in the current module, or if the specified type that
+it applies to is defined in the current module. Why is this sufficient?
+Well, with respect to the conlikes, if you have a pattern match
case expr of
P1 -> ...
@@ -1062,8 +1052,11 @@ Well if you have a pattern match
P3 -> ...
any COMPLETE pragma which mentions a conlike other than P1, P2 or P3
-will not be of any use in verifying that the pattern match is
-exhaustive. So as we have certainly read the interface files that
+(or which explicitly specifies a type other than the type being
+deconstructed) will not be of any use in verifying that the pattern
+match is exhaustive.
+
+So as we have certainly read the interface files that
define P1, P2 and P3, we will have loaded all non-orphan COMPLETE
pragmas that could be relevant to this pattern match.
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 8634d5939f..b0f239d6e3 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -13,6 +13,7 @@ module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars,
+ rnHsCompletePragType,
HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
newTyVarNameRn,
rnConDeclFields,
@@ -138,6 +139,25 @@ rnHsSigWcType doc (HsWC { hswc_body =
, sig_bndrs = outer_bndrs', sig_body = body_ty' }}
, fvs) } }
+rnHsCompletePragType :: HsDocContext
+ -> HsPatSigType GhcPs
+ -> RnM (HsPatSigType GhcRn)
+-- Simplified version of rnHsPatSigType used for scrutinee types in COMPLETE pragmas.
+-- Doesn't check for any extensions.
+-- All type variables and wildcards are allowed but we don't keep track of the free type variables, since
+-- they never scope over anything further.
+rnHsCompletePragType ctx sig_ty
+ = do { let free_vars = extractHsTyRdrTyVars pat_sig_ty
+ ; (res, _) <- rnImplicitTvOccs Nothing free_vars $ \ imp_tvs ->
+ do { (nwcs, pat_sig_ty', fvs1) <- rnWcBody ctx [] pat_sig_ty
+ ; let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }
+ sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = pat_sig_ty' }
+ ; return (sig_ty', fvs1) }
+ ; return res
+ }
+ where
+ pat_sig_ty = hsPatSigType sig_ty
+
rnHsPatSigType :: HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 0ab561a0a7..4d4e1cc385 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -2,7 +2,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-
@@ -50,6 +49,7 @@ import GHC.Tc.Utils.TcType
import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
import GHC.Builtin.Types ( mkBoxedTupleTy )
import GHC.Builtin.Types.Prim
+import GHC.Types.CompleteMatch
import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.Var as Var
@@ -66,7 +66,6 @@ import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Types.Basic
-import GHC.Types.CompleteMatch
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Builtin.Names( ipClassName )
@@ -202,17 +201,27 @@ tcTopBinds binds sigs
tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs sigs =
- let
+ let orphanError :: SDoc
+ orphanError =
+ text "Orphan COMPLETE pragmas not supported" $$
+ text "A COMPLETE pragma must mention at least one data constructor" $$
+ text "or pattern synonym defined in the same module."
+
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.
- -- There it is also where we consider if the type of the pattern match is
- -- compatible with the result type constructor 'mb_tc'.
- doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm))
- = fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $ do
- cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns
- mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm
- pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }
+ doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mty))
+ = do this_mod <- fmap tcg_mod getGblEnv
+ mt <- forM mty $ \ty -> do
+ (_,_,t) <- tcHsPatSigType CompletePragCtxt HM_FamPat ty OpenKind
+ return t
+
+ fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $ do
+ -- Check if this COMPLETE pragma is an orphan.
+ unless (any (nameIsLocalOrFrom this_mod . unLoc) ns || any (nameSetAny (nameIsLocalOrFrom this_mod) . orphNamesOfType) mt) $
+ -- Why 'any'? See Note [Orphan COMPLETE pragmas]
+ failWithTc orphanError
+ -- Look up the ConLikes mentioned
+ conlikes <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns
+ return (CompleteMatch { cmConLikes = conlikes, cmResultType = mt })
doOne _ = return Nothing
-- For some reason I haven't investigated further, the signatures come in
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 648bf5ce12..16a4a24467 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -109,6 +109,7 @@ data UserTypeCtxt
| DataKindCtxt Name -- The kind of a data/newtype (instance)
| TySynKindCtxt Name -- The kind of the RHS of a type synonym
| TyFamResKindCtxt Name -- The result kind of a type family
+ | CompletePragCtxt -- The scrutinee type of a COMPLETE pragma
{-
-- Notes re TySynCtxt
@@ -150,6 +151,7 @@ pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type va
pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n)
+pprUserTypeCtxt CompletePragCtxt = text "the scrutinee type of a COMPLETE pragma"
isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe (FunSigCtxt n _) = Just n
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index f446b69634..c10e29fa80 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -377,6 +377,7 @@ checkValidType ctxt ty
DataKindCtxt _ -> rank1
TySynKindCtxt _ -> rank1
TyFamResKindCtxt _ -> rank1
+ CompletePragCtxt -> rank1
_ -> panic "checkValidType"
-- Can't happen; not used for *user* sigs
@@ -507,6 +508,7 @@ typeOrKindCtxt (SigmaCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (DataTyCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (DerivClauseCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (ConArgCtxt {}) = OnlyTypeCtxt
+typeOrKindCtxt (CompletePragCtxt {}) = OnlyTypeCtxt
-- Although data constructors can be promoted with DataKinds, we always
-- validity-check them as though they are the types of terms. We may need
-- to revisit this decision if we ever allow visible dependent quantification
@@ -1376,6 +1378,7 @@ okIPCtxt (TyVarBndrKindCtxt {}) = False
okIPCtxt (DataKindCtxt {}) = False
okIPCtxt (TySynKindCtxt {}) = False
okIPCtxt (TyFamResKindCtxt {}) = False
+okIPCtxt (CompletePragCtxt {}) = False
{-
Note [Kind polymorphic type classes]
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 12f65d36ca..4ae63d19c3 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -827,9 +827,9 @@ cvtPragmaD (LineP line file)
}
cvtPragmaD (CompleteP cls mty)
= do { cls' <- noLoc <$> mapM cNameL cls
- ; mty' <- traverse tconNameL mty
+ ; mty' <- traverse cvtType mty
; returnJustL $ Hs.SigD noExtField
- $ CompleteMatchSig noExtField NoSourceText cls' mty' }
+ $ CompleteMatchSig noExtField NoSourceText cls' (fmap mkHsPatSigType mty') }
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
diff --git a/compiler/GHC/Types/CompleteMatch.hs b/compiler/GHC/Types/CompleteMatch.hs
index 43216eba12..9070082ac6 100644
--- a/compiler/GHC/Types/CompleteMatch.hs
+++ b/compiler/GHC/Types/CompleteMatch.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE TypeApplications #-}
-
-- | COMPLETE signature
module GHC.Types.CompleteMatch where
@@ -7,20 +5,22 @@ import GHC.Prelude
import GHC.Core.TyCo.Rep
import GHC.Types.Unique.DSet
import GHC.Core.ConLike
-import GHC.Core.TyCon
-import GHC.Core.Type ( splitTyConApp_maybe )
import GHC.Utils.Outputable
+import GHC.Core.Unify
+
+import Data.Maybe
-- | A list of conlikes which represents a complete pattern match.
-- These arise from @COMPLETE@ signatures.
-- See also Note [Implementation of COMPLETE pragmas].
data CompleteMatch = CompleteMatch
{ cmConLikes :: UniqDSet ConLike -- ^ The set of `ConLike` values
- , cmResultTyCon :: Maybe TyCon -- ^ The optional, concrete result TyCon the set applies to
+ , cmResultType :: Maybe Type -- ^ A type to be unified with the type of the scrutinee of a pattern match to determine if this pragma applies to the given match.
+ -- It should be a type which is possibly the type of result of each of the constructors, though at present, we don't check this.
}
vanillaCompleteMatch :: UniqDSet ConLike -> CompleteMatch
-vanillaCompleteMatch cls = CompleteMatch { cmConLikes = cls, cmResultTyCon = Nothing }
+vanillaCompleteMatch cls = CompleteMatch { cmConLikes = cls, cmResultType = Nothing }
instance Outputable CompleteMatch where
ppr (CompleteMatch cls mty) = case mty of
@@ -30,11 +30,5 @@ instance Outputable CompleteMatch where
type CompleteMatches = [CompleteMatch]
completeMatchAppliesAtType :: Type -> CompleteMatch -> Bool
-completeMatchAppliesAtType ty cm = all @Maybe ty_matches (cmResultTyCon cm)
- where
- ty_matches sig_tc
- | Just (tc, _arg_tys) <- splitTyConApp_maybe ty
- , tc == sig_tc
- = True
- | otherwise
- = False
+completeMatchAppliesAtType ty cm = all (isJust . (\t -> tcUnifyTyKi t ty)) (cmResultType cm)
+ -- NB: We're using all (from Foldable) on a Maybe here.
View Lorry Controller Status