X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=4bf54170c2fec4e94a5af0bf8ee47ec71f136386;hp=88a7bc78e1375b3e79f508e9b598815f5544f767;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=94b170a053c161d1e0cc4418b37a6a4807872a5f diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 88a7bc7..4bf5417 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,16 +55,16 @@ module Type ( splitTyConApp_maybe, splitTyConApp, splitNewTyConApp_maybe, splitNewTyConApp, - repType, typePrimRep, coreView, tcView, kindView, + repType, repType', typePrimRep, coreView, tcView, kindView, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, dropForAlls, -- Source types - predTypeRep, mkPredTy, mkPredTys, + predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp, -- Newtypes - splitRecNewType_maybe, newTyConInstRhs, + newTyConInstRhs, -- Lifting and boxity isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType, @@ -88,13 +95,14 @@ module Type ( mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, + isEmptyTvSubst, -- Performing substitution on types substTy, substTys, substTyWith, substTheta, - substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar, + substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll, pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind ) where @@ -121,6 +129,7 @@ import Util import Outputable import UniqSet +import Data.List import Data.Maybe ( isJust ) \end{code} @@ -405,12 +414,9 @@ 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 - \end{code} @@ -449,19 +455,26 @@ repType :: Type -> Type 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) + | 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 --- 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' 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 + -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. @@ -477,7 +490,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} @@ -592,34 +604,30 @@ 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)) -\end{code} - - -%************************************************************************ -%* * - 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 - - +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 -- Instance tycon :RTL +-- Then +-- 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 +-- e.g. data T [a] = ... +-- In that case we want to print `T [a]', where T is the family TyCon +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon \end{code} @@ -706,13 +714,17 @@ It doesn't change the uniques at all, just the print names. \begin{code} tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr (tidy_env, subst) tyvar +tidyTyVarBndr env@(tidy_env, subst) tyvar = case tidyOccName tidy_env (getOccName name) of - (tidy', occ') -> ((tidy', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarName tyvar name' - name' = tidyNameOcc name occ' + (tidy', occ') -> ((tidy', subst'), tyvar'') + where + subst' = extendVarEnv subst tyvar tyvar'' + tyvar' = setTyVarName tyvar name' + name' = tidyNameOcc name occ' + -- Don't forget to tidy the kind for coercions! + tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind' + | otherwise = tyvar' + kind' = tidyType env (tyVarKind tyvar) where name = tyVarName tyvar @@ -1015,10 +1027,12 @@ cmpTypesX env ty [] = GT ------------- cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2 - -- Compare types as well as names for implicit parameters - -- This comparison is used exclusively (I think) for the - -- finite map built in TcSimplify -cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2 + -- Compare names only for implicit parameters + -- This comparison is used exclusively (I believe) + -- for the Avails finite map built in TcSimplify + -- If the types differ we keep them distinct so that we see + -- a distinct pair to run improvement on +cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTypesX env tys1 tys2) cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2') -- Constructor order: IParam < ClassP < EqPred @@ -1187,7 +1201,7 @@ zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst zipTopTvSubst tyvars tys #ifdef DEBUG | length tyvars /= length tys - = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst + = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst | otherwise #endif = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) @@ -1293,6 +1307,9 @@ substTyVar subst@(TvSubst in_scope env) tv Just ty -> ty -- See Note [Apply Once] } +substTyVars :: TvSubst -> [TyVar] -> [Type] +substTyVars subst tvs = map (substTyVar subst) tvs + lookupTyVar :: TvSubst -> TyVar -> Maybe Type -- See Note [Extending the TvSubst] lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv @@ -1457,8 +1474,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