X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=925357f51f60e8f8b61faf8be44ab1a6473ebae4;hb=2007c7e67ddea6e16f4c8e013a453b073232459a;hp=d16aa04b800c260a93550f5f471cbfd751d4b6f8;hpb=b0604aad2c311d8713c2497afa6373bd938d501b;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d16aa04..925357f 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -62,10 +62,11 @@ module Type ( usageAnnOfType, typeKind, addFreeTyVars, -- Tidying up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyTyVar, tidyTyVars, tidyFreeTyVars, - tidyTopType, tidyPred, + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVarBndr, tidyFreeTyVars, + tidyOpenTyVar, tidyOpenTyVars, + tidyTopType, tidyPred, -- Comparison eqType, eqKind, eqUsage, @@ -108,7 +109,7 @@ import Maybes ( maybeToBool ) import SrcLoc ( noSrcLoc ) import PrimRep ( PrimRep(..) ) import Unique ( Uniquable(..) ) -import Util ( mapAccumL, seqList ) +import Util ( mapAccumL, seqList, lengthIs ) import Outputable import UniqSet ( sizeUniqSet ) -- Should come via VarSet \end{code} @@ -325,7 +326,7 @@ mkTyConApp tycon tys | isNewTyCon tycon, -- A saturated newtype application; not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them) - length tys == tyConArity tycon -- use the SourceType form + tys `lengthIs` tyConArity tycon -- use the SourceType form = SourceTy (NType tycon tys) | otherwise @@ -367,13 +368,26 @@ splitTyConApp_maybe other = Nothing ~~~~~ \begin{code} -mkSynTy syn_tycon tys - = ASSERT( isSynTyCon syn_tycon ) - ASSERT( length tyvars == length tys ) - NoteTy (SynNote (TyConApp syn_tycon tys)) - (substTyWith tyvars tys body) +mkSynTy tycon tys + | n_args == arity -- Exactly saturated + = mk_syn tys + | n_args > arity -- Over-saturated + = case splitAt arity tys of { (as,bs) -> foldl AppTy (mk_syn as) bs } + | otherwise -- Un-saturated + = TyConApp tycon tys + -- For the un-saturated case we build TyConApp directly + -- (mkTyConApp ASSERTs that the tc isn't a SynTyCon). + -- Here we are relying on checkValidType to find + -- the error. What we can't do is use mkSynTy with + -- too few arg tys, because that is utterly bogus. + where - (tyvars, body) = getSynTyConDefn syn_tycon + mk_syn tys = NoteTy (SynNote (TyConApp tycon tys)) + (substTyWith tyvars tys body) + + (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon + arity = tyConArity tycon + n_args = length tys \end{code} Notes on type synonyms @@ -412,7 +426,7 @@ repType (ForAllTy _ ty) = repType ty repType (NoteTy _ ty) = repType ty repType (SourceTy p) = repType (sourceTypeRep p) repType (UsageTy _ ty) = repType ty -repType (TyConApp tc tys) | isNewTyCon tc && length tys == tyConArity tc +repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc = repType (newTypeRep tc tys) repType ty = ty @@ -636,7 +650,7 @@ splitNewType_maybe :: Type -> Maybe Type splitNewType_maybe ty = case splitTyConApp_maybe ty of - Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc ) + Just (tc,tys) | isNewTyCon tc -> ASSERT( tys `lengthIs` tyConArity tc ) -- The assert should hold because repType should -- only be applied to *types* (of kind *) Just (newTypeRep tc tys) @@ -756,36 +770,34 @@ an interface file. It doesn't change the uniques at all, just the print names. \begin{code} -tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVar env@(tidy_env, subst) tyvar - = case lookupVarEnv subst tyvar of - - Just tyvar' -> -- Already substituted - (env, tyvar') - - Nothing -> -- Make a new nice name for it - - case tidyOccName tidy_env (getOccName name) of - (tidy', occ') -> -- New occname reqd - ((tidy', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarName tyvar name' - name' = mkLocalName (getUnique name) occ' noSrcLoc - -- Note: make a *user* tyvar, so it printes nicely - -- Could extract src loc, but no need. +tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVarBndr (tidy_env, subst) tyvar + = case tidyOccName tidy_env (getOccName name) of + (tidy', occ') -> -- New occname reqd + ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarName tyvar name' + name' = mkLocalName (getUnique name) occ' noSrcLoc + -- Note: make a *user* tyvar, so it printes nicely + -- Could extract src loc, but no need. where name = tyVarName tyvar -tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars - tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv -- Add the free tyvars to the env in tidy form, -- so that we can tidy the type they are free in -tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars) - where - add env tv = fst (tidyTyVar env tv) +tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) + +tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars + +tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +-- Treat a new tyvar as a binder, and give it a fresh tidy name +tidyOpenTyVar env@(tidy_env, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder tidyType :: TidyEnv -> Type -> Type tidyType env@(tidy_env, subst) ty @@ -796,16 +808,16 @@ tidyType env@(tidy_env, subst) ty Just tv' -> TyVarTy tv' go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args - go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty) + go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty) go (SourceTy sty) = SourceTy (tidySourceType env sty) - go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg) - go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg) - go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty) + go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) + go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) + go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) where - (envp, tvp) = tidyTyVar env tv - go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty) + (envp, tvp) = tidyTyVarBndr env tv + go (UsageTy u ty) = (UsageTy $! (go u)) $! (go ty) - go_note (SynNote ty) = SynNote SAPPLY (go ty) + go_note (SynNote ty) = SynNote $! (go ty) go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars tidyTypes env tys = map (tidyType env) tys @@ -868,7 +880,7 @@ 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( length ty_args == tyConArity tc ) + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) isAlgTyCon tc other -> False \end{code} @@ -899,7 +911,7 @@ isPrimitiveType :: Type -> Bool -- Most of these are unlifted, but now that we interact with .NET, we -- may have primtive (foreign-imported) types that are lifted isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) isPrimTyCon tc other -> False \end{code} @@ -964,7 +976,7 @@ eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of Just tv1a -> tv1a == tv2 Nothing -> tv1 == tv2 eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2) - | tv1 == tv2 = eq_ty env t1 t2 + | tv1 == tv2 = eq_ty (delVarEnv env tv1) t1 t2 | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)