X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=6eaac8c5ccecdc7bb58129787a61a976ef3e5ffc;hp=fdcec308414322a62dc16a6dd12f52ae2c783d76;hb=526c3af1dc98987b6949f4df73c0debccf9875bd;hpb=3287fb1d88a8322a767e45eaea431dacc05862dc diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index fdcec30..6eaac8c 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -1,23 +1,50 @@ % +% (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 -fno-warn-incomplete-patterns #-} +-- 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, funTyCon, - -- Re-exports from Kind - module Kind, + -- Kinds + Kind, SimpleKind, KindVar, + kindFunResult, splitKindFunTys, splitKindFunTysN, + + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + + tySuperKind, coSuperKind, + + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, + isCoSuperKind, isSuperKind, isCoercionKind, isEqPred, + mkArrowKind, mkArrowKinds, + + isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind, + isSubKindCon, -- Re-exports from TyCon PrimRep(..), mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, + splitAppTy_maybe, repSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, @@ -25,26 +52,30 @@ module Type ( mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, - splitTyConApp_maybe, splitTyConApp, + splitTyConApp_maybe, splitTyConApp, + splitNewTyConApp_maybe, splitNewTyConApp, - repType, typePrimRep, coreView, tcView, + repType, typePrimRep, coreView, tcView, kindView, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, dropForAlls, -- Source types - predTypeRep, mkPredTy, mkPredTys, + predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp, -- Newtypes - splitRecNewType_maybe, + 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, + typeKind, + + -- Type families + tyFamInsts, -- Tidying up for printing tidyType, tidyTypes, @@ -56,7 +87,7 @@ module Type ( -- Comparison coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, + tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, -- Seq seqType, seqTypes, @@ -67,14 +98,15 @@ 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, - pprPred, pprTheta, pprThetaArrow, pprClassPred + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, + pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind ) where #include "HsVersions.h" @@ -85,29 +117,23 @@ module Type ( import TypeRep -- friends: -import Kind -import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName, mkTyVar ) +import Var import VarEnv import VarSet -import OccName ( tidyOccName ) -import Name ( NamedThing(..), mkInternalName, tidyNameOcc ) -import Class ( Class, classTyCon ) -import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, - isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs, - isAlgTyCon, tyConArity, - tcExpandTyCon_maybe, coreExpandTyCon_maybe, - tyConKind, PrimRep(..), tyConPrimRep, - ) +import Name +import Class +import PrelNames +import TyCon -- others -import StaticFlags ( opt_DictsStrict ) -import SrcLoc ( noSrcLoc ) -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 FastString + +import Data.List +import Data.Maybe ( isJust ) \end{code} @@ -122,7 +148,7 @@ In Core, we "look through" non-recursive newtypes and PredTypes. \begin{code} {-# INLINE coreView #-} coreView :: Type -> Maybe Type --- Srips off the *top layer only* of a type to give +-- Strips off the *top layer only* of a type to give -- its underlying representation type. -- Returns Nothing if there is nothing to look through. -- @@ -141,23 +167,32 @@ coreView :: Type -> Maybe Type -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing -coreView (NoteTy _ ty) = Just ty -coreView (PredTy p) = Just (predTypeRep p) +coreView (PredTy p) + | isEqPred p = Nothing + | otherwise = Just (predTypeRep p) coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') -- Its important to use mkAppTys, rather than (foldl AppTy), -- because the function part might well return a -- partially-applied type constructor; indeed, usually will! -coreView ty = Nothing +coreView _ = Nothing + + ----------------------------------------------- {-# INLINE tcView #-} tcView :: Type -> Maybe Type -- Same, but for the type checker, which just looks through synonyms -tcView (NoteTy _ ty) = Just ty tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') -tcView ty = Nothing +tcView _ = Nothing + +----------------------------------------------- +{-# INLINE kindView #-} +kindView :: Kind -> Maybe Kind +-- C.f. coreView, tcView +-- For the moment, we don't even handle synonyms in kinds +kindView _ = Nothing \end{code} @@ -189,7 +224,8 @@ isTyVarTy ty = isJust (getTyVar_maybe ty) getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe other = Nothing +getTyVar_maybe _ = Nothing + \end{code} @@ -201,12 +237,12 @@ invariant that a TyConApp is always visibly so. mkAppTy maintains the invariant: use it. \begin{code} +mkAppTy :: Type -> Type -> Type mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1 where - mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) - mk_app ty1 = AppTy orig_ty1 orig_ty2 + mk_app _ = AppTy orig_ty1 orig_ty2 -- Note that the TyConApp could be an -- under-saturated type synonym. GHC allows that; e.g. -- type Foo k = k a -> k a @@ -226,34 +262,50 @@ mkAppTys orig_ty1 [] = orig_ty1 mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1 where - mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) -- mkTyConApp: see notes with mkAppTy - mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 + mk_app _ = foldl AppTy orig_ty1 orig_tys2 +------------- splitAppTy_maybe :: Type -> Maybe (Type, Type) -splitAppTy_maybe ty | Just ty' <- coreView ty = splitAppTy_maybe ty' -splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) -splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -splitAppTy_maybe (TyConApp tc tys) = case snocView tys of - Nothing -> Nothing - Just (tys',ty') -> Just (TyConApp tc tys', ty') -splitAppTy_maybe other = Nothing +splitAppTy_maybe ty | Just ty' <- coreView ty + = splitAppTy_maybe ty' +splitAppTy_maybe ty = repSplitAppTy_maybe ty +------------- +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) + | 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 Just pr -> pr Nothing -> panic "splitAppTy" +------------- splitAppTys :: Type -> (Type, [Type]) 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 (FunTy ty1 ty2) args = ASSERT( null args ) + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (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 _ (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) - split orig_ty ty args = (orig_ty, args) + split orig_ty _ args = (orig_ty, args) + \end{code} @@ -263,10 +315,11 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type +mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type -mkFunTys tys ty = foldr FunTy ty tys +mkFunTys tys ty = foldr mkFunTy ty tys isFunTy :: Type -> Bool isFunTy ty = isJust (splitFunTy_maybe ty) @@ -279,14 +332,14 @@ splitFunTy other = pprPanic "splitFunTy" (ppr other) splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe other = Nothing +splitFunTy_maybe _ = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args orig_ty (FunTy arg res) = split (arg:args) res res - split args orig_ty ty = (reverse args, orig_ty) + split args _ (FunTy arg res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) splitFunTysN :: Int -> Type -> ([Type], Type) -- Split off exactly n arg tys @@ -298,21 +351,21 @@ splitFunTysN n ty = case splitFunTy ty of { (arg, res) -> zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty where - split acc [] nty ty = (reverse acc, nty) + split acc [] nty _ = (reverse acc, nty) split acc xs nty ty | Just ty' <- coreView ty = split acc xs nty ty' - split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res - split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) + split acc (x:xs) _ (FunTy arg res) = split ((x,arg):acc) xs res res + split _ _ _ _ = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) funResultTy :: Type -> Type funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (FunTy arg res) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) +funResultTy (FunTy _arg res) = res +funResultTy ty = pprPanic "funResultTy" (ppr ty) funArgTy :: Type -> Type funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (FunTy arg res) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) +funArgTy (FunTy arg _res) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) \end{code} @@ -353,7 +406,30 @@ splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -splitTyConApp_maybe other = Nothing +splitTyConApp_maybe _ = Nothing + +-- Sometimes we do NOT want to look throught a newtype. When case matching +-- on a newtype we want a convenient way to access the arguments of a newty +-- constructor so as to properly form a coercion. +splitNewTyConApp :: Type -> (TyCon, [Type]) +splitNewTyConApp ty = case splitNewTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitNewTyConApp" (ppr ty) +splitNewTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) +splitNewTyConApp_maybe ty | Just ty' <- tcView ty = splitNewTyConApp_maybe ty' +splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +splitNewTyConApp_maybe _ = Nothing + +newTyConInstRhs :: TyCon -> [Type] -> Type +-- 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} @@ -376,6 +452,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 @@ -383,29 +484,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 _ ty = ty + -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. @@ -415,13 +521,12 @@ typePrimRep ty = case repType ty of FunTy _ _ -> PtrRep AppTy _ _ -> PtrRep -- See note below TyVarTy _ -> PtrRep - other -> pprPanic "typePrimRep" (ppr ty) + _ -> pprPanic "typePrimRep" (ppr ty) -- Types of the form 'f a' must be of kind *, not *#, so -- we are guaranteed that they are represented by pointers. -- 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} @@ -438,9 +543,8 @@ mkForAllTys :: [TyVar] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars isForAllTy :: Type -> Bool -isForAllTy (NoteTy _ ty) = isForAllTy ty isForAllTy (ForAllTy _ _) = True -isForAllTy other_ty = False +isForAllTy _ = False splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) splitForAllTy_maybe ty = splitFAT_m ty @@ -453,8 +557,8 @@ splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty t tvs = (reverse tvs, orig_ty) + split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) dropForAlls :: Type -> Type dropForAlls ty = snd (splitForAllTys ty) @@ -474,7 +578,7 @@ the expression. applyTy :: Type -> Type -> Type applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty -applyTy other arg = panic "applyTy" +applyTy _ _ = panic "applyTy" applyTys :: Type -> [Type] -> Type -- This function is interesting because @@ -535,31 +639,32 @@ predTypeRep (IParam _ ty) = ty predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -- Result might be a newtype application, but the consumer will -- look through that too if necessary -\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 +predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) + +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 -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon \end{code} @@ -574,15 +679,29 @@ splitRecNewType_maybe other = Nothing ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} typeKind :: Type -> Kind - -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (TyConApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys -typeKind (NoteTy _ ty) = typeKind ty -typeKind (PredTy _) = liftedTypeKind -- Predicates are always - -- represented by lifted types -typeKind (AppTy fun arg) = kindFunResult (typeKind fun) -typeKind (FunTy arg res) = liftedTypeKind -typeKind (ForAllTy tv ty) = typeKind ty +typeKind (TyConApp tycon tys) = ASSERT( not (isCoercionTyCon tycon) ) + -- We should be looking for the coercion kind, + -- not the type kind + foldr (\_ k -> kindFunResult k) (tyConKind tycon) 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) + -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), + -- not unliftedTypKind (#) + -- The only things that can be after a function arrow are + -- (a) types (of kind openTypeKind or its sub-kinds) + -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) + | isTySuperKind k = k + | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind + where + k = typeKind res + +predKind :: PredType -> Kind +predKind (EqPred {}) = coSuperKind -- A coercion kind! +predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are +predKind (IParam {}) = liftedTypeKind -- always represented by lifted types \end{code} @@ -593,8 +712,7 @@ typeKind (ForAllTy tv ty) = typeKind ty tyVarsOfType :: Type -> TyVarSet -- NB: for type synonyms tyVarsOfType does *not* expand the synonym tyVarsOfType (TyVarTy tv) = unitVarSet tv -tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys -tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs +tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys tyVarsOfType (PredTy sty) = tyVarsOfPred sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg @@ -604,16 +722,34 @@ tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred (IParam _ ty) = tyVarsOfType ty -tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys +tyVarsOfPred (IParam _ ty) = tyVarsOfType ty +tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys +tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 tyVarsOfTheta :: ThetaType -> TyVarSet tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet +\end{code} + + +%************************************************************************ +%* * +\subsection{Type families} +%* * +%************************************************************************ + +Type family instances occuring in a type after expanding synonyms. --- Add a Note with the free tyvars to the top of the type -addFreeTyVars :: Type -> Type -addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty -addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty +\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} @@ -630,13 +766,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 @@ -650,13 +790,13 @@ tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -- Treat a new tyvar as a binder, and give it a fresh tidy name -tidyOpenTyVar env@(tidy_env, subst) tyvar +tidyOpenTyVar env@(_, subst) tyvar = case lookupVarEnv subst tyvar of Just tyvar' -> (env, tyvar') -- Already substituted Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder tidyType :: TidyEnv -> Type -> Type -tidyType env@(tidy_env, subst) ty +tidyType env@(_, subst) ty = go ty where go (TyVarTy tv) = case lookupVarEnv subst tv of @@ -664,7 +804,6 @@ tidyType env@(tidy_env, subst) ty Just tv' -> TyVarTy tv' go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args - go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty) go (PredTy sty) = PredTy (tidyPred env sty) go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) @@ -672,13 +811,13 @@ tidyType env@(tidy_env, subst) ty where (envp, tvp) = tidyTyVarBndr env tv - go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars - +tidyTypes :: TidyEnv -> [Type] -> [Type] tidyTypes env tys = map (tidyType env) tys tidyPred :: TidyEnv -> PredType -> PredType tidyPred env (IParam n ty) = IParam n (tidyType env ty) tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) +tidyPred env (EqPred ty1 ty2) = EqPred (tidyType env ty1) (tidyType env ty2) \end{code} @@ -699,42 +838,11 @@ tidyTopType :: Type -> Type tidyTopType ty = tidyType emptyTidyEnv ty \end{code} - -%************************************************************************ -%* * - Tidying Kinds -%* * -%************************************************************************ - -We use a grevious hack for tidying KindVars. A TidyEnv contains -a (VarEnv Var) substitution, to express the renaming; but -KindVars are not Vars. The Right Thing ultimately is to make them -into Vars (and perhaps make Kinds into Types), but I just do a hack -here: I make up a TyVar just to remember the new OccName for the -renamed KindVar - \begin{code} + tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyKind env@(tidy_env, subst) (KindVar kvar) - | Just tv <- lookupVarEnv_Directly subst uniq - = (env, KindVar (setKindVarOcc kvar (getOccName tv))) - | otherwise - = ((tidy', subst'), KindVar kvar') - where - uniq = kindVarUniq kvar - (tidy', occ') = tidyOccName tidy_env (kindVarOcc kvar) - kvar' = setKindVarOcc kvar occ' - fake_tv = mkTyVar tv_name (panic "tidyKind:fake tv kind") - tv_name = mkInternalName uniq occ' noSrcLoc - subst' = extendVarEnv subst fake_tv fake_tv - -tidyKind env (FunKind k1 k2) - = (env2, FunKind k1' k2') - where - (env1, k1') = tidyKind env k1 - (env2, k2') = tidyKind env1 k2 +tidyKind env k = tidyOpenType env k -tidyKind env k = (env, k) -- Atomic kinds \end{code} @@ -753,21 +861,30 @@ isUnLiftedType :: Type -> Bool -- construct them isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' -isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty +isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType other = False +isUnLiftedType _ = False isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> isUnboxedTupleTyCon tc - other -> False + Just (tc, _ty_args) -> isUnboxedTupleTyCon tc + _ -> False -- 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 @@ -778,14 +895,16 @@ this function should be in TcType, but isStrictType is used by DataCon, which is below TcType in the hierarchy, so it's convenient to put it here. \begin{code} +isStrictType :: Type -> Bool isStrictType (PredTy pred) = isStrictPred pred isStrictType ty | Just ty' <- coreView ty = isStrictType ty' -isStrictType (ForAllTy tv ty) = isStrictType ty +isStrictType (ForAllTy _ ty) = isStrictType ty isStrictType (TyConApp tc _) = isUnLiftedTyCon tc -isStrictType other = False +isStrictType _ = False +isStrictPred :: PredType -> Bool isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) -isStrictPred other = False +isStrictPred _ = False -- We may be strict in dictionary types, but only if it -- has more than one component. -- [Being strict in a single-component dictionary risks @@ -800,7 +919,7 @@ isPrimitiveType :: Type -> Bool isPrimitiveType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) isPrimTyCon tc - other -> False + _ -> False \end{code} @@ -815,7 +934,6 @@ seqType :: Type -> () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (NoteTy note t2) = seqNote note `seq` seqType t2 seqType (PredTy p) = seqPred p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty @@ -824,12 +942,10 @@ seqTypes :: [Type] -> () seqTypes [] = () seqTypes (ty:tys) = seqType ty `seq` seqTypes tys -seqNote :: TyNote -> () -seqNote (FTVNote set) = sizeUniqSet set `seq` () - seqPred :: PredType -> () -seqPred (ClassP c tys) = c `seq` seqTypes tys -seqPred (IParam n ty) = n `seq` seqType ty +seqPred (ClassP c tys) = c `seq` seqTypes tys +seqPred (IParam n ty) = n `seq` seqType ty +seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2 \end{code} @@ -867,11 +983,11 @@ coreEqType t1 t2 -- attempt to expand one side or the other. -- Now deal with newtypes, synonyms, pred-tys - eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2 - | Just t2' <- coreView t2 = eq env t1 t2' + eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2 + | Just t2' <- coreView t2 = eq env t1 t2' -- Fall through case; not equal! - eq env t1 t2 = False + eq _ _ _ = False \end{code} @@ -902,6 +1018,9 @@ tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 tcEqPred :: PredType -> PredType -> Bool tcEqPred p1 p2 = isEqual $ cmpPred p1 p2 +tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool +tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 + tcCmpPred :: PredType -> PredType -> Ordering tcCmpPred p1 p2 = cmpPred p1 p2 @@ -909,6 +1028,28 @@ 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 + +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} @@ -937,43 +1078,49 @@ cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenC cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (PredTy p1) (PredTy p2) = cmpPredX env p1 p2 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2 -cmpTypeX env t1 (NoteTy _ t2) = cmpTypeX env t1 t2 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy -cmpTypeX env (AppTy _ _) (TyVarTy _) = GT - -cmpTypeX env (FunTy _ _) (TyVarTy _) = GT -cmpTypeX env (FunTy _ _) (AppTy _ _) = GT - -cmpTypeX env (TyConApp _ _) (TyVarTy _) = GT -cmpTypeX env (TyConApp _ _) (AppTy _ _) = GT -cmpTypeX env (TyConApp _ _) (FunTy _ _) = GT - -cmpTypeX env (ForAllTy _ _) (TyVarTy _) = GT -cmpTypeX env (ForAllTy _ _) (AppTy _ _) = GT -cmpTypeX env (ForAllTy _ _) (FunTy _ _) = GT -cmpTypeX env (ForAllTy _ _) (TyConApp _ _) = GT +cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT -cmpTypeX env (PredTy _) t2 = GT +cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT +cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT -cmpTypeX env _ _ = LT +cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT +cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT +cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT + +cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT +cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT + +cmpTypeX _ (PredTy _) _ = GT + +cmpTypeX _ _ _ = LT ------------- cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering -cmpTypesX env [] [] = EQ +cmpTypesX _ [] [] = EQ cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2 -cmpTypesX env [] tys = LT -cmpTypesX env ty [] = GT +cmpTypesX _ [] _ = LT +cmpTypesX _ _ [] = 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 _ (IParam {}) _ = LT +cmpPredX _ (ClassP {}) (IParam {}) = GT +cmpPredX _ (ClassP {}) (EqPred {}) = LT +cmpPredX _ (EqPred {}) _ = GT \end{code} PredTypes are used as a FM key in TcSimplify, @@ -995,11 +1142,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 @@ -1016,6 +1165,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 + + -------------------------------------------------------------- -} @@ -1041,9 +1222,11 @@ composeTvSubst in_scope env1 env2 where subst1 = TvSubst in_scope env1 +emptyTvSubst :: TvSubst emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv isEmptyTvSubst :: TvSubst -> Bool + -- See Note [Extending the TvSubstEnv] isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst @@ -1078,16 +1261,27 @@ extendTvSubstList (TvSubst in_scope env) tvs tys -- the types given; but it's just a thunk so with a bit of luck -- it'll never be evaluated +-- Note [Generating the in-scope set for a substitution] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we want to substitute [a -> ty1, b -> ty2] I used to +-- think it was enough to generate an in-scope set that includes +-- fv(ty1,ty2). But that's not enough; we really should also take the +-- free vars of the type we are substituting into! Example: +-- (forall b. (a,b,x)) [a -> List b] +-- Then if we use the in-scope set {b}, there is a danger we will rename +-- the forall'd variable to 'x' by mistake, getting this: +-- (forall x. (List b, x, x) +-- Urk! This means looking at all the calls to mkOpenTvSubst.... + + mkOpenTvSubst :: TvSubstEnv -> TvSubst mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst zipOpenTvSubst tyvars tys -#ifdef DEBUG - | length tyvars /= length tys + | debugIsOn && (length tyvars /= length tys) = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst | otherwise -#endif = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) -- mkTopTvSubst is called when doing top-level substitutions. @@ -1098,24 +1292,21 @@ mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs) zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst zipTopTvSubst tyvars tys -#ifdef DEBUG - | length tyvars /= length tys - = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst | otherwise -#endif = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys -#ifdef DEBUG - | length tyvars /= length tys + | debugIsOn && (length tyvars /= length tys) = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv | otherwise -#endif = zip_ty_env tyvars tys emptyVarEnv -- Later substitutions in the list over-ride earlier ones, -- but there should be no loops +zip_ty_env :: [TyVar] -> [Type] -> TvSubstEnv -> TvSubstEnv zip_ty_env [] [] env = env zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty) -- There used to be a special case for when @@ -1135,9 +1326,9 @@ zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr instance Outputable TvSubst where ppr (TvSubst ins env) - = brackets $ sep[ ptext SLIT("TvSubst"), - nest 2 (ptext SLIT("In scope:") <+> ppr ins), - nest 2 (ptext SLIT("Env:") <+> ppr env) ] + = brackets $ sep[ ptext (sLit "TvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Env:") <+> ppr env) ] \end{code} %************************************************************************ @@ -1167,6 +1358,7 @@ substTheta subst theta substPred :: TvSubst -> PredType -> PredType substPred subst (IParam n ty) = IParam n (subst_ty subst ty) substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) +substPred subst (EqPred ty1 ty2) = EqPred (subst_ty subst ty1) (subst_ty subst ty2) deShadowTy :: TyVarSet -> Type -> Type -- Remove any nested binders mentioning tvs deShadowTy tvs ty @@ -1174,59 +1366,247 @@ deShadowTy tvs ty where in_scope = mkInScopeSet tvs +subst_ty :: TvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- -- Note that the in_scope set is poked only if we hit a forall -- so it may often never be fully computed subst_ty subst ty = go ty where - go (TyVarTy tv) = substTyVar subst tv - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args + go (TyVarTy tv) = substTyVar subst tv + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args - go (PredTy p) = PredTy $! (substPred subst p) + go (PredTy p) = PredTy $! (substPred subst p) - go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note - - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- by [Int], represented with TyConApp - go (ForAllTy tv ty) = case substTyVarBndr subst tv of - (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) + go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (ForAllTy tv ty) = case substTyVarBndr subst tv of + (subst', tv') -> + ForAllTy tv' $! (subst_ty subst' ty) substTyVar :: TvSubst -> TyVar -> Type -substTyVar subst tv - = case lookupTyVar subst tv of - Nothing -> TyVarTy tv - Just ty' -> ty' -- See Note [Apply Once] +substTyVar subst@(TvSubst _ _) tv + = case lookupTyVar subst tv of { + 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 -lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv + -- See Note [Extending the TvSubst] +lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) substTyVarBndr subst@(TvSubst in_scope env) old_var - | old_var == new_var -- No need to clone - -- But we *must* zap any current substitution for the variable. - -- For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - -- - -- The new_id isn't cloned, but it may have a different type - -- etc, so we must return it, not the old id - = (TvSubst (in_scope `extendInScopeSet` new_var) - (delVarEnv env old_var), - new_var) - - | otherwise -- The new binder is in scope so - -- we'd better rename it away from the in-scope variables - -- Extending the substitution to do this renaming also - -- has the (correct) effect of discarding any existing - -- substitution for that variable - = (TvSubst (in_scope `extendInScopeSet` new_var) - (extendVarEnv env old_var (TyVarTy new_var)), - new_var) + = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) where - new_var = uniqAway in_scope old_var + is_co_var = isCoVar old_var + + new_env | no_change = delVarEnv env old_var + | otherwise = extendVarEnv env old_var (TyVarTy new_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 + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var = uniqAway in_scope subst_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 (tyVarKind old_var)) + | otherwise = old_var +\end{code} + +---------------------------------------------------- +-- Kind Stuff + +Kinds +~~~~~ +There's a little subtyping at the kind level: + + ? + / \ + / \ + ?? (#) + / \ + * # + +where * [LiftedTypeKind] means boxed type + # [UnliftedTypeKind] means unboxed type + (#) [UbxTupleKind] means unboxed tuple + ?? [ArgTypeKind] is the lub of *,# + ? [OpenTypeKind] means any type at all + +In particular: + + error :: forall a:?. String -> a + (->) :: ?? -> ? -> * + (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple) + +\begin{code} +type KindVar = TyVar -- invariant: KindVar will always be a + -- TcTyVar with details MetaTv TauTv ... +-- kind var constructors and functions are in TcType + +type SimpleKind = Kind +\end{code} + +Kind inference +~~~~~~~~~~~~~~ +During kind inference, a kind variable unifies only with +a "simple kind", sk + sk ::= * | sk1 -> sk2 +For example + data T a = MkT a (T Int#) +fails. We give T the kind (k -> *), and the kind variable k won't unify +with # (the kind of Int#). + +Type inference +~~~~~~~~~~~~~~ +When creating a fresh internal type variable, we give it a kind to express +constraints on it. E.g. in (\x->e) we make up a fresh type variable for x, +with kind ??. + +During unification we only bind an internal type variable to a type +whose kind is lower in the sub-kind hierarchy than the kind of the tyvar. + +When unifying two internal type variables, we collect their kind constraints by +finding the GLB of the two. Since the partial order is a tree, they only +have a glb if one is a sub-kind of the other. In that case, we bind the +less-informative one to the more informative one. Neat, eh? + + +\begin{code} + +\end{code} + +%************************************************************************ +%* * + Functions over Kinds +%* * +%************************************************************************ + +\begin{code} +kindFunResult :: Kind -> Kind +kindFunResult k = funResultTy k + +splitKindFunTys :: Kind -> ([Kind],Kind) +splitKindFunTys k = splitFunTys k + +splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) +splitKindFunTysN k = splitFunTysN k + +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 +-- True of any sub-kind of OpenTypeKind (i.e. anything except arrow) +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 + -- This is a conservative answer + -- It matters in the call to isSubKind in + -- checkExpectedKind. + +isSubArgTypeKindCon kc + | isUnliftedTypeKindCon kc = True + | isLiftedTypeKindCon kc = True + | isArgTypeKindCon kc = True + | otherwise = False + +isSubArgTypeKind :: Kind -> Bool +-- True of any sub-kind of ArgTypeKind +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 +-- (k1 `isSubKind` k2) checks that k1 <: k2 +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' +isSubKind _ _ = False + +eqKind :: Kind -> Kind -> Bool +eqKind = tcEqType + +isSubKindCon :: TyCon -> TyCon -> Bool +-- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2 +isSubKindCon kc1 kc2 + | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True + | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True + | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True + | isOpenTypeKindCon kc2 = True + -- we already know kc1 is not a fun, its a TyCon + | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True + | otherwise = False + +defaultKind :: Kind -> Kind +-- Used when generalising: default kind '?' and '??' to '*' +-- +-- When we generalise, we make generic type variables whose kind is +-- simple (* or *->* etc). So generic type variables (other than +-- built-in constants like 'error') always have simple kinds. This is important; +-- consider +-- f x = True +-- We want f to get type +-- f :: forall (a::*). a -> Bool +-- Not +-- f :: forall (a::??). a -> Bool +-- because that would allow a call like (f 3#) as well as (f True), +--and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. +defaultKind k + | isSubOpenTypeKind k = liftedTypeKind + | isSubArgTypeKind k = liftedTypeKind + | otherwise = k + +isEqPred :: PredType -> Bool +isEqPred (EqPred _ _) = True +isEqPred _ = False \end{code}