X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=c36893bc7ae7a3bc4c01fbb1806107ce1dd0a287;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=649baea9f5280be8ac4d5dd929cd0ea66fd7c4ac;hpb=262c142b90c94ca1aa577c950a6ceae1f255e2d6;p=ghc-hetmet.git diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 649baea..c36893b 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -6,6 +6,13 @@ Type - public interface \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Type ( -- re-exports from TypeRep TyThing(..), Type, PredType(..), ThetaType, @@ -48,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, @@ -57,16 +64,19 @@ module Type ( predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp, -- Newtypes - splitRecNewType_maybe, newTyConInstRhs, + newTyConInstRhs, -- Lifting and boxity - isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType, - isStrictType, isStrictPred, + isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, + isPrimitiveType, isStrictType, isStrictPred, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, typeKind, addFreeTyVars, + -- Type families + tyFamInsts, + -- Tidying up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, @@ -77,7 +87,7 @@ module Type ( -- Comparison coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, + tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, -- Seq seqType, seqTypes, @@ -95,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 @@ -180,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 @@ -271,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 @@ -287,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) @@ -407,11 +437,15 @@ splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitNewTyConApp_maybe other = Nothing --- get instantiated newtype rhs, the arguments had better saturate --- the constructor newTyConInstRhs :: TyCon -> [Type] -> Type -newTyConInstRhs tycon tys = - let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty +-- Unwrap one 'layer' of newtype +-- Use the eta'd version if possible +newTyConInstRhs tycon tys + = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs ) + mkAppTys (substTyWith tvs tys1 ty) tys2 + where + (tvs, ty) = newTyConEtadRhs tycon + (tys1, tys2) = splitAtList tvs tys \end{code} @@ -434,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 @@ -447,32 +506,28 @@ 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) - | isClosedNewTyCon 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 - --- 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 - - --- new_type_rep doesn't ask any questions: --- it just expands newtype, whether recursive or not -new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) - case newTyConRep new_tycon of - (tvs, rep_ty) -> substTyWith tvs tys rep_ty +repType ty + = go [] ty + where + go :: [TyCon] -> Type -> Type + go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms + = go rec_nts ty' + + go rec_nts (ForAllTy _ ty) -- Look through foralls + = go rec_nts ty + + go rec_nts ty@(TyConApp tc tys) -- Expand newtypes + | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes] + = if tc `elem` rec_nts -- in Type.lhs + then ty + else go rec_nts' nt_rhs + where + nt_rhs = newTyConInstRhs tc tys + rec_nts' | isRecursiveTyCon tc = tc:rec_nts + | otherwise = rec_nts + + go rec_nts ty = ty + -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. @@ -488,7 +543,6 @@ typePrimRep ty = case repType ty of -- The reason is that f must have kind *->*, not *->*#, because -- (we claim) there is no way to constrain f's kind any other -- way. - \end{code} @@ -632,31 +686,6 @@ pprSourceTyCon tycon %************************************************************************ %* * - 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) - | isClosedNewTyCon 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 -\end{code} - - -%************************************************************************ -%* * \subsection{Kinds and free variables} %* * %************************************************************************ @@ -727,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} %* * %************************************************************************ @@ -846,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 @@ -992,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} @@ -1498,8 +1581,6 @@ isSuperKind other = False isKind :: Kind -> Bool isKind k = isSuperKind (typeKind k) - - isSubKind :: Kind -> Kind -> Bool -- (k1 `isSubKind` k2) checks that k1 <: k2 isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2