X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=c36893bc7ae7a3bc4c01fbb1806107ce1dd0a287;hb=5642651b4ac4da3c9c5981ffcde9baf09217a296;hp=4146fa7ad9cf719ae56d0e33d1f2527736e1d212;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 4146fa7..c36893b 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -10,7 +10,7 @@ Type - public interface -- 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/CodingStyle#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module Type ( @@ -55,7 +55,7 @@ module Type ( splitTyConApp_maybe, splitTyConApp, splitNewTyConApp_maybe, splitNewTyConApp, - repType, repType', typePrimRep, coreView, tcView, kindView, + repType, typePrimRep, coreView, tcView, kindView, rttiView, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, dropForAlls, @@ -67,13 +67,16 @@ module Type ( 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, @@ -84,7 +87,7 @@ module Type ( -- Comparison coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, + tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, -- Seq seqType, seqTypes, @@ -102,7 +105,7 @@ module Type ( substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, -- Pretty-printing - pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind ) where @@ -187,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 @@ -278,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 @@ -294,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) @@ -415,8 +438,14 @@ splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitNewTyConApp_maybe other = Nothing 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} @@ -439,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 @@ -452,28 +506,27 @@ 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 - , (tvs, rep_ty) <- newTyConRep 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( tys `lengthIs` tyConArity tc ) - repType (substTyWith tvs tys rep_ty) - -repType ty = ty - --- repType' aims to be a more thorough version of repType --- For now it simply looks through the TyConApp args too -repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined - | otherwise = go1 ty - where - go1 = go . repType - go (TyConApp tc tys) = mkTyConApp tc (map repType' tys) - go ty = 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 @@ -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} %* * %************************************************************************ @@ -822,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 @@ -968,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}