{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Tools.Refactor.Utils.TypeLookup where
import qualified TyCoRep as GHC (Type(..), TyThing(..))
import qualified ConLike as GHC (ConLike(..))
import qualified DataCon as GHC (dataConUserType, isVanillaDataCon)
import qualified Name as GHC (isTyVarName)
import qualified PatSyn as GHC (patSynBuilder)
import qualified TyCon as GHC (isClosedSynFamilyTyConWithAxiom_maybe, isClassTyCon)
import qualified Type as GHC (eqType, typeKind, tcIsConstraintKind)
import qualified Var as GHC (varType)
import qualified CoAxiom as GHC
import qualified GHC hiding (typeKind)
import GHC (GhcMonad)
import Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.Rewrite as AST
import Language.Haskell.Tools.Refactor.Utils.NameLookup as AST
import Language.Haskell.Tools.Refactor.Utils.Maybe as AST
instance Eq GHC.Type where
(==) = GHC.eqType
type ClosedTyFam = GHC.CoAxiom GHC.Branched
hasConstraintKind :: GHC.Type -> Bool
hasConstraintKind = GHC.tcIsConstraintKind . GHC.typeKind
lookupTypeFromId :: (HasIdInfo' id, GhcMonad m) => id -> MaybeT m GHC.Type
lookupTypeFromId idn
| GHC.isLocalId . semanticsId $ idn = return . typeOrKindFromId $ idn
| GHC.isGlobalId . semanticsId $ idn = lookupTypeFromGlobalName idn
| otherwise = fail "Couldn't lookup name"
typeOrKindFromId :: HasIdInfo' id => id -> GHC.Type
typeOrKindFromId idn = GHC.varType . semanticsId $ idn
typeFromTyThing :: GHC.TyThing -> Maybe GHC.Type
typeFromTyThing (GHC.AnId idn) = Just . GHC.varType $ idn
typeFromTyThing (GHC.ATyCon tc) = GHC.synTyConRhs_maybe tc
typeFromTyThing (GHC.ACoAxiom _) = fail "CoAxioms are not supported for type lookup"
typeFromTyThing (GHC.AConLike con) = handleCon con
where handleCon (GHC.RealDataCon dc) = Just . GHC.dataConUserType $ dc
handleCon (GHC.PatSynCon pc) = do
(idn,_) <- GHC.patSynBuilder pc
return . GHC.varType $ idn
lookupTypeFromGlobalName :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m GHC.Type
lookupTypeFromGlobalName name = do
sname <- liftMaybe . semanticsName $ name
tt <- MaybeT . GHC.lookupName $ sname
liftMaybe . typeFromTyThing $ tt
lookupTypeSynRhs :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m GHC.Type
lookupTypeSynRhs name = do
sname <- liftMaybe . semanticsName $ name
tt <- MaybeT . GHC.lookupName $ sname
tc <- liftMaybe . tyconFromTyThing $ tt
liftMaybe . GHC.synTyConRhs_maybe $ tc
lookupSynDef :: GHC.TyThing -> Maybe GHC.TyCon
lookupSynDef syn = do
tycon <- tyconFromTyThing syn
rhs <- GHC.synTyConRhs_maybe tycon
tyconFromGHCType rhs
tyconFromTyThing :: GHC.TyThing -> Maybe GHC.TyCon
tyconFromTyThing (GHC.ATyCon tycon) = Just tycon
tyconFromTyThing _ = Nothing
tyconFromGHCType :: GHC.Type -> Maybe GHC.TyCon
tyconFromGHCType (GHC.AppTy t1 _) = tyconFromGHCType t1
tyconFromGHCType (GHC.TyConApp tycon _) = Just tycon
tyconFromGHCType _ = Nothing
isNewtype :: GhcMonad m => AST.Type -> m Bool
isNewtype t = do
tycon <- runMaybeT . lookupType $ t
return $! maybe True isNewtypeTyCon tycon
lookupType :: GhcMonad m => AST.Type -> MaybeT m GHC.TyThing
lookupType t = do
name <- liftMaybe . nameFromType $ t
sname <- liftMaybe . semanticsName $ name
MaybeT . GHC.lookupName $ sname
lookupClassWith :: GhcMonad m => (a -> MaybeT m GHC.Name) -> a -> MaybeT m GHC.Class
lookupClassWith getName x = do
sname <- getName x
tything <- MaybeT . GHC.lookupName $ sname
case tything of
GHC.ATyCon tc | GHC.isClassTyCon tc -> liftMaybe . GHC.tyConClass_maybe $ tc
_ -> fail "TypeLookup.lookupClassWith: Argument does not contain a class type constructor"
lookupClass :: (GhcMonad m, HasNameInfo' n) => n -> MaybeT m GHC.Class
lookupClass = lookupClassWith (liftMaybe . semanticsName)
lookupClassFromInstance :: GhcMonad m => InstanceHead -> MaybeT m GHC.Class
lookupClassFromInstance = lookupClassWith (liftMaybe . instHeadSemName)
lookupClassFromDeclHead :: GhcMonad m => DeclHead -> MaybeT m GHC.Class
lookupClassFromDeclHead = lookupClassWith (liftMaybe . declHeadSemName)
semanticsTypeSynRhs :: GhcMonad m => AST.Type -> MaybeT m GHC.Type
semanticsTypeSynRhs ty = (liftMaybe . nameFromType $ ty) >>= lookupTypeSynRhs
semanticsType :: GhcMonad m => AST.Type -> MaybeT m GHC.Type
semanticsType ty = (liftMaybe . nameFromType $ ty) >>= lookupTypeFromGlobalName
isNewtypeTyCon :: GHC.TyThing -> Bool
isNewtypeTyCon (GHC.ATyCon tycon) = GHC.isNewTyCon tycon
isNewtypeTyCon _ = False
satisfies :: (HasNameInfo' n, GhcMonad m) =>
(GHC.TyThing -> Maybe a) -> (a -> Bool) -> n -> MaybeT m Bool
satisfies extract pred name = do
sname <- liftMaybe . semanticsName $ name
tt <- MaybeT . GHC.lookupName $ sname
return $ maybe False pred (extract tt)
isClassTyConNameM :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m Bool
isClassTyConNameM = satisfies extractTyCon GHC.isClassTyCon
where extractTyCon (GHC.ATyCon tc) = Just tc
extractTyCon _ = Nothing
isVanillaDataConNameM :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m Bool
isVanillaDataConNameM = satisfies extractDataCon GHC.isVanillaDataCon
where extractDataCon (GHC.AConLike (GHC.RealDataCon dc)) = Just dc
extractDataCon _ = Nothing
lookupClosedTyFam :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m ClosedTyFam
lookupClosedTyFam name = do
sname <- liftMaybe . semanticsName $ name
tt <- MaybeT . GHC.lookupName $ sname
liftMaybe . coAxiomFromTyThing $ tt
coAxiomFromTyThing :: GHC.TyThing -> Maybe (GHC.CoAxiom GHC.Branched)
coAxiomFromTyThing (GHC.ATyCon tc) = GHC.isClosedSynFamilyTyConWithAxiom_maybe tc
coAxiomFromTyThing (GHC.ACoAxiom ax) = Just ax
coAxiomFromTyThing _ = Nothing
hasTyVarHead :: Type -> Bool
hasTyVarHead (ForallType _ t) = hasTyVarHead t
hasTyVarHead (CtxType _ t) = hasTyVarHead t
hasTyVarHead FunctionType{} = False
hasTyVarHead TupleType{} = False
hasTyVarHead UnboxedTupleType{} = False
hasTyVarHead ListType{} = False
hasTyVarHead ParArrayType{} = False
hasTyVarHead (TypeApp f _) = hasTyVarHead f
hasTyVarHead InfixTypeApp{} = False
hasTyVarHead (ParenType t) = hasTyVarHead t
hasTyVarHead (VarType n) = maybe False GHC.isTyVarName (semanticsName n)
hasTyVarHead (KindedType t _) = hasTyVarHead t
hasTyVarHead (BangType t) = hasTyVarHead t
hasTyVarHead (LazyType t) = hasTyVarHead t
hasTyVarHead (UnpackType t) = hasTyVarHead t
hasTyVarHead (NoUnpackType t) = hasTyVarHead t
hasTyVarHead WildcardType{} = False
hasTyVarHead NamedWildcardType{} = False
hasTyVarHead SpliceType{} = False
hasTyVarHead QuasiQuoteType{} = False
hasTyVarHead PromotedIntType{} = False
hasTyVarHead PromotedStringType{} = False
hasTyVarHead PromotedConType{} = False
hasTyVarHead PromotedListType{} = False
hasTyVarHead PromotedTupleType{} = False
hasTyVarHead PromotedUnitType{} = False
hasTyVarHead UnboxedSumType{} = False