module Kind (
SuperKind, Kind, typeKind,
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind,
mkArrowKind, mkArrowKinds,
anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon,
unliftedTypeKindTyCon, constraintKindTyCon,
superKind, superKindTyCon,
pprKind, pprParendKind,
kindAppResult, synTyConResKind,
splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isConstraintKind, isConstraintOrLiftedKind, returnsConstraintKind,
isKind, isKindVar,
isSuperKind, isSuperKindTyCon,
isLiftedTypeKindCon, isConstraintKindCon,
isAnyKind, isAnyKindCon,
okArrowArgKind, okArrowResultKind,
isSubOpenTypeKind, isSubOpenTypeKindKey,
isSubKind, isSubKindCon,
tcIsSubKind, tcIsSubKindCon,
defaultKind, defaultKind_maybe,
kiVarsOfKind, kiVarsOfKinds
) where
#include "HsVersions.h"
import Type ( typeKind, substKiWith, eqKind )
import TypeRep
import TysPrim
import TyCon
import VarSet
import PrelNames
import Outputable
import Maybes( orElse )
import Util
import FastString
kindFunResult :: SDoc -> Kind -> KindOrType -> Kind
kindFunResult _ (FunTy _ res) _ = res
kindFunResult _ (ForAllTy kv res) arg = substKiWith [kv] [arg] res
#ifdef DEBUG
kindFunResult doc k _ = pprPanic "kindFunResult" (ppr k $$ doc)
#else
kindFunResult _ _ _ = panic "kindFunResult"
#endif
kindAppResult :: SDoc -> Kind -> [Type] -> Kind
kindAppResult _ k [] = k
kindAppResult doc k (a:as) = kindAppResult doc (kindFunResult doc k a) as
splitKindFunTys :: Kind -> ([Kind],Kind)
splitKindFunTys (FunTy a r) = case splitKindFunTys r of
(as, k) -> (a:as, k)
splitKindFunTys k = ([], k)
splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
splitKindFunTy_maybe (FunTy a r) = Just (a,r)
splitKindFunTy_maybe _ = Nothing
splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
splitKindFunTysN 0 k = ([], k)
splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n1) r of
(as, k) -> (a:as, k)
splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
synTyConResKind :: TyCon -> Kind
synTyConResKind tycon = kindAppResult (ptext (sLit "synTyConResKind") <+> ppr tycon)
(tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon))
isOpenTypeKind, isUnliftedTypeKind,
isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool
isOpenTypeKindCon, isUnliftedTypeKindCon,
isSubOpenTypeKindCon, isConstraintKindCon,
isLiftedTypeKindCon, isAnyKindCon, isSuperKindTyCon :: TyCon -> Bool
isLiftedTypeKindCon tc = tyConUnique tc == liftedTypeKindTyConKey
isAnyKindCon tc = tyConUnique tc == anyKindTyConKey
isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey
isSuperKindTyCon tc = tyConUnique tc == superKindTyConKey
isAnyKind (TyConApp tc _) = isAnyKindCon tc
isAnyKind _ = False
isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
isOpenTypeKind _ = False
isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
isUnliftedTypeKind _ = False
isConstraintKind (TyConApp tc _) = isConstraintKindCon tc
isConstraintKind _ = False
isConstraintOrLiftedKind (TyConApp tc _)
= isConstraintKindCon tc || isLiftedTypeKindCon tc
isConstraintOrLiftedKind _ = False
returnsConstraintKind :: Kind -> Bool
returnsConstraintKind (ForAllTy _ k) = returnsConstraintKind k
returnsConstraintKind (FunTy _ k) = returnsConstraintKind k
returnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc
returnsConstraintKind _ = False
okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool
okArrowArgKindCon = isSubOpenTypeKindCon
okArrowResultKindCon = isSubOpenTypeKindCon
okArrowArgKind, okArrowResultKind :: Kind -> Bool
okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc
okArrowArgKind _ = False
okArrowResultKind (TyConApp kc []) = okArrowResultKindCon kc
okArrowResultKind _ = False
isSubOpenTypeKind :: Kind -> Bool
isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc
isSubOpenTypeKind _ = False
isSubOpenTypeKindCon kc = isSubOpenTypeKindKey (tyConUnique kc)
isSubOpenTypeKindKey :: Unique -> Bool
isSubOpenTypeKindKey uniq
= uniq == openTypeKindTyConKey
|| uniq == unliftedTypeKindTyConKey
|| uniq == liftedTypeKindTyConKey
|| uniq == constraintKindTyConKey
isKind :: Kind -> Bool
isKind k = isSuperKind (typeKind k)
isSubKind :: Kind -> Kind -> Bool
isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s)
| isPromotedTyCon kc1 || isPromotedTyCon kc2
= eqKind k1 k2
| otherwise
= ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 )
kc1 `isSubKindCon` kc2
isSubKind k1 k2 = eqKind k1 k2
isSubKindCon :: TyCon -> TyCon -> Bool
isSubKindCon kc1 kc2
| kc1 == kc2 = True
| isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1
| isConstraintKindCon kc1 = isLiftedTypeKindCon kc2
| isLiftedTypeKindCon kc1 = isConstraintKindCon kc2
| otherwise = False
tcIsSubKind :: Kind -> Kind -> Bool
tcIsSubKind k1 k2
| isConstraintKind k1 = isConstraintKind k2
| isConstraintKind k2 = isConstraintKind k1
| otherwise = isSubKind k1 k2
tcIsSubKindCon :: TyCon -> TyCon -> Bool
tcIsSubKindCon kc1 kc2
| isConstraintKindCon kc1 = isConstraintKindCon kc2
| isConstraintKindCon kc2 = isConstraintKindCon kc1
| otherwise = isSubKindCon kc1 kc2
defaultKind :: Kind -> Kind
defaultKind_maybe :: Kind -> Maybe Kind
defaultKind_maybe (TyConApp kc _args)
| isOpenTypeKindCon kc = ASSERT( null _args ) Just liftedTypeKind
defaultKind_maybe _ = Nothing
defaultKind k = defaultKind_maybe k `orElse` k
kiVarsOfKind :: Kind -> VarSet
kiVarsOfKind = tyVarsOfType
kiVarsOfKinds :: [Kind] -> VarSet
kiVarsOfKinds = tyVarsOfTypes