\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,
tidyTopType, tidyPred,
-- Comparison
- eqType, eqKind,
+ eqType,
-- Seq
- seqType, seqTypes
+ seqType, seqTypes,
+ -- Pretty-printing
+ pprType, pprParendType,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
#include "HsVersions.h"
import {-# SOURCE #-} Subst ( substTyWith )
-- friends:
+import Kind
import Var ( TyVar, tyVarKind, tyVarName, setTyVarName )
import VarEnv
import VarSet
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
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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)
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}
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)
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}
---------------------------------------------------------------------
= 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
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
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
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}
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}
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'
\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
projects / ghc-hetmet.git / blobdiff