X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;fp=compiler%2Ftypes%2FType.lhs;h=995d7a9c1d5e69c272d243bd6dc6b50e31816ed4;hp=c9bf3f5d65a8af33e75053314fb75c4161d4a615;hb=1b381af863d64aaa0a4dd9c816170c58e6131a9e;hpb=c25b934ef544fa3eba0a9f9da41b363c470156cb diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index c9bf3f5..995d7a9 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -20,7 +20,8 @@ module Type ( -- $type_classification -- $representation_types - TyThing(..), Type, PredType(..), ThetaType, + TyThing(..), Type, Pred(..), PredType, ThetaType, + Var, TyVar, isTyVar, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, @@ -45,14 +46,20 @@ module Type ( -- (Type families) tyFamInsts, predFamInsts, - -- (Source types) - mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred, + -- Pred types + mkPredTy, mkPredTys, mkFamilyTyConApp, + mkDictTy, isDictLikeTy, isClassPred, + isEqPred, allPred, mkEqPred, + mkClassPred, getClassPredTys, getClassPredTys_maybe, + isTyVarClassPred, + mkIPPred, isIPPred, -- ** Common type constructors funTyCon, -- ** Predicates on types - isTyVarTy, isFunTy, isDictTy, + isTyVarTy, isFunTy, isPredTy, + isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, @@ -65,8 +72,7 @@ module Type ( -- ** Common Kinds and SuperKinds liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, - - tySuperKind, coSuperKind, + tySuperKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, @@ -74,19 +80,18 @@ module Type ( -- * Type free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - expandTypeSynonyms, + exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms, typeSize, -- * Type comparison - coreEqType, coreEqType2, - tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, + eqType, eqTypeX, eqTypes, cmpType, cmpTypes, + eqPred, eqPredX, cmpPred, eqKind, -- * Forcing evaluation of types - seqType, seqTypes, + seqType, seqTypes, seqPred, -- * Other views onto Types - coreView, tcView, kindView, + coreView, tcView, repType, @@ -103,18 +108,22 @@ module Type ( emptyTvSubstEnv, emptyTvSubst, mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, - getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, + getTvSubstEnv, setTvSubstEnv, + zapTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList, - extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, + extendTvSubst, extendTvSubstList, + isInScope, composeTvSubst, zipTyEnv, isEmptyTvSubst, unionTvSubst, -- ** Performing substitution on types substTy, substTys, substTyWith, substTysWith, substTheta, - substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, + substPred, substTyVar, substTyVars, substTyVarBndr, + deShadowTy, lookupTyVar, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, - pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind, + pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprSourceTyCon ) where @@ -133,8 +142,11 @@ import VarSet import Class import TyCon +import TysPrim -- others +import BasicTypes ( IPName ) +import Name ( Name ) import StaticFlags import Util import Outputable @@ -219,31 +231,9 @@ coreView :: Type -> Maybe Type -- its underlying representation type. -- Returns Nothing if there is nothing to look through. -- --- In the case of @newtype@s, it returns one of: --- --- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated) --- --- 2) The newtype representation (otherwise), meaning the --- type written in the RHS of the newtype declaration, --- which may itself be a newtype --- --- For example, with: --- --- > newtype R = MkR S --- > newtype S = MkS T --- > newtype T = MkT (T -> T) --- --- 'expandNewTcApp' on: --- --- * @R@ gives @Just S@ --- * @S@ gives @Just T@ --- * @T@ gives @Nothing@ (no expansion) - -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing -coreView (PredTy p) - | isEqPred p = Nothing - | otherwise = Just (predTypeRep p) +coreView (PredTy p) = 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), @@ -252,7 +242,6 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc coreView _ = Nothing - ----------------------------------------------- {-# INLINE tcView #-} tcView :: Type -> Maybe Type @@ -283,14 +272,6 @@ expandTypeSynonyms ty go_pred (ClassP c ts) = ClassP c (map go ts) go_pred (IParam ip t) = IParam ip (go t) go_pred (EqPred t1 t2) = EqPred (go t1) (go t2) - ------------------------------------------------ -{-# INLINE kindView #-} -kindView :: Kind -> Maybe Kind --- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's - --- For the moment, we don't even handle synonyms in kinds -kindView _ = Nothing \end{code} @@ -305,12 +286,6 @@ kindView _ = Nothing TyVarTy ~~~~~~~ \begin{code} -mkTyVarTy :: TyVar -> Type -mkTyVarTy = TyVarTy - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - -- | Attempts to obtain the type variable underlying a 'Type', and panics with the -- given message if this is not a type variable type. See also 'getTyVar_maybe' getTyVar :: String -> Type -> TyVar @@ -384,10 +359,9 @@ repSplitAppTy_maybe :: Type -> Maybe (Type,Type) repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) - | isDecomposableTyCon 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 + | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! repSplitAppTy_maybe _other = Nothing ------------- splitAppTy :: Type -> (Type, Type) @@ -427,8 +401,7 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -- ^ Creates a function type from the given argument and result type -mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res -mkFunTy arg res = FunTy arg res +mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys @@ -496,20 +469,6 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty) ~~~~~~~~ \begin{code} --- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. --- Applies its arguments to the constructor from left to right -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = mkTyConApp tycon [] - -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -612,13 +571,16 @@ 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 (ForAllTy _ ty) -- Look through foralls = go rec_nts ty - go rec_nts (TyConApp tc tys) -- Expand newtypes + go rec_nts (PredTy p) -- Expand predicates + = go rec_nts (predTypeRep p) + + go rec_nts (TyConApp tc tys) -- Expand newtypes and synonyms + | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys + = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys = go rec_nts' ty' @@ -756,13 +718,32 @@ applyTysD doc orig_fun_ty arg_tys %************************************************************************ %* * -\subsection{Source types} + Pred %* * %************************************************************************ -Source types are always lifted. +Polymorphic functions over Pred -The key function is predTypeRep which gives the representation of a source type: +\begin{code} +allPred :: (a -> Bool) -> Pred a -> Bool +allPred p (ClassP _ ts) = all p ts +allPred p (IParam _ t) = p t +allPred p (EqPred t1 t2) = p t1 && p t2 + +isClassPred :: Pred a -> Bool +isClassPred (ClassP {}) = True +isClassPred _ = False + +isEqPred :: Pred a -> Bool +isEqPred (EqPred {}) = True +isEqPred _ = False + +isIPPred :: Pred a -> Bool +isIPPred (IParam {}) = True +isIPPred _ = False +\end{code} + +Make PredTypes \begin{code} mkPredTy :: PredType -> Type @@ -771,91 +752,115 @@ mkPredTy pred = PredTy pred mkPredTys :: ThetaType -> [Type] mkPredTys preds = map PredTy preds -isEqPred :: PredType -> Bool -isEqPred (EqPred _ _) = True -isEqPred _ = False - predTypeRep :: PredType -> Type -- ^ Convert a 'PredType' to its representation type. However, it unwraps -- only the outermost level; for example, the result might be a newtype application 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 -predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) +predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [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 --- --- Where the instance tycon is :RTL, so: --- --- > 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 +splitPredTy_maybe :: Type -> Maybe PredType +-- Returns Just for predicates only +splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty' +splitPredTy_maybe (PredTy p) = Just p +splitPredTy_maybe _ = Nothing --- | Pretty prints a 'TyCon', using the family instance in case of a --- representation tycon. For example: --- --- > 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 - -isDictTy :: Type -> Bool -isDictTy ty = case splitTyConApp_maybe ty of - Just (tc, _) -> isClassTyCon tc - Nothing -> False +isPredTy :: Type -> Bool +isPredTy ty = isJust (splitPredTy_maybe ty) \end{code} +--------------------- Equality types --------------------------------- +\begin{code} +isReflPredTy :: Type -> Bool +isReflPredTy ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> ty1 `eqType` ty2 + _ -> False + +splitEqPredTy_maybe :: Type -> Maybe (Type,Type) +splitEqPredTy_maybe ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> Just (ty1,ty2) + _ -> Nothing + +isEqPredTy :: Type -> Bool +isEqPredTy ty = case splitPredTy_maybe ty of + Just (EqPred {}) -> True + _ -> False + +-- | Creates a type equality predicate +mkEqPred :: (a, a) -> Pred a +mkEqPred (ty1, ty2) = EqPred ty1 ty2 +\end{code} -%************************************************************************ -%* * - The free variables of a type -%* * -%************************************************************************ - +--------------------- Dictionary types --------------------------------- \begin{code} -tyVarsOfType :: Type -> TyVarSet --- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym -tyVarsOfType (TyVarTy tv) = unitVarSet tv -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 -tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder - -- can mention type variables! - | isTyVar tv = inner_tvs `delVarSet` tv - | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) ) - inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv) - where - inner_tvs = tyVarsOfType ty +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = ClassP clas tys -tyVarsOfTypes :: [Type] -> TyVarSet -tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys +isDictTy :: Type -> Bool +isDictTy ty = case splitPredTy_maybe ty of + Just p -> isClassPred p + Nothing -> False + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys +isTyVarClassPred _ = False + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) +getClassPredTys_maybe _ = Nothing + +getClassPredTys :: PredType -> (Class, [Type]) +getClassPredTys (ClassP clas tys) = (clas, tys) +getClassPredTys _ = panic "getClassPredTys" + +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = mkPredTy (ClassP clas tys) + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' +isDictLikeTy (PredTy p) = isClassPred p +isDictLikeTy (TyConApp tc tys) + | isTupleTyCon tc = all isDictLikeTy tys +isDictLikeTy _ = False +\end{code} -tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred (IParam _ ty) = tyVarsOfType ty -tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys -tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + +--------------------- Implicit parameters --------------------------------- -tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet +\begin{code} +mkIPPred :: IPName Name -> Type -> PredType +mkIPPred ip ty = IParam ip ty \end{code} - %************************************************************************ %* * Size @@ -867,14 +872,9 @@ typeSize :: Type -> Int typeSize (TyVarTy _) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (PredTy p) = predSize p +typeSize (PredTy p) = predSize typeSize p typeSize (ForAllTy _ t) = 1 + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) - -predSize :: PredType -> Int -predSize (IParam _ t) = 1 + typeSize t -predSize (ClassP _ ts) = 1 + sum (map typeSize ts) -predSize (EqPred t1 t2) = typeSize t1 + typeSize t2 \end{code} @@ -904,8 +904,37 @@ predFamInsts :: PredType -> [(TyCon, [Type])] predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys) predFamInsts (IParam _ ty) = tyFamInsts ty predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 -\end{code} +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 +-- +-- Where the instance tycon is :RTL, so: +-- +-- > 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: +-- +-- > 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} %************************************************************************ %* * @@ -924,6 +953,7 @@ isUnLiftedType :: Type -> Bool isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty +isUnLiftedType (PredTy p) = isEqPred p isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc isUnLiftedType _ = False @@ -977,7 +1007,8 @@ isStrictType _ = False -- poking the dictionary component, which is wrong.) isStrictPred :: PredType -> Bool isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) -isStrictPred _ = False +isStrictPred (EqPred {}) = True +isStrictPred (IParam {}) = False \end{code} \begin{code} @@ -994,6 +1025,64 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of %************************************************************************ %* * + The "exact" free variables of a type +%* * +%************************************************************************ + +Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! +Here's the example that Ralf Laemmel showed me: + foo :: (forall a. C u a -> C u a) -> u + mappend :: Monoid u => u -> u -> u + + bar :: Monoid u => u + bar = foo (\t -> t `mappend` t) +We have to generalise at the arg to f, and we don't +want to capture the constraint (Monad (C u a)) because +it appears to mention a. Pretty silly, but it was useful to him. + +exactTyVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It's also used in the +smart-app checking code --- see TcExpr.tcIdApp + +On the other hand, consider a *top-level* definition + f = (\x -> x) :: T a -> T a +If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then +if we have an application like (f "x") we get a confusing error message +involving Any. So the conclusion is this: when generalising + - at top level use tyVarsOfType + - in nested bindings use exactTyVarsOfType +See Trac #1813 for example. + +\begin{code} +exactTyVarsOfType :: Type -> TyVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. +exactTyVarsOfType ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' -- This is the key line + go (TyVarTy tv) = unitVarSet tv + go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (PredTy ty) = go_pred ty + go (FunTy arg res) = go arg `unionVarSet` go res + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + + go_pred (IParam _ ty) = go ty + go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 + +exactTyVarsOfTypes :: [Type] -> TyVarSet +exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys +\end{code} + + +%************************************************************************ +%* * \subsection{Sequencing on types} %* * %************************************************************************ @@ -1003,7 +1092,7 @@ 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 (PredTy p) = seqPred p +seqType (PredTy p) = seqPred seqType p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty @@ -1011,115 +1100,40 @@ seqTypes :: [Type] -> () seqTypes [] = () seqTypes (ty:tys) = seqType ty `seq` seqTypes tys -seqPred :: PredType -> () -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 +seqPred :: (a -> ()) -> Pred a -> () +seqPred seqt (ClassP c tys) = c `seq` foldr (seq . seqt) () tys +seqPred seqt (IParam n ty) = n `seq` seqt ty +seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2 \end{code} %************************************************************************ %* * - Equality for Core types + Comparision for types (We don't use instances so that we know where it happens) %* * %************************************************************************ -Note that eqType works right even for partial applications of newtypes. -See Note [Newtype eta] in TyCon.lhs - \begin{code} --- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.) -coreEqType :: Type -> Type -> Bool -coreEqType t1 t2 = coreEqType2 rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) - -coreEqType2 :: RnEnv2 -> Type -> Type -> Bool -coreEqType2 rn_env t1 t2 - = eq rn_env t1 t2 - where - eq env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 - eq env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2 - eq env (AppTy s1 t1) (AppTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (FunTy s1 t1) (FunTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, all2 (eq env) tys1 tys2 = True - -- The lengths should be equal because - -- the two types have the same kind - -- NB: if the type constructors differ that does not - -- necessarily mean that the types aren't equal - -- (synonyms, newtypes) - -- Even if the type constructors are the same, but the arguments - -- differ, the two types could be the same (e.g. if the arg is just - -- ignored in the RHS). In both these cases we fall through to an - -- 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' - - -- Fall through case; not equal! - eq _ _ _ = False -\end{code} - +eqKind :: Kind -> Kind -> Bool +eqKind = eqType -%************************************************************************ -%* * - Comparision for source types - (We don't use instances so that we know where it happens) -%* * -%************************************************************************ - -\begin{code} -tcEqType :: Type -> Type -> Bool +eqType :: Type -> Type -> Bool -- ^ Type equality on source types. Does not look through @newtypes@ or -- 'PredType's, but it does look through type synonyms. -tcEqType t1 t2 = isEqual $ cmpType t1 t2 - -tcEqTypes :: [Type] -> [Type] -> Bool -tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 - -tcCmpType :: Type -> Type -> Ordering --- ^ Type ordering on source types. Does not look through @newtypes@ or --- 'PredType's, but it does look through type synonyms. -tcCmpType t1 t2 = cmpType t1 t2 +eqType t1 t2 = isEqual $ cmpType t1 t2 -tcCmpTypes :: [Type] -> [Type] -> Ordering -tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -tcEqPred :: PredType -> PredType -> Bool -tcEqPred p1 p2 = isEqual $ cmpPred p1 p2 +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 -tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool -tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 +eqPred :: PredType -> PredType -> Bool +eqPred p1 p2 = isEqual $ cmpPred p1 p2 -tcCmpPred :: PredType -> PredType -> Ordering -tcCmpPred p1 p2 = cmpPred p1 p2 - -tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool -tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -\end{code} - -\begin{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.) -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 +eqPredX :: RnEnv2 -> PredType -> PredType -> Bool +eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 \end{code} Now here comes the real worker @@ -1141,8 +1155,13 @@ cmpPred p1 p2 = cmpPredX rn_env p1 p2 rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2)) cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2 - | Just t2' <- tcView t2 = cmpTypeX env t1 t2' +cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 + | Just t2' <- coreView t2 = cmpTypeX env t1 t2' +-- We expand predicate types, because in Core-land we have +-- lots of definitions like +-- fOrdBool :: Ord Bool +-- fOrdBool = D:Ord .. .. .. +-- So the RHS has a data type cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 @@ -1199,8 +1218,8 @@ PredTypes are used as a FM key in TcSimplify, so we take the easy path and make them an instance of Ord \begin{code} -instance Eq PredType where { (==) = tcEqPred } -instance Ord PredType where { compare = tcCmpPred } +instance Eq PredType where { (==) = eqPred } +instance Ord PredType where { compare = cmpPred } \end{code} @@ -1211,81 +1230,6 @@ instance Ord PredType where { compare = tcCmpPred } %************************************************************************ \begin{code} --- | Type substitution --- --- #tvsubst_invariant# --- The following invariants must hold of a 'TvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substition is only applied ONCE! This is because --- in general such application will not reached a fixed point. -data TvSubst - = TvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- The substitution itself - -- See Note [Apply Once] - -- and Note [Extending the TvSubstEnv] - -{- ---------------------------------------------------------- - -Note [Apply Once] -~~~~~~~~~~~~~~~~~ -We use TvSubsts to instantiate things, and we might instantiate - forall a b. ty -\with the types - [a, b], or [b, a]. -So the substition might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substition that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - *************************************************** - *** So a TvSubst must be applied precisely once *** - *************************************************** - -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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tvsubst_invariant# for the invariants that must hold. - -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 kind 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 - - --------------------------------------------------------------- -} - --- | A substitition of 'Type's for 'TyVar's -type TvSubstEnv = TyVarEnv Type - -- A TvSubstEnv is used both inside a TvSubst (with the apply-once - -- invariant discussed in Note [Apply Once]), and also independently - -- in the middle of matching, and unification (see Types.Unify) - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever - emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv @@ -1303,11 +1247,11 @@ composeTvSubst in_scope env1 env2 subst1 = TvSubst in_scope env1 emptyTvSubst :: TvSubst -emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv +emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv isEmptyTvSubst :: TvSubst -> Bool -- See Note [Extending the TvSubstEnv] -isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env +isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst mkTvSubst = TvSubst @@ -1321,34 +1265,34 @@ getTvInScope (TvSubst in_scope _) = in_scope isInScope :: Var -> TvSubst -> Bool isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope -notElemTvSubst :: TyVar -> TvSubst -> Bool -notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env) +notElemTvSubst :: TyCoVar -> TvSubst -> Bool +notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst -setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env +setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv zapTvSubstEnv :: TvSubst -> TvSubst zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv extendTvInScope :: TvSubst -> Var -> TvSubst -extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env +extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv extendTvInScopeList :: TvSubst -> [Var] -> TvSubst -extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env +extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst -extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty) +extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty) extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst -extendTvSubstList (TvSubst in_scope env) tvs tys - = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) +extendTvSubstList (TvSubst in_scope tenv) tvs tys + = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys)) unionTvSubst :: TvSubst -> TvSubst -> TvSubst -- Works when the ranges are disjoint -unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2) - = ASSERT( not (env1 `intersectsVarEnv` env2) ) +unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) ) TvSubst (in_scope1 `unionInScope` in_scope2) - (env1 `plusVarEnv` env2) + (tenv1 `plusVarEnv` tenv2) -- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from -- the types given; but it's just a thunk so with a bit of luck @@ -1370,7 +1314,7 @@ unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2) -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming -- environment, hence "open" mkOpenTvSubst :: TvSubstEnv -> TvSubst -mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env +mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming -- environment, hence "open" @@ -1396,7 +1340,7 @@ zipTopTvSubst tyvars tys zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn && (length tyvars /= length tys) - = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv + = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv | otherwise = zip_ty_env tyvars tys emptyVarEnv @@ -1421,10 +1365,10 @@ zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr -- zip_ty_env _ _ env = env instance Outputable TvSubst where - ppr (TvSubst ins env) + ppr (TvSubst ins tenv) = brackets $ sep[ ptext (sLit "TvSubst"), nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Env:") <+> ppr env) ] + nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ] \end{code} %************************************************************************ @@ -1499,29 +1443,34 @@ subst_ty subst ty ForAllTy tv' $! (subst_ty subst' ty) substTyVar :: TvSubst -> TyVar -> Type -substTyVar subst@(TvSubst _ _) tv - = case lookupTyVar subst tv of { - Nothing -> TyVarTy tv; - Just ty -> ty -- See Note [Apply Once] - } +substTyVar (TvSubst _ tenv) tv + | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once] + | otherwise = ASSERT( isTyVar tv ) TyVarTy tv + -- We do not require that the tyvar is in scope + -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau) + -- and it's a nuisance to bring all the free vars of tau into + -- scope --- and then force that thunk at every tyvar + -- Instead we have an ASSERT in substTyVarBndr to check for capture substTyVars :: TvSubst -> [TyVar] -> [Type] substTyVars subst tvs = map (substTyVar subst) tvs lookupTyVar :: TvSubst -> TyVar -> Maybe Type -- See Note [Extending the TvSubst] -lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv +lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv -substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVarBndr subst@(TvSubst in_scope env) old_var - = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) +substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVarBndr subst@(TvSubst in_scope tenv) old_var + = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) + (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) where - is_co_var = isCoVar old_var + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - new_env | no_change = delVarEnv env old_var - | otherwise = extendVarEnv env old_var (TyVarTy new_var) + _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) + -- Check that we are not capturing something in the substitution - no_change = new_var == old_var && not is_co_var + no_change = new_var == old_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] @@ -1532,14 +1481,8 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var -- (\x.e) with id_subst = [x |-> e'] -- Here we must simply zap the substitution for x - new_var = uniqAway in_scope subst_old_var + new_var = uniqAway in_scope 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} ----------------------------------------------------