X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=c7e5fa250901254842eab866d7a2e7d0edde5851;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=9720470b9d8189cf337354a1b28c078902b68baf;hpb=ffa4651e23a4c382dd3bdc43674a60b1a91c3b56;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 9720470..c7e5fa2 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -5,22 +5,15 @@ \begin{code} module Type ( - -- re-exports from TypeRep: - TyThing(..), - Type, PredType(..), ThetaType, - Kind, TyVarSubst, - - superKind, superBoxity, -- KX and BX respectively - liftedBoxity, unliftedBoxity, -- :: BX - openKindCon, -- :: KX - typeCon, -- :: BX -> KX - liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX - mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - isTypeKind, isAnyTypeKind, + -- re-exports from TypeRep + TyThing(..), Type, PredType(..), ThetaType, TyVarSubst, funTyCon, - -- exports from this module: - hasMoreBoxityInfo, defaultKind, + -- Re-exports from Kind + module Kind, + + -- Re-exports from TyCon + PrimRep(..), mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, @@ -62,11 +55,14 @@ module Type ( tidyTopType, tidyPred, -- Comparison - eqType, eqKind, + eqType, -- Seq - seqType, seqTypes + seqType, seqTypes, + -- Pretty-printing + pprType, pprParendType, + pprPred, pprTheta, pprThetaArrow, pprClassPred ) where #include "HsVersions.h" @@ -81,6 +77,7 @@ import TypeRep import {-# SOURCE #-} Subst ( substTyWith ) -- friends: +import Kind import Var ( TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet @@ -89,16 +86,14 @@ import Name ( NamedThing(..), mkInternalName, tidyOccName ) import Class ( Class, classTyCon ) import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isNewTyCon, newTyConRep, + isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs, isAlgTyCon, isSynTyCon, tyConArity, - tyConKind, getSynTyConDefn, - tyConPrimRep, + tyConKind, getSynTyConDefn, PrimRep(..), tyConPrimRep, ) -- others import CmdLineOpts ( opt_DictsStrict ) import SrcLoc ( noSrcLoc ) -import PrimRep ( PrimRep(..) ) import Unique ( Uniquable(..) ) import Util ( mapAccumL, seqList, lengthIs, snocView ) import Outputable @@ -109,38 +104,6 @@ import Maybe ( isJust ) %************************************************************************ %* * -\subsection{Stuff to do with kinds.} -%* * -%************************************************************************ - -\begin{code} -hasMoreBoxityInfo :: Kind -> Kind -> Bool --- (k1 `hasMoreBoxityInfo` k2) checks that k1 <: k2 -hasMoreBoxityInfo k1 k2 - | k2 `eqKind` openTypeKind = isAnyTypeKind k1 - | otherwise = k1 `eqKind` k2 - -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 *# -isTypeKind (TyConApp tc _) = tc == typeCon -isTypeKind (NoteTy _ k) = isTypeKind k -isTypeKind other = False - -defaultKind :: Kind -> Kind --- Used when generalising: default kind '?' to '*' -defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind - | otherwise = kind -\end{code} - - -%************************************************************************ -%* * \subsection{Constructor-specific functions} %* * %************************************************************************ @@ -265,7 +228,7 @@ splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty splitFunTy (PredTy p) = splitFunTy (predTypeRep p) splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys) -splitFunTy other = pprPanic "splitFunTy" (crudePprType other) +splitFunTy other = pprPanic "splitFunTy" (ppr other) splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) @@ -291,21 +254,21 @@ zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty split acc xs nty (NoteTy _ ty) = split acc xs nty ty split acc xs nty (PredTy p) = split acc xs nty (predTypeRep p) split acc xs nty (NewTcApp tc tys) = split acc xs nty (newTypeRep tc tys) - split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> crudePprType orig_ty) + split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) funResultTy :: Type -> Type funResultTy (FunTy arg res) = res funResultTy (NoteTy _ ty) = funResultTy ty funResultTy (PredTy p) = funResultTy (predTypeRep p) funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys) -funResultTy ty = pprPanic "funResultTy" (crudePprType ty) +funResultTy ty = pprPanic "funResultTy" (ppr ty) funArgTy :: Type -> Type funArgTy (FunTy arg res) = arg funArgTy (NoteTy _ ty) = funArgTy ty funArgTy (PredTy p) = funArgTy (predTypeRep p) funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys) -funArgTy ty = pprPanic "funArgTy" (crudePprType ty) +funArgTy ty = pprPanic "funArgTy" (ppr ty) \end{code} @@ -350,7 +313,7 @@ tyConAppArgs ty = snd (splitTyConApp ty) splitTyConApp :: Type -> (TyCon, [Type]) splitTyConApp ty = case splitTyConApp_maybe ty of Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (crudePprType ty) + Nothing -> pprPanic "splitTyConApp" (ppr ty) splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) @@ -428,15 +391,27 @@ repType (NewTcApp tc tys) = ASSERT( tys `lengthIs` tyConArity tc ) repType ty = ty +-- ToDo: this could be moved to the code generator, using splitTyConApp instead +-- of inspecting the type directly. typePrimRep :: Type -> PrimRep typePrimRep ty = case repType ty of TyConApp tc _ -> tyConPrimRep tc FunTy _ _ -> PtrRep - AppTy _ _ -> PtrRep -- ?? + AppTy _ _ -> PtrRep -- See note below TyVarTy _ -> PtrRep - other -> pprPanic "typePrimRep" (crudePprType ty) -\end{code} + other -> pprPanic "typePrimRep" (ppr ty) + -- Types of the form 'f a' must be of kind *, not *#, so + -- we are guaranteed that they are represented by pointers. + -- The reason is that f must have kind *->*, not *->*#, because + -- (we claim) there is no way to constrain f's kind any other + -- way. +-- 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 +\end{code} --------------------------------------------------------------------- @@ -516,7 +491,7 @@ applyTys orig_fun_ty arg_tys = substTyWith (take n_args tvs) arg_tys (mkForAllTys (drop n_args tvs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, crudePprType orig_fun_ty ) -- Zero case gives infnite loop! + = 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) where @@ -549,6 +524,8 @@ mkPredTys preds = map PredTy preds predTypeRep :: PredType -> Type -- Convert a PredType to its "representation type"; -- the post-type-checking type used by all the Core passes of GHC. +-- Unwraps only the outermost level; for example, the result might +-- be a NewTcApp; c.f. newTypeRep predTypeRep (IParam _ ty) = ty predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -- Result might be a NewTcApp, but the consumer will @@ -566,23 +543,33 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys splitRecNewType_maybe :: Type -> Maybe Type -- Newtypes are always represented by a NewTcApp -- 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 (NoteTy _ ty) = splitRecNewType_maybe ty +splitRecNewType_maybe (PredTy p) = splitRecNewType_maybe (predTypeRep p) splitRecNewType_maybe (NewTcApp tc tys) | isRecursiveTyCon tc = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc ) - -- The assert should hold because repType should - -- only be applied to *types* (of kind *) - Just (new_type_rep tc tys) + -- The assert should hold because splitRecNewType_maybe + -- should only be applied to *types* (of kind *) + Just (new_type_rhs tc tys) splitRecNewType_maybe other = Nothing ----------------------------- newTypeRep :: TyCon -> [Type] -> Type -- A local helper function (not exported) --- Expands a newtype application to +-- Expands *the outermoset level of* a newtype application to -- *either* a vanilla TyConApp (recursive newtype, or non-saturated) --- *or* the newtype representation (otherwise) --- Either way, the result is not a NewTcApp +-- *or* the newtype representation (otherwise), meaning the +-- type written in the RHS of the newtype decl, +-- which may itself be a newtype +-- +-- Example: newtype R = MkR S +-- newtype S = MkS T +-- newtype T = MkT (T -> T) +-- newTypeRep on R gives NewTcApp S +-- on S gives NewTcApp T +-- on T gives TyConApp T -- -- NB: the returned TyConApp is always deconstructed immediately by the -- caller... a TyConApp with a newtype type constructor never lives @@ -590,17 +577,16 @@ newTypeRep :: TyCon -> [Type] -> Type newTypeRep tc tys | not (isRecursiveTyCon tc), -- Not recursive and saturated tys `lengthIs` tyConArity tc -- treat as equivalent to expansion - = new_type_rep tc tys + = new_type_rhs tc tys | otherwise = TyConApp tc tys -- ToDo: Consider caching this substitution in a NType ----------------------------- --- 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 +-- new_type_rhs doesn't ask any questions: +-- it just expands newtype one level, whether recursive or not +new_type_rhs tc tys + = case newTyConRhs tc of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty \end{code} @@ -617,26 +603,13 @@ new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) typeKind :: Type -> Kind typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys -typeKind (NewTcApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys +typeKind (TyConApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys +typeKind (NewTcApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys typeKind (NoteTy _ ty) = typeKind ty typeKind (PredTy _) = liftedTypeKind -- Predicates are always -- represented by lifted types -typeKind (AppTy fun arg) = funResultTy (typeKind fun) - -typeKind (FunTy arg res) = fix_up (typeKind res) - where - fix_up (TyConApp tycon _) | tycon == typeCon - || tycon == openKindCon = liftedTypeKind - fix_up (NoteTy _ kind) = fix_up kind - fix_up kind = kind - -- The basic story is - -- typeKind (FunTy arg res) = typeKind res - -- But a function is lifted regardless of its result type - -- Hence the strange fix-up. - -- Note that 'res', being the result of a FunTy, can't have - -- a strange kind like (*->*). - +typeKind (AppTy fun arg) = kindFunResult (typeKind fun) +typeKind (FunTy arg res) = liftedTypeKind typeKind (ForAllTy tv ty) = typeKind ty \end{code} @@ -702,8 +675,7 @@ It doesn't change the uniques at all, just the print names. 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') + (tidy', occ') -> ((tidy', subst'), tyvar') where subst' = extendVarEnv subst tyvar tyvar' tyvar' = setTyVarName tyvar name' @@ -898,7 +870,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 -- Look through Notes eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2