X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=9a9fae26085a4dce8e6ed6b3a3eb876e0eaaa263;hb=e98c75873475e94d23246c4e92a41c120d0e167b;hp=9a673110aefefacef30cd21cc3e56c403521a4c6;hpb=20f50b2a3651ce7dacdcb86a83afb5c5d444cb0b;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 9a67311..9a9fae2 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -15,14 +15,9 @@ module Type ( typeCon, -- :: BX -> KX liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - isTypeKind, + isTypeKind, isAnyTypeKind, funTyCon, - usageKindCon, -- :: KX - usageTypeKind, -- :: KX - usOnceTyCon, usManyTyCon, -- :: $ - usOnce, usMany, -- :: $ - -- exports from this module: hasMoreBoxityInfo, defaultKind, @@ -31,18 +26,18 @@ module Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, - funResultTy, funArgTy, zipFunTys, + funResultTy, funArgTy, zipFunTys, isFunTy, - mkTyConApp, mkTyConTy, + mkGenTyConApp, mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, mkSynTy, - repType, splitRepFunTys, typePrimRep, + repType, typePrimRep, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, isForAllTy, + applyTy, applyTys, isForAllTy, dropForAlls, -- Source types SourceType(..), sourceTypeRep, mkPredTy, mkPredTys, @@ -65,7 +60,7 @@ module Type ( tidyTopType, tidyPred, -- Comparison - eqType, eqKind, eqUsage, + eqType, eqKind, -- Seq seqType, seqTypes @@ -85,12 +80,12 @@ import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages import {-# SOURCE #-} Subst ( substTyWith ) -- friends: -import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName ) +import Var ( Id, TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet -import Name ( NamedThing(..), mkLocalName, tidyOccName ) -import Class ( classTyCon ) +import Name ( NamedThing(..), mkInternalName, tidyOccName ) +import Class ( Class, classTyCon ) import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, isFunTyCon, isNewTyCon, newTyConRep, @@ -101,13 +96,13 @@ import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, -- others import CmdLineOpts ( opt_DictsStrict ) -import Maybes ( maybeToBool ) import SrcLoc ( noSrcLoc ) import PrimRep ( PrimRep(..) ) import Unique ( Uniquable(..) ) -import Util ( mapAccumL, seqList, lengthIs ) +import Util ( mapAccumL, seqList, lengthIs, snocView ) import Outputable import UniqSet ( sizeUniqSet ) -- Should come via VarSet +import Maybe ( isJust ) \end{code} @@ -121,12 +116,15 @@ import UniqSet ( sizeUniqSet ) -- Should come via VarSet hasMoreBoxityInfo :: Kind -> Kind -> Bool -- (k1 `hasMoreBoxityInfo` k2) checks that k1 <: k2 hasMoreBoxityInfo k1 k2 - | k2 `eqKind` openTypeKind = ok k1 + | k2 `eqKind` openTypeKind = isAnyTypeKind k1 | otherwise = k1 `eqKind` k2 where - ok (TyConApp tc _) = tc == typeCon || tc == openKindCon - ok (NoteTy _ k) = ok k - ok other = False + +isAnyTypeKind :: Kind -> Bool +-- True of kind * and *# and ? +isAnyTypeKind (TyConApp tc _) = tc == typeCon || tc == openKindCon +isAnyTypeKind (NoteTy _ k) = isAnyTypeKind k +isAnyTypeKind other = False isTypeKind :: Kind -> Bool -- True of kind * and *# @@ -191,8 +189,16 @@ mkAppTy orig_ty1 orig_ty2 mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) + mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2]) mk_app ty1 = AppTy orig_ty1 orig_ty2 + -- We call mkGenTyConApp because the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well mkAppTys :: Type -> [Type] -> Type mkAppTys orig_ty1 [] = orig_ty1 @@ -213,14 +219,11 @@ splitAppTy_maybe :: Type -> Maybe (Type, Type) splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty -splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) -splitAppTy_maybe (TyConApp tc []) = Nothing -splitAppTy_maybe (TyConApp tc tys) = split tys [] - where - split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) - split (ty:tys) acc = split tys (ty:acc) - -splitAppTy_maybe other = Nothing +splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) +splitAppTy_maybe (TyConApp tc tys) = case snocView tys of + Nothing -> Nothing + Just (tys',ty') -> Just (TyConApp tc tys', ty') +splitAppTy_maybe other = Nothing splitAppTy :: Type -> (Type, Type) splitAppTy ty = case splitAppTy_maybe ty of @@ -232,7 +235,7 @@ splitAppTys ty = split ty ty [] where split orig_ty (AppTy ty arg) args = split ty ty (arg:args) split orig_ty (NoteTy _ ty) args = split orig_ty ty args - split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args + split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) @@ -251,6 +254,9 @@ mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr FunTy ty tys +isFunTy :: Type -> Bool +isFunTy ty = isJust (splitFunTy_maybe ty) + splitFunTy :: Type -> (Type, Type) splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty @@ -300,6 +306,11 @@ funArgTy ty = pprPanic "funArgTy" (pprType ty) as apppropriate. \begin{code} +mkGenTyConApp :: TyCon -> [Type] -> Type +mkGenTyConApp tc tys + | isSynTyCon tc = mkSynTy tc tys + | otherwise = mkTyConApp tc tys + mkTyConApp :: TyCon -> [Type] -> Type -- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those mkTyConApp tycon tys @@ -352,7 +363,10 @@ 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 } + = case splitAt arity tys of { (as,bs) -> mkAppTys (mk_syn as) bs } + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because (mk_syn as) might well return a partially-applied + -- type constructor; indeed, usually will! | otherwise -- Un-saturated = TyConApp tycon tys -- For the un-saturated case we build TyConApp directly @@ -387,7 +401,6 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. Representation types ~~~~~~~~~~~~~~~~~~~~ - repType looks through (a) for-alls, and (b) synonyms @@ -409,12 +422,6 @@ repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc = repType (newTypeRep tc tys) repType ty = ty -splitRepFunTys :: Type -> ([Type], Type) --- Like splitFunTys, but looks through newtypes and for-alls -splitRepFunTys ty = split [] (repType ty) - where - split args (FunTy arg res) = split (arg:args) (repType res) - split args ty = (reverse args, ty) typePrimRep :: Type -> PrimRep typePrimRep ty = case repType ty of @@ -458,11 +465,20 @@ splitForAllTys ty = split ty ty [] split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs split orig_ty t tvs = (reverse tvs, orig_ty) + +dropForAlls :: Type -> Type +dropForAlls ty = snd (splitForAllTys ty) \end{code} -- (mkPiType now in CoreUtils) -Applying a for-all to its arguments. Lift usage annotation as required. +applyTy, applyTys +~~~~~~~~~~~~~~~~~ +Instantiate a for-all type with one or more type arguments. +Used when we have a polymorphic function applied to type args: + f t1 t2 +Then we use (applyTys type-of-f [t1,t2]) to compute the type of +the expression. \begin{code} applyTy :: Type -> Type -> Type @@ -472,17 +488,32 @@ applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty applyTy other arg = panic "applyTy" applyTys :: Type -> [Type] -> Type -applyTys fun_ty arg_tys - = substTyWith tvs arg_tys ty - where - (mu, tvs, ty) = split fun_ty arg_tys - - split fun_ty [] = (Nothing, [], fun_ty) - split (NoteTy _ fun_ty) args = split fun_ty args - split (SourceTy p) args = split (sourceTypeRep p) args - split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of - (mu, tvs, ty) -> (mu, tv:tvs, ty) - split other_ty args = panic "applyTys" +-- This function is interesting because +-- a) the function may have more for-alls than there are args +-- b) less obviously, it may have fewer for-alls +-- For case (b) think of +-- applyTys (forall a.a) [forall b.b, Int] +-- This really can happen, via dressing up polymorphic types with newtype +-- clothing. Here's an example: +-- newtype R = R (forall a. a->a) +-- foo = case undefined :: R of +-- R f -> f () + +applyTys orig_fun_ty [] = orig_fun_ty +applyTys 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, pprType orig_fun_ty ) -- Zero case gives infnite loop! + applyTys (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 + n_args = length arg_tys \end{code} @@ -584,12 +615,27 @@ tyVarsOfType :: Type -> TyVarSet tyVarsOfType (TyVarTy tv) = unitVarSet tv tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs -tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1 +tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty2 -- See note [Syn] below tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar +-- Note [Syn] +-- Consider +-- type T a = Int +-- What are the free tyvars of (T x)? Empty, of course! +-- Here's the example that Ralf Laemmel showed me: +-- foo :: (forall a. C u a -> C u a) -> u +-- mappend :: Monoid u => u -> u -> u +-- +-- bar :: Monoid u => u +-- bar = foo (\t -> t `mappend` t) +-- We have to generalise at the arg to f, and we don't +-- want to capture the constraint (Monad (C u a)) because +-- it appears to mention a. Pretty silly, but it was useful to him. + + tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys @@ -610,8 +656,6 @@ addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty \end{code} - - %************************************************************************ %* * \subsection{TidyType} @@ -632,7 +676,7 @@ tidyTyVarBndr (tidy_env, subst) tyvar where subst' = extendVarEnv subst tyvar tyvar' tyvar' = setTyVarName tyvar name' - name' = mkLocalName (getUnique name) occ' noSrcLoc + name' = mkInternalName (getUnique name) occ' noSrcLoc -- Note: make a *user* tyvar, so it printes nicely -- Could extract src loc, but no need. where @@ -821,7 +865,6 @@ I don't think this is harmful, but it's soemthing to watch out for. \begin{code} eqType t1 t2 = eq_ty emptyVarEnv t1 t2 eqKind = eqType -- No worries about looking -eqUsage = eqType -- through source types for these two -- Look through Notes eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2