X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=3705914140e8d018224c7c8f5b82b387ca745eb4;hb=59fa6266f00b6edcfc20c491c8de9a1b215dfa22;hp=63633e9694eb93cd752dafdc9d89c5f82ca226d2;hpb=2cd930397966d27a221998c8ac060151e2027e90;p=ghc-hetmet.git diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 63633e9..3705914 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -36,16 +36,15 @@ module Type ( mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, - splitNewTyConApp_maybe, splitNewTyConApp, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, isForAllTy, dropForAlls, + applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, -- (Newtypes) - newTyConInstRhs, + newTyConInstRhs, carefullySplitNewType_maybe, -- (Type families) - tyFamInsts, + tyFamInsts, predFamInsts, -- (Source types) mkPredTy, mkPredTys, mkFamilyTyConApp, @@ -128,7 +127,7 @@ module Type ( isEmptyTvSubst, -- ** Performing substitution on types - substTy, substTys, substTyWith, substTheta, + substTy, substTys, substTyWith, substTysWith, substTheta, substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, -- * Pretty-printing @@ -534,22 +533,8 @@ splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitTyConApp_maybe _ = Nothing --- | Sometimes we do NOT want to look through a @newtype@. When case matching --- on a newtype we want a convenient way to access the arguments of a @newtype@ --- constructor so as to properly form a coercion, and so we use 'splitNewTyConApp' --- instead of 'splitTyConApp_maybe' -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 on a type constructor and it's arguments, using an +-- ^ Unwrap one 'layer' of newtype on a type constructor and its arguments, using an -- eta-reduced version of the @newtype@ if possible newTyConInstRhs tycon tys = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs ) @@ -611,14 +596,9 @@ newtype at outermost level; and bale out if we see it again. -- | Looks through: -- -- 1. For-alls --- -- 2. Synonyms --- -- 3. Predicates --- --- 4. Usage annotations --- --- 5. All newtypes, including recursive ones, but not newtype families +-- 4. All newtypes, including recursive ones, but not newtype families -- -- It's useful in the back end of the compiler. repType :: Type -> Type @@ -633,19 +613,25 @@ repType 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 (TyConApp tc tys) -- Expand newtypes + | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys + = go rec_nts' ty' go _ ty = ty +carefullySplitNewType_maybe :: [TyCon] -> TyCon -> [Type] -> Maybe ([TyCon],Type) +-- Return the representation of a newtype, unless +-- we've seen it already: see Note [Expanding newtypes] +carefullySplitNewType_maybe rec_nts tc tys + | isNewTyCon tc + , not (tc `elem` rec_nts) = Just (rec_nts', newTyConInstRhs tc tys) + | otherwise = Nothing + where + rec_nts' | isRecursiveTyCon tc = tc:rec_nts + | otherwise = rec_nts + + -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. @@ -742,17 +728,20 @@ applyTys :: Type -> [Type] -> Type -- > foo = case undefined :: R of -- > R f -> f () -applyTys orig_fun_ty [] = orig_fun_ty -applyTys orig_fun_ty arg_tys +applyTys ty args = applyTysD empty ty args + +applyTysD :: SDoc -> Type -> [Type] -> Type -- Debug version +applyTysD _ orig_fun_ty [] = orig_fun_ty +applyTysD doc orig_fun_ty arg_tys | n_tvs == n_args -- The vastly common case = substTyWith tvs arg_tys rho_ty | n_tvs > n_args -- Too many for-alls = substTyWith (take n_args tvs) arg_tys (mkForAllTys (drop n_args tvs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, ppr orig_fun_ty ) -- Zero case gives infnite loop! - applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty) - (drop n_tvs arg_tys) + = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infnite loop! + applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty) + (drop n_tvs arg_tys) where (tvs, rho_ty) = splitForAllTys orig_fun_ty n_tvs = length tvs @@ -899,6 +888,14 @@ tyFamInsts (TyConApp tc tys) tyFamInsts (FunTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 tyFamInsts (AppTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 tyFamInsts (ForAllTy _ ty) = tyFamInsts ty +tyFamInsts (PredTy pty) = predFamInsts pty + +-- | Finds type family instances occuring in a predicate type after expanding +-- synonyms. +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} @@ -1159,14 +1156,16 @@ coreEqType t1 t2 \begin{code} tcEqType :: Type -> Type -> Bool --- ^ Type equality on source types. Does not look through @newtypes@ or 'PredType's +-- ^ 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 +-- ^ 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 tcCmpTypes :: [Type] -> [Type] -> Ordering @@ -1511,6 +1510,12 @@ substTyWith :: [TyVar] -> [Type] -> Type -> Type substTyWith tvs tys = ASSERT( length tvs == length tys ) substTy (zipOpenTvSubst tvs tys) +-- | Type substitution making use of an 'TvSubst' that +-- is assumed to be open, see 'zipOpenTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( length tvs == length tys ) + substTys (zipOpenTvSubst tvs tys) + -- | Substitute within a 'Type' substTy :: TvSubst -> Type -> Type substTy subst ty | isEmptyTvSubst subst = ty