X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=8dfe475349809ed469452fb07c682b49e0b3bad1;hb=bcadca676448e38427b910bad5d7063f948a99c8;hp=07e61daf0008c079462ff08b333022bc1946a73b;hpb=32a5c61dc1df5e12aaf1f21e5928fbb261d62043;p=ghc-hetmet.git diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 07e61da..8dfe475 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -41,10 +41,10 @@ module Type ( applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, -- (Newtypes) - newTyConInstRhs, + newTyConInstRhs, carefullySplitNewType_maybe, -- (Type families) - tyFamInsts, + tyFamInsts, predFamInsts, -- (Source types) mkPredTy, mkPredTys, mkFamilyTyConApp, @@ -87,7 +87,7 @@ module Type ( -- * Type free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - typeKind, + typeKind, expandTypeSynonyms, -- * Tidying type related things up for printing tidyType, tidyTypes, @@ -132,7 +132,7 @@ module Type ( -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, - pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind, + pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind, pprSourceTyCon ) where @@ -281,6 +281,29 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys tcView _ = Nothing ----------------------------------------------- +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +expandTypeSynonyms ty + = go ty + where + go (TyConApp tc tys) + | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys + = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + | otherwise + = TyConApp tc (map go tys) + go (TyVarTy tv) = TyVarTy tv + go (AppTy t1 t2) = AppTy (go t1) (go t2) + go (FunTy t1 t2) = FunTy (go t1) (go t2) + go (ForAllTy tv t) = ForAllTy tv (go t) + go (PredTy p) = PredTy (go_pred p) + + 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 @@ -423,8 +446,8 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -- ^ Creates a function type from the given argument and result type -mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res -mkFunTy arg res = FunTy arg res +mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res +mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys @@ -534,7 +557,7 @@ splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitTyConApp_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 ) @@ -596,14 +619,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 @@ -618,19 +636,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. @@ -657,7 +681,7 @@ typePrimRep ty = case repType ty of \begin{code} mkForAllTy :: TyVar -> Type -> Type mkForAllTy tyvar ty - = mkForAllTys [tyvar] ty + = ForAllTy tyvar ty -- | Wraps foralls over the type using the provided 'TyVar's from left to right mkForAllTys :: [TyVar] -> Type -> Type @@ -739,8 +763,8 @@ applyTysD doc orig_fun_ty arg_tys (mkForAllTys (drop n_args tvs) rho_ty) | otherwise -- Too many type args = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infnite loop! - applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty) - (drop n_tvs arg_tys) + 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 @@ -887,6 +911,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}