X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=c36893bc7ae7a3bc4c01fbb1806107ce1dd0a287;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=a7aeeec5043cb8f2579bfab962afec6ab26e9186;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51;p=ghc-hetmet.git diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index a7aeeec..c36893b 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -1,10 +1,18 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1998 % -\section[Type]{Type - public interface} +Type - public interface \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Type ( -- re-exports from TypeRep TyThing(..), Type, PredType(..), ThetaType, @@ -47,25 +55,28 @@ module Type ( splitTyConApp_maybe, splitTyConApp, splitNewTyConApp_maybe, splitNewTyConApp, - repType, typePrimRep, coreView, tcView, kindView, + repType, typePrimRep, coreView, tcView, kindView, rttiView, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, dropForAlls, -- Source types - predTypeRep, mkPredTy, mkPredTys, + predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp, -- Newtypes - splitRecNewType_maybe, newTyConInstRhs, + newTyConInstRhs, -- Lifting and boxity - isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType, - isStrictType, isStrictPred, + isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, + isPrimitiveType, isStrictType, isStrictPred, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, typeKind, addFreeTyVars, + -- Type families + tyFamInsts, + -- Tidying up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, @@ -76,7 +87,7 @@ module Type ( -- Comparison coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, + tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, -- Seq seqType, seqTypes, @@ -87,13 +98,14 @@ module Type ( mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, + isEmptyTvSubst, -- Performing substitution on types substTy, substTys, substTyWith, substTheta, - substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar, + substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind ) where @@ -105,31 +117,23 @@ module Type ( import TypeRep -- friends: -import Var ( Var, TyVar, tyVarKind, tyVarName, - setTyVarName, setTyVarKind, mkWildCoVar ) +import Var import VarEnv import VarSet -import OccName ( tidyOccName ) -import Name ( NamedThing(..), tidyNameOcc ) -import Class ( Class, classTyCon ) -import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey, - ubxTupleKindTyConKey, argTypeKindTyConKey ) -import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, - isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs, - isAlgTyCon, tyConArity, isSuperKindTyCon, - tcExpandTyCon_maybe, coreExpandTyCon_maybe, - tyConKind, PrimRep(..), tyConPrimRep, tyConUnique, - isCoercionTyCon_maybe, isCoercionTyCon - ) +import Name +import Class +import PrelNames +import TyCon -- others -import StaticFlags ( opt_DictsStrict ) -import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual, all2 ) +import StaticFlags +import Util import Outputable -import UniqSet ( sizeUniqSet ) -- Should come via VarSet -import Maybe ( isJust ) +import UniqSet + +import Data.List +import Data.Maybe ( isJust ) \end{code} @@ -186,6 +190,18 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys tcView ty = Nothing ----------------------------------------------- +rttiView :: Type -> Type +-- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism +rttiView (ForAllTy _ ty) = rttiView ty +rttiView (NoteTy _ ty) = rttiView ty +rttiView (FunTy PredTy{} ty) = rttiView ty +rttiView (FunTy NoteTy{} ty) = rttiView ty +rttiView ty@TyConApp{} | Just ty' <- coreView ty + = rttiView ty' +rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys) +rttiView ty = ty + +----------------------------------------------- {-# INLINE kindView #-} kindView :: Kind -> Maybe Kind -- C.f. coreView, tcView @@ -277,10 +293,12 @@ repSplitAppTy_maybe :: Type -> Maybe (Type,Type) -- Does the AppTy split, but assumes that any view stuff is already done repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -repSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of - Just (tys', ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing -repSplitAppTy_maybe other = Nothing +repSplitAppTy_maybe (TyConApp tc tys) + | not (isOpenSynTyCon tc) || length tys > tyConArity tc + = case snocView tys of -- never create unsaturated type family apps + Just (tys', ty') -> Just (TyConApp tc tys', ty') + Nothing -> Nothing +repSplitAppTy_maybe _other = Nothing ------------- splitAppTy :: Type -> (Type, Type) splitAppTy ty = case splitAppTy_maybe ty of @@ -293,7 +311,13 @@ splitAppTys ty = split ty ty [] where split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args split orig_ty (AppTy ty arg) args = split ty ty (arg:args) - split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) + split orig_ty (TyConApp tc tc_args) args + = let -- keep type families saturated + n | isOpenSynTyCon tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) split orig_ty ty args = (orig_ty, args) @@ -413,12 +437,15 @@ splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitNewTyConApp_maybe other = Nothing --- get instantiated newtype rhs, the arguments had better saturate --- the constructor newTyConInstRhs :: TyCon -> [Type] -> Type -newTyConInstRhs tycon tys = - let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty - +-- Unwrap one 'layer' of newtype +-- Use the eta'd version if possible +newTyConInstRhs tycon tys + = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs ) + mkAppTys (substTyWith tvs tys1 ty) tys2 + where + (tvs, ty) = newTyConEtadRhs tycon + (tys1, tys2) = splitAtList tvs tys \end{code} @@ -441,6 +468,31 @@ The reason is that we then get better (shorter) type signatures in interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. +Note [Expanding newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that we can expand T, even though it's recursive. +And we can expand Id (Id Int), even though the Id shows up +twice at the outer level. + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bale out if we see it again. + + Representation types ~~~~~~~~~~~~~~~~~~~~ repType looks through @@ -448,28 +500,34 @@ repType looks through (b) synonyms (c) predicates (d) usage annotations - (e) all newtypes, including recursive ones + (e) all newtypes, including recursive ones, but not newtype families It's useful in the back end. \begin{code} repType :: Type -> Type -- Only applied to types of kind *; hence tycons are saturated -repType ty | Just ty' <- coreView ty = repType ty' -repType (ForAllTy _ ty) = repType ty -repType (TyConApp tc tys) - | isNewTyCon tc = -- Recursive newtypes are opaque to coreView - -- but we must expand them here. Sure to - -- be saturated because repType is only applied - -- to types of kind * - ASSERT( {- isRecursiveTyCon tc && -} tys `lengthIs` tyConArity tc ) - repType (new_type_rep tc tys) -repType ty = ty - --- new_type_rep doesn't ask any questions: --- it just expands newtype, whether recursive or not -new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) - case newTyConRep new_tycon of - (tvs, rep_ty) -> substTyWith tvs tys rep_ty +repType ty + = go [] ty + where + go :: [TyCon] -> Type -> Type + go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms + = go rec_nts ty' + + go rec_nts (ForAllTy _ ty) -- Look through foralls + = go rec_nts ty + + go rec_nts ty@(TyConApp tc tys) -- Expand newtypes + | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes] + = if tc `elem` rec_nts -- in Type.lhs + then ty + else go rec_nts' nt_rhs + where + nt_rhs = newTyConInstRhs tc tys + rec_nts' | isRecursiveTyCon tc = tc:rec_nts + | otherwise = rec_nts + + go rec_nts ty = ty + -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. @@ -485,7 +543,6 @@ typePrimRep ty = case repType ty of -- The reason is that f must have kind *->*, not *->*#, because -- (we claim) there is no way to constrain f's kind any other -- way. - \end{code} @@ -600,34 +657,30 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -- Result might be a newtype application, but the consumer will -- look through that too if necessary predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) -\end{code} - - -%************************************************************************ -%* * - NewTypes -%* * -%************************************************************************ - -\begin{code} -splitRecNewType_maybe :: Type -> Maybe Type --- Sometimes we want to look through a recursive newtype, and that's what happens here --- It only strips *one layer* off, so the caller will usually call itself recursively --- Only applied to types of kind *, hence the newtype is always saturated -splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty' -splitRecNewType_maybe (TyConApp tc tys) - | isNewTyCon tc - = ASSERT( tys `lengthIs` tyConArity tc ) -- splitRecNewType_maybe only be applied - -- to *types* (of kind *) - ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView - case newTyConRhs tc of - (tvs, rep_ty) -> ASSERT( length tvs == length tys ) - Just (substTyWith tvs tys rep_ty) - -splitRecNewType_maybe other = Nothing - - +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g. +-- data family T a +-- data instance T (Maybe b) = MkT b -- Instance tycon :RTL +-- Then +-- mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- Pretty prints a tycon, using the family instance in case of a +-- representation tycon. For example +-- e.g. data T [a] = ... +-- In that case we want to print `T [a]', where T is the family TyCon +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon \end{code} @@ -703,6 +756,28 @@ addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty %************************************************************************ %* * +\subsection{Type families} +%* * +%************************************************************************ + +Type family instances occuring in a type after expanding synonyms. + +\begin{code} +tyFamInsts :: Type -> [(TyCon, [Type])] +tyFamInsts ty + | Just exp_ty <- tcView ty = tyFamInsts exp_ty +tyFamInsts (TyVarTy _) = [] +tyFamInsts (TyConApp tc tys) + | isOpenSynTyCon tc = [(tc, tys)] + | otherwise = concat (map tyFamInsts tys) +tyFamInsts (FunTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 +tyFamInsts (AppTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 +tyFamInsts (ForAllTy _ ty) = tyFamInsts ty +\end{code} + + +%************************************************************************ +%* * \subsection{TidyType} %* * %************************************************************************ @@ -714,13 +789,17 @@ It doesn't change the uniques at all, just the print names. \begin{code} tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr (tidy_env, subst) tyvar +tidyTyVarBndr env@(tidy_env, subst) tyvar = case tidyOccName tidy_env (getOccName name) of - (tidy', occ') -> ((tidy', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarName tyvar name' - name' = tidyNameOcc name occ' + (tidy', occ') -> ((tidy', subst'), tyvar'') + where + subst' = extendVarEnv subst tyvar tyvar'' + tyvar' = setTyVarName tyvar name' + name' = tidyNameOcc name occ' + -- Don't forget to tidy the kind for coercions! + tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind' + | otherwise = tyvar' + kind' = tidyType env (tyVarKind tyvar) where name = tyVarName tyvar @@ -818,10 +897,19 @@ isUnboxedTupleType ty = case splitTyConApp_maybe ty of -- Should only be applied to *types*; hence the assert isAlgType :: Type -> Bool -isAlgType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isAlgTyCon tc - other -> False +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- Should only be applied to *types*; hence the assert +isClosedAlgType :: Type -> Bool +isClosedAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc && not (isOpenTyCon tc) + _other -> False \end{code} @isStrictType@ computes whether an argument (or let RHS) should @@ -964,6 +1052,29 @@ tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 \end{code} +Checks whether the second argument is a subterm of the first. (We don't care +about binders, as we are only interested in syntactic subterms.) + +\begin{code} +tcPartOfType :: Type -> Type -> Bool +tcPartOfType t1 t2 + | tcEqType t1 t2 = True +tcPartOfType t1 t2 + | Just t2' <- tcView t2 = tcPartOfType t1 t2' +tcPartOfType _ (TyVarTy _) = False +tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2 +tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 +tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 +tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2 +tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts +tcPartOfType t1 (NoteTy _ t2) = tcPartOfType t1 t2 + +tcPartOfPred :: Type -> PredType -> Bool +tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2 +tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts +tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 +\end{code} + Now here comes the real worker \begin{code} @@ -1023,13 +1134,19 @@ cmpTypesX env ty [] = GT ------------- cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2 - -- Compare types as well as names for implicit parameters - -- This comparison is used exclusively (I think) for the - -- finite map built in TcSimplify -cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2 -cmpPredX env (IParam _ _) (ClassP _ _) = LT -cmpPredX env (ClassP _ _) (IParam _ _) = GT + -- Compare names only for implicit parameters + -- This comparison is used exclusively (I believe) + -- for the Avails finite map built in TcSimplify + -- If the types differ we keep them distinct so that we see + -- a distinct pair to run improvement on +cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTypesX env tys1 tys2) cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2') + +-- Constructor order: IParam < ClassP < EqPred +cmpPredX env (IParam {}) _ = LT +cmpPredX env (ClassP {}) (IParam {}) = GT +cmpPredX env (ClassP {}) (EqPred {}) = LT +cmpPredX env (EqPred {}) _ = GT \end{code} PredTypes are used as a FM key in TcSimplify, @@ -1051,11 +1168,13 @@ instance Ord PredType where { compare = tcCmpPred } data TvSubst = TvSubst InScopeSet -- The in-scope type variables TvSubstEnv -- The substitution itself - -- See Note [Apply Once] + -- See Note [Apply Once] + -- and Note [Extending the TvSubstEnv] {- ---------------------------------------------------------- - Note [Apply Once] +Note [Apply Once] +~~~~~~~~~~~~~~~~~ We use TvSubsts to instantiate things, and we might instantiate forall a b. ty \with the types @@ -1072,6 +1191,38 @@ variations happen to; for example [a -> (a, b)]. A TvSubst is not idempotent, but, unlike the non-idempotent substitution we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following invariant should hold of a TvSubst + + The in-scope set is needed *only* to + guide the generation of fresh uniques + + In particular, the *kind* of the type variables in + the in-scope set is not relevant + +This invariant allows a short-cut when the TvSubstEnv is empty: +if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- +then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's type does change + +This invariant has several crucial consequences: + +* In substTyVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + + -------------------------------------------------------------- -} @@ -1100,6 +1251,7 @@ composeTvSubst in_scope env1 env2 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv isEmptyTvSubst :: TvSubst -> Bool + -- See Note [Extending the TvSubstEnv] isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst @@ -1156,7 +1308,7 @@ zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst zipTopTvSubst tyvars tys #ifdef DEBUG | length tyvars /= length tys - = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst + = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst | otherwise #endif = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) @@ -1258,17 +1410,22 @@ subst_ty subst ty substTyVar :: TvSubst -> TyVar -> Type substTyVar subst@(TvSubst in_scope env) tv = case lookupTyVar subst tv of { - Nothing -> TyVarTy tv; + Nothing -> TyVarTy tv; Just ty -> ty -- See Note [Apply Once] } +substTyVars :: TvSubst -> [TyVar] -> [Type] +substTyVars subst tvs = map (substTyVar subst) tvs + lookupTyVar :: TvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TvSubst] lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) substTyVarBndr subst@(TvSubst in_scope env) old_var = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) where + is_co_var = isCoVar old_var new_env | no_change = delVarEnv env old_var | otherwise = extendVarEnv env old_var (TyVarTy new_var) @@ -1276,6 +1433,7 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var no_change = new_var == old_var && not is_co_var -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TvSubst] -- -- In that case we don't need to extend the substitution -- to map old to new. But instead we must zap any @@ -1287,12 +1445,10 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var -- The uniqAway part makes sure the new variable is not already in scope subst_old_var -- subst_old_var is old_var with the substitution applied to its kind - -- It's only worth doing the substitution for coercions, - -- becuase only they can have free type variables - | is_co_var = setTyVarKind old_var (substTy subst kind) + -- It's only worth doing the substitution for coercions, + -- becuase only they can have free type variables + | is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var)) | otherwise = old_var - kind = tyVarKind old_var - is_co_var = isCoercionKind kind \end{code} ---------------------------------------------------- @@ -1425,11 +1581,9 @@ isSuperKind other = False isKind :: Kind -> Bool isKind k = isSuperKind (typeKind k) - - isSubKind :: Kind -> Kind -> Bool -- (k1 `isSubKind` k2) checks that k1 <: k2 -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc1 +isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2')) = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2' @@ -1468,14 +1622,6 @@ defaultKind k | isSubArgTypeKind k = liftedTypeKind | otherwise = k -isCoercionKind :: Kind -> Bool --- All coercions are of form (ty1 :=: ty2) --- This function is here rather than in Coercion, --- because it's used by substTy -isCoercionKind k | Just k' <- kindView k = isCoercionKind k' -isCoercionKind (PredTy (EqPred {})) = True -isCoercionKind other = False - isEqPred :: PredType -> Bool isEqPred (EqPred _ _) = True isEqPred other = False