{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module GHC.Types.CompleteMatch
( CompleteMatchX(..)
, CompleteMatch, CompleteMatches
, DsCompleteMatch, DsCompleteMatches
, mkCompleteMatch, vanillaCompleteMatch
, completeMatchAppliesAtType
) where
import GHC.Prelude
import GHC.Core.TyCo.Rep
import GHC.Types.Unique
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Type ( splitTyConApp_maybe )
import GHC.Types.Name ( Name )
import GHC.Types.Unique.DSet
import GHC.Utils.Outputable
type CompleteMatch = CompleteMatchX Name
type DsCompleteMatch = CompleteMatchX ConLike
type CompleteMatches = [CompleteMatch]
type DsCompleteMatches = [DsCompleteMatch]
data CompleteMatchX con = CompleteMatch
{ forall con. CompleteMatchX con -> UniqDSet con
cmConLikes :: UniqDSet con
, forall con. CompleteMatchX con -> Maybe Name
cmResultTyCon :: Maybe Name
}
deriving CompleteMatchX con -> CompleteMatchX con -> Bool
(CompleteMatchX con -> CompleteMatchX con -> Bool)
-> (CompleteMatchX con -> CompleteMatchX con -> Bool)
-> Eq (CompleteMatchX con)
forall con. CompleteMatchX con -> CompleteMatchX con -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall con. CompleteMatchX con -> CompleteMatchX con -> Bool
== :: CompleteMatchX con -> CompleteMatchX con -> Bool
$c/= :: forall con. CompleteMatchX con -> CompleteMatchX con -> Bool
/= :: CompleteMatchX con -> CompleteMatchX con -> Bool
Eq
mkCompleteMatch :: UniqDSet con -> Maybe Name -> CompleteMatchX con
mkCompleteMatch :: forall con. UniqDSet con -> Maybe Name -> CompleteMatchX con
mkCompleteMatch UniqDSet con
nms Maybe Name
mb_tc = CompleteMatch { cmConLikes :: UniqDSet con
cmConLikes = UniqDSet con
nms, cmResultTyCon :: Maybe Name
cmResultTyCon = Maybe Name
mb_tc }
vanillaCompleteMatch :: UniqDSet con -> CompleteMatchX con
vanillaCompleteMatch :: forall con. UniqDSet con -> CompleteMatchX con
vanillaCompleteMatch UniqDSet con
nms = UniqDSet con -> Maybe Name -> CompleteMatchX con
forall con. UniqDSet con -> Maybe Name -> CompleteMatchX con
mkCompleteMatch UniqDSet con
nms Maybe Name
forall a. Maybe a
Nothing
instance Outputable con => Outputable (CompleteMatchX con) where
ppr :: CompleteMatchX con -> SDoc
ppr (CompleteMatch UniqDSet con
cls Maybe Name
mty) = case Maybe Name
mty of
Maybe Name
Nothing -> UniqDSet con -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqDSet con
cls
Just Name
ty -> UniqDSet con -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqDSet con
cls SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"@" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
ty)
completeMatchAppliesAtType :: Type -> CompleteMatchX con -> Bool
completeMatchAppliesAtType :: forall con. Type -> CompleteMatchX con -> Bool
completeMatchAppliesAtType Type
ty CompleteMatchX con
cm = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all @Maybe Unique -> Bool
ty_matches (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique (Name -> Unique) -> Maybe Name -> Maybe Unique
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompleteMatchX con -> Maybe Name
forall con. CompleteMatchX con -> Maybe Name
cmResultTyCon CompleteMatchX con
cm)
where
ty_matches :: Unique -> Bool
ty_matches :: Unique -> Bool
ty_matches Unique
sig_tc
| Just (TyCon
tc, [Type]
_arg_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
sig_tc
Bool -> Bool -> Bool
|| Unique
sig_tc Unique -> TyCon -> Bool
`is_family_ty_con_of` TyCon
tc
= Bool
True
| Bool
otherwise
= Bool
False
Unique
fam_tc is_family_ty_con_of :: Unique -> TyCon -> Bool
`is_family_ty_con_of` TyCon
repr_tc =
case (TyCon, [Type]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [Type]) -> TyCon) -> Maybe (TyCon, [Type]) -> Maybe TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
repr_tc of
Just TyCon
tc -> TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
fam_tc
Maybe TyCon
Nothing -> Bool
False