%
% (c) The University of Glasgow 2006
%
\begin{code}
module Kind (
Kind, typeKind,
liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind,
mkArrowKind, mkArrowKinds,
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
argTypeKindTyCon, ubxTupleKindTyCon,
tySuperKind, tySuperKindTyCon,
pprKind, pprParendKind,
kindFunResult, kindAppResult, synTyConResKind,
splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
isSuperKind, isCoercionKind,
isLiftedTypeKindCon,
isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
isSubKindCon,
) where
#include "HsVersions.h"
import TypeRep
import TysPrim
import TyCon
import Var
import PrelNames
import Outputable
\end{code}
%************************************************************************
%* *
Predicates over Kinds
%* *
%************************************************************************
\begin{code}
isTySuperKind :: SuperKind -> Bool
isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
isTySuperKind _ = False
isLiftedTypeKindCon :: TyCon -> Bool
isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
\end{code}
%************************************************************************
%* *
The kind of a type
%* *
%************************************************************************
\begin{code}
typeKind :: Type -> Kind
typeKind _ty@(TyConApp tc tys)
= ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty )
kindAppResult (tyConKind tc) tys
typeKind (PredTy pred) = predKind pred
typeKind (AppTy fun _) = kindFunResult (typeKind fun)
typeKind (ForAllTy _ ty) = typeKind ty
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (FunTy _arg res)
| isTySuperKind k = k
| otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind
where
k = typeKind res
predKind :: PredType -> Kind
predKind (EqPred {}) = unliftedTypeKind
predKind (ClassP {}) = liftedTypeKind
predKind (IParam {}) = liftedTypeKind
\end{code}
%************************************************************************
%* *
Functions over Kinds
%* *
%************************************************************************
\begin{code}
kindFunResult :: Kind -> Kind
kindFunResult (FunTy _ res) = res
kindFunResult k = pprPanic "kindFunResult" (ppr k)
kindAppResult :: Kind -> [arg] -> Kind
kindAppResult k [] = k
kindAppResult k (_:as) = kindAppResult (kindFunResult k) 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 (tyConKind tycon) (tyConTyVars tycon)
isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
isOpenTypeKind _ = False
isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
isUbxTupleKind _ = False
isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
isArgTypeKind _ = False
isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
isUnliftedTypeKind _ = False
isSubOpenTypeKind :: Kind -> Bool
isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) )
ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) )
False
isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
isSubOpenTypeKind other = ASSERT( isKind other ) False
isSubArgTypeKindCon kc
| isUnliftedTypeKindCon kc = True
| isLiftedTypeKindCon kc = True
| isArgTypeKindCon kc = True
| otherwise = False
isSubArgTypeKind :: Kind -> Bool
isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
isSubArgTypeKind _ = False
isSuperKind :: Type -> Bool
isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
isSuperKind _ = False
isKind :: Kind -> Bool
isKind k = isSuperKind (typeKind k)
isSubKind :: Kind -> Kind -> Bool
isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
isSubKind _ _ = False
isSubKindCon :: TyCon -> TyCon -> Bool
isSubKindCon kc1 kc2
| isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True
| isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
| isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True
| isOpenTypeKindCon kc2 = True
| isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True
| otherwise = False
defaultKind :: Kind -> Kind
defaultKind k
| isSubOpenTypeKind k = liftedTypeKind
| isSubArgTypeKind k = liftedTypeKind
| otherwise = k
\end{code}