X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=b3134f59500650da59434542c1a3bc4c808efadb;hb=30d559930fff086ad3a8ef4162e7d748d1e96b70;hp=56decc5a0be0aa041f3193750f858dd7b6ac0177;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 56decc5..b3134f5 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,248 +1,132 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[Type]{Type - public interface} + \begin{code} module Type ( - GenType(..), TyNote(..), -- Representation visible to friends - Type, GenKind, Kind, - TyVarSubst, GenTyVarSubst, + -- re-exports from TypeRep: + Type, + Kind, TyVarSubst, + + superKind, superBoxity, -- KX and BX respectively + boxedBoxity, unboxedBoxity, -- :: BX + openKindCon, -- :: KX + typeCon, -- :: BX -> KX + boxedTypeKind, unboxedTypeKind, openTypeKind, -- :: KX + mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - funTyCon, boxedKindCon, unboxedKindCon, openKindCon, + funTyCon, - boxedTypeKind, unboxedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, - hasMoreBoxityInfo, superKind, + -- exports from this module: + hasMoreBoxityInfo, defaultKind, mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, funResultTy, + mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, + funResultTy, funArgTy, zipFunTys, mkTyConApp, mkTyConTy, splitTyConApp_maybe, - splitAlgTyConApp_maybe, splitAlgTyConApp, - mkDictTy, splitDictTy_maybe, isDictTy, + splitAlgTyConApp_maybe, splitAlgTyConApp, + + -- Predicates and the like + mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, + splitDictTy_maybe, isDictTy, predRepTy, - mkSynTy, isSynTy, + mkSynTy, isSynTy, deNoteType, + + repType, splitRepFunTys, splitNewType_maybe, typePrimRep, + + UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, + mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, isForAllTy, - mkPiType, + applyTy, applyTys, hoistForAllTys, + + TauType, RhoType, SigmaType, PredType(..), ThetaType, + ClassPred, ClassContext, mkClassPred, + getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds, + isTauTy, mkRhoTy, splitRhoTy, + mkSigmaTy, isSigmaTy, splitSigmaTy, + getDFunTyKey, - TauType, RhoType, SigmaType, ThetaType, - isTauTy, - mkRhoTy, splitRhoTy, - mkSigmaTy, splitSigmaTy, + -- Lifting and boxity + isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType, - isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, - typePrimRep, + -- Free variables + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, + namesOfType, typeKind, addFreeTyVars, - tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, - addFreeTyVars, + -- Tidying up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVar, tidyTyVars, + tidyTopType, - substTy, fullSubstTy, substTyVar, - substFlexiTy, substFlexiTheta, + -- Seq + seqType, seqTypes - showTypeCategory ) where #include "HsVersions.h" -import {-# SOURCE #-} DataCon( DataCon ) +-- We import the representation and primitive functions from TypeRep. +-- Many things are reexported, but not the representation! + +import TypeRep + +-- Other imports: + +import {-# SOURCE #-} DataCon( DataCon, dataConRepType ) +import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages +import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy ) -- friends: -import Var ( Id, TyVar, GenTyVar, IdOrTyVar, - removeTyVarFlexi, - tyVarKind, isId, idType +import Var ( TyVar, Var, UVar, + tyVarKind, tyVarName, setTyVarName, isId, idType, ) import VarEnv import VarSet -import Name ( NamedThing(..), Provenance(..), ExportFlag(..), - mkWiredInTyConName, mkGlobalName, varOcc - ) +import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName ) import NameSet -import Class ( classTyCon, Class ) -import TyCon ( TyCon, Boxity(..), - mkFunTyCon, mkKindCon, superKindCon, - matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isEnumerationTyCon, - isTupleTyCon, maybeTyConSingleCon, - isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity, - tyConKind, tyConDataCons, getSynTyConDefn, - tyConPrimRep, tyConClass_maybe +import Class ( classTyCon, Class, ClassPred, ClassContext ) +import TyCon ( TyCon, + isUnboxedTupleTyCon, isUnLiftedTyCon, + isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, + isAlgTyCon, isSynTyCon, tyConArity, + tyConKind, tyConDataCons, getSynTyConDefn, + tyConPrimRep ) -- others -import BasicTypes ( Unused ) -import SrcLoc ( mkBuiltinSrcLoc ) -import PrelMods ( pREL_GHC ) -import Maybes ( maybeToBool ) +import SrcLoc ( noSrcLoc ) import PrimRep ( PrimRep(..), isFollowableRep ) -import Unique -- quite a few *Keys -import Util ( thenCmp ) +import Unique ( Uniquable(..) ) +import Util ( mapAccumL, seqList, thenCmp ) import Outputable - +import UniqSet ( sizeUniqSet ) -- Should come via VarSet \end{code} -%************************************************************************ -%* * -\subsection{Type Classifications} -%* * -%************************************************************************ - -A type is - - *unboxed* iff its representation is other than a pointer - Unboxed types cannot instantiate a type variable - Unboxed types are always unlifted. - - *lifted* A type is lifted iff it has bottom as an element. - Closures always have lifted types: i.e. any - let-bound identifier in Core must have a lifted - type. Operationally, a lifted object is one that - can be entered. - (NOTE: previously "pointed"). - - *algebraic* A type with one or more constructors. An algebraic - type is one that can be deconstructed with a case - expression. *NOT* the same as lifted types, - because we also include unboxed tuples in this - classification. - - *primitive* iff it is a built-in type that can't be expressed - in Haskell. - -Currently, all primitive types are unlifted, but that's not necessarily -the case. (E.g. Int could be primitive.) - -Some primitive types are unboxed, such as Int#, whereas some are boxed -but unlifted (such as ByteArray#). The only primitive types that we -classify as algebraic are the unboxed tuples. - -examples of type classifications: - -Type primitive boxed lifted algebraic ------------------------------------------------------------------------------ -Int#, Yes No No No -ByteArray# Yes Yes No No -(# a, b #) Yes No No Yes -( a, b ) No Yes Yes Yes -[a] No Yes Yes Yes %************************************************************************ %* * -\subsection{The data type} +\subsection{Stuff to do with kinds.} %* * %************************************************************************ - \begin{code} -type Type = GenType Unused -- Used after typechecker - -type GenKind flexi = GenType flexi -type Kind = Type - -type TyVarSubst = TyVarEnv Type -type GenTyVarSubst flexi = TyVarEnv (GenType flexi) - -data GenType flexi -- Parameterised over the "flexi" part of a type variable - = TyVarTy (GenTyVar flexi) - - | AppTy - (GenType flexi) -- Function is *not* a TyConApp - (GenType flexi) - - | TyConApp -- Application of a TyCon - TyCon -- *Invariant* saturated appliations of FunTyCon and - -- synonyms have their own constructors, below. - [GenType flexi] -- Might not be saturated. - - | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2] - (GenType flexi) - (GenType flexi) - - | NoteTy -- Saturated application of a type synonym - (TyNote flexi) - (GenType flexi) -- The expanded version - - | ForAllTy - (GenTyVar flexi) - (GenType flexi) -- TypeKind - -data TyNote flexi - = SynNote (GenType flexi) -- The unexpanded version of the type synonym; always a TyConApp - | FTVNote (GenTyVarSet flexi) -- The free type variables of the noted expression -\end{code} - - -%************************************************************************ -%* * -\subsection{Wired-in type constructors -%* * -%************************************************************************ - -We define a few wired-in type constructors here to avoid module knots - -\begin{code} -funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("->") funTyCon -funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind) -\end{code} - -\begin{code} -mk_kind_name key str = mkGlobalName key pREL_GHC (varOcc str) - (LocalDef mkBuiltinSrcLoc NotExported) - -- mk_kind_name is a bit of a hack - -- The LocalDef means that we print the name without - -- a qualifier, which is what we want for these kinds. - -boxedKindConName = mk_kind_name boxedKindConKey SLIT("*") -boxedKindCon = mkKindCon boxedKindConName superKind Boxed - -unboxedKindConName = mk_kind_name unboxedKindConKey SLIT("*#") -unboxedKindCon = mkKindCon unboxedKindConName superKind Unboxed - -openKindConName = mk_kind_name openKindConKey SLIT("*?") -openKindCon = mkKindCon openKindConName superKind Open -\end{code} - - -%************************************************************************ -%* * -\subsection{Kinds} -%* * -%************************************************************************ - -\begin{code} -superKind :: GenKind flexi -- Box, the type of all kinds -superKind = TyConApp superKindCon [] - -boxedTypeKind, unboxedTypeKind, openTypeKind :: GenKind flexi -boxedTypeKind = TyConApp boxedKindCon [] -unboxedTypeKind = TyConApp unboxedKindCon [] -openTypeKind = TyConApp openKindCon [] - -mkArrowKind :: GenKind flexi -> GenKind flexi -> GenKind flexi -mkArrowKind = FunTy - -mkArrowKinds :: [GenKind flexi] -> GenKind flexi -> GenKind flexi -mkArrowKinds arg_kinds result_kind = foldr FunTy result_kind arg_kinds -\end{code} - -\begin{code} -hasMoreBoxityInfo :: GenKind flexi -> GenKind flexi -> Bool - -(NoteTy _ k1) `hasMoreBoxityInfo` k2 = k1 `hasMoreBoxityInfo` k2 -k1 `hasMoreBoxityInfo` (NoteTy _ k2) = k1 `hasMoreBoxityInfo` k2 - -(TyConApp kc1 ts1) `hasMoreBoxityInfo` (TyConApp kc2 ts2) - = ASSERT( null ts1 && null ts2 ) - kc2 `matchesTyCon` kc1 -- NB the reversal of arguments - -kind1@(FunTy _ _) `hasMoreBoxityInfo` kind2@(FunTy _ _) - = ASSERT( kind1 == kind2 ) - True - -- The two kinds can be arrow kinds; for example when unifying - -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should - -- have the same kind. - --- Other cases are impossible +hasMoreBoxityInfo :: Kind -> Kind -> Bool +hasMoreBoxityInfo k1 k2 + | k2 == openTypeKind = True + | otherwise = k1 == k2 + +defaultKind :: Kind -> Kind +-- Used when generalising: default kind '?' to '*' +defaultKind kind | kind == openTypeKind = boxedTypeKind + | otherwise = kind \end{code} @@ -257,25 +141,28 @@ kind1@(FunTy _ _) `hasMoreBoxityInfo` kind2@(FunTy _ _) TyVarTy ~~~~~~~ \begin{code} -mkTyVarTy :: GenTyVar flexi -> GenType flexi +mkTyVarTy :: TyVar -> Type mkTyVarTy = TyVarTy -mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi] +mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy -getTyVar :: String -> GenType flexi -> GenTyVar flexi +getTyVar :: String -> Type -> TyVar getTyVar msg (TyVarTy tv) = tv +getTyVar msg (PredTy p) = getTyVar msg (predRepTy p) getTyVar msg (NoteTy _ t) = getTyVar msg t getTyVar msg other = panic ("getTyVar: " ++ msg) -getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi) +getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe (TyVarTy tv) = Just tv getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p) getTyVar_maybe other = Nothing -isTyVarTy :: GenType flexi -> Bool +isTyVarTy :: Type -> Bool isTyVarTy (TyVarTy tv) = True isTyVarTy (NoteTy _ ty) = isTyVarTy ty +isTyVarTy (PredTy p) = isTyVarTy (predRepTy p) isTyVarTy other = False \end{code} @@ -288,29 +175,37 @@ invariant that a TyConApp is always visibly so. mkAppTy maintains the invariant: use it. \begin{code} -mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1 +mkAppTy orig_ty1 orig_ty2 + = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 ) + ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) mk_app ty1 = AppTy orig_ty1 orig_ty2 -mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi +mkAppTys :: Type -> [Type] -> Type mkAppTys orig_ty1 [] = orig_ty1 -- This check for an empty list of type arguments -- avoids the needless of a type synonym constructor. -- For example: mkAppTys Rational [] -- returns to (Ratio Integer), which has needlessly lost -- the Rational part. -mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1 +mkAppTys orig_ty1 orig_tys2 + = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 ) + ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) - mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 + mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) ) + foldl AppTy orig_ty1 orig_tys2 -splitAppTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi) +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 (PredTy p) = splitAppTy_maybe (predRepTy p) splitAppTy_maybe (TyConApp tc []) = Nothing splitAppTy_maybe (TyConApp tc tys) = split tys [] where @@ -319,16 +214,17 @@ splitAppTy_maybe (TyConApp tc tys) = split tys [] splitAppTy_maybe other = Nothing -splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi) +splitAppTy :: Type -> (Type, Type) splitAppTy ty = case splitAppTy_maybe ty of Just pr -> pr Nothing -> panic "splitAppTy" -splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi]) +splitAppTys :: Type -> (Type, [Type]) 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 (PredTy p) args = split orig_ty (predRepTy 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) @@ -341,39 +237,69 @@ splitAppTys ty = split ty ty [] ~~~~~ \begin{code} -mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi +mkFunTy :: Type -> Type -> Type mkFunTy arg res = FunTy arg res -mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi +mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr FunTy ty tys -splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi) +splitFunTy :: Type -> (Type, Type) +splitFunTy (FunTy arg res) = (arg, res) +splitFunTy (NoteTy _ ty) = splitFunTy ty +splitFunTy (PredTy p) = splitFunTy (predRepTy p) + +splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p) splitFunTy_maybe other = Nothing - -splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi) +splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty (FunTy arg res) = split (arg:args) res res split args orig_ty (NoteTy _ ty) = split args orig_ty ty + split args orig_ty (PredTy p) = split args orig_ty (predRepTy p) split args orig_ty ty = (reverse args, orig_ty) -funResultTy :: GenType flexi -> GenType flexi +splitFunTysN :: String -> Int -> Type -> ([Type], Type) +splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty + where + split 0 args syn_ty ty = (reverse args, syn_ty) + split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res + split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty + split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p) + split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty) + +zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) +zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty + where + split acc [] nty ty = (reverse acc, nty) + split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res + split acc xs nty (NoteTy _ ty) = split acc xs nty ty + split acc xs nty (PredTy p) = split acc xs nty (predRepTy p) + split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) + +funResultTy :: Type -> Type funResultTy (FunTy arg res) = res funResultTy (NoteTy _ ty) = funResultTy ty -funResultTy ty = ty +funResultTy (PredTy p) = funResultTy (predRepTy p) +funResultTy ty = pprPanic "funResultTy" (pprType ty) + +funArgTy :: Type -> Type +funArgTy (FunTy arg res) = arg +funArgTy (NoteTy _ ty) = funArgTy ty +funArgTy (PredTy p) = funArgTy (predRepTy p) +funArgTy ty = pprPanic "funArgTy" (pprType ty) \end{code} - --------------------------------------------------------------------- TyConApp ~~~~~~~~ \begin{code} -mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi +mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon && length tys == 2 = case tys of @@ -383,7 +309,7 @@ mkTyConApp tycon tys = ASSERT(not (isSynTyCon tycon)) TyConApp tycon tys -mkTyConTy :: TyCon -> GenType flexi +mkTyConTy :: TyCon -> Type mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) TyConApp tycon [] @@ -391,57 +317,35 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. -splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi]) +splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty +splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p) splitTyConApp_maybe other = Nothing -- splitAlgTyConApp_maybe looks for -- *saturated* applications of *algebraic* data types -- "Algebraic" => newtype, data type, or dictionary (not function types) --- We return the constructors too. +-- We return the constructors too, so there had better be some. -splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [DataCon]) +splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon]) splitAlgTyConApp_maybe (TyConApp tc tys) - | isAlgTyCon tc && + | isAlgTyCon tc && tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty +splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p) splitAlgTyConApp_maybe other = Nothing -splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [DataCon]) +splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon]) -- Here the "algebraic" property is an *assertion* splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys ) (tc, tys, tyConDataCons tc) splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty -\end{code} - -"Dictionary" types are just ordinary data types, but you can -tell from the type constructor whether it's a dictionary or not. - -\begin{code} -mkDictTy :: Class -> [GenType flexi] -> GenType flexi -mkDictTy clas tys = TyConApp (classTyCon clas) tys - -splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi]) -splitDictTy_maybe (TyConApp tc tys) - | maybeToBool maybe_class - && tyConArity tc == length tys = Just (clas, tys) - where - maybe_class = tyConClass_maybe tc - Just clas = maybe_class - -splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty -splitDictTy_maybe other = Nothing - -isDictTy :: GenType flexi -> Bool - -- This version is slightly more efficient than (maybeToBool . splitDictTy) -isDictTy (TyConApp tc tys) - | maybeToBool (tyConClass_maybe tc) - && tyConArity tc == length tys - = True -isDictTy (NoteTy _ ty) = isDictTy ty -isDictTy other = False +splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p) +#ifdef DEBUG +splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty) +#endif \end{code} @@ -451,15 +355,26 @@ isDictTy other = False \begin{code} mkSynTy syn_tycon tys - = ASSERT(isSynTyCon syn_tycon) + = ASSERT( isSynTyCon syn_tycon ) + ASSERT( isNotUsgTy body ) + ASSERT( length tyvars == length tys ) NoteTy (SynNote (TyConApp syn_tycon tys)) - (substFlexiTy (zipVarEnv tyvars tys) body) - -- The "flexi" is needed so we can get a TcType from a synonym + (substTy (mkTyVarSubst tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon isSynTy (NoteTy (SynNote _) _) = True isSynTy other = False + +deNoteType :: Type -> Type + -- Remove synonyms, but not Preds +deNoteType ty@(TyVarTy tyvar) = ty +deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) +deNoteType (PredTy p) = PredTy p +deNoteType (NoteTy _ ty) = deNoteType ty +deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) +deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) +deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) \end{code} Notes on type synonyms @@ -477,107 +392,365 @@ The reason is that we then get better (shorter) type signatures in interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. + Representation types + ~~~~~~~~~~~~~~~~~~~~ + +repType looks through + (a) for-alls, and + (b) newtypes + (c) synonyms + (d) predicates +It's useful in the back end where we're not +interested in newtypes anymore. + +\begin{code} +repType :: Type -> Type +repType (ForAllTy _ ty) = repType ty +repType (NoteTy _ ty) = repType ty +repType (PredTy p) = repType (predRepTy p) +repType ty = case splitNewType_maybe ty of + Just ty' -> repType ty' -- Still re-apply repType in case of for-all + Nothing -> 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 + TyConApp tc _ -> tyConPrimRep tc + FunTy _ _ -> PtrRep + AppTy _ _ -> PtrRep -- ?? + TyVarTy _ -> PtrRep + +splitNewType_maybe :: Type -> Maybe Type +-- Find the representation of a newtype, if it is one +-- Looks through multiple levels of newtype, but does not look through for-alls +splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty +splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p) +splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of + Just rep_ty -> ASSERT( length tys == tyConArity tc ) + -- The assert should hold because repType should + -- only be applied to *types* (of kind *) + Just (applyTys rep_ty tys) + Nothing -> Nothing +splitNewType_maybe other = Nothing +\end{code} + --------------------------------------------------------------------- - ForAllTy - ~~~~~~~~ + UsgNote + ~~~~~~~ + +NB: Invariant: if present, usage note is at the very top of the type. +This should be carefully preserved. + +In some parts of the compiler, comments use the _Once Upon a +Polymorphic Type_ (POPL'99) usage of "rho = generalised +usage-annotated type; sigma = usage-annotated type; tau = +usage-annotated type except on top"; unfortunately this conflicts with +the rho/tau/theta/sigma usage in the rest of the compiler. (KSW +1999-07) \begin{code} -mkForAllTy = ForAllTy +mkUsgTy :: UsageAnn -> Type -> Type +#ifndef USMANY +mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty ) + ty +#endif +mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty ) + NoteTy (UsgNote usg) ty + +-- The isUsgTy function is utterly useless if UsManys are omitted. +-- Be warned! KSW 1999-04. +isUsgTy :: Type -> Bool +#ifndef USMANY +isUsgTy _ = True +#else +isUsgTy (NoteTy (UsgForAll _) ty) = isUsgTy ty +isUsgTy (NoteTy (UsgNote _) _ ) = True +isUsgTy other = False +#endif + +-- The isNotUsgTy function may return a false True if UsManys are omitted; +-- in other words, A SSERT( isNotUsgTy ty ) may be useful but +-- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04. +isNotUsgTy :: Type -> Bool +isNotUsgTy (NoteTy (UsgForAll _) _) = False +isNotUsgTy (NoteTy (UsgNote _) _) = False +isNotUsgTy other = True + +-- splitUsgTy_maybe is not exported, since it is meaningless if +-- UsManys are omitted. It is used in several places in this module, +-- however. KSW 1999-04. +splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type) +splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 ) + Just (usg,ty2) +splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty +splitUsgTy_maybe ty = Nothing + +splitUsgTy :: Type -> (UsageAnn,Type) +splitUsgTy ty = case splitUsgTy_maybe ty of + Just ans -> ans + Nothing -> +#ifndef USMANY + (UsMany,ty) +#else + pprPanic "splitUsgTy: no usage annot:" $ pprType ty +#endif + +tyUsg :: Type -> UsageAnn +tyUsg = fst . splitUsgTy + +unUsgTy :: Type -> Type +-- strip outer usage annotation if present +unUsgTy ty = case splitUsgTy_maybe ty of + Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty ) + ty1 + Nothing -> ty + +mkUsForAllTy :: UVar -> Type -> Type +mkUsForAllTy uv ty = NoteTy (UsgForAll uv) ty + +mkUsForAllTys :: [UVar] -> Type -> Type +mkUsForAllTys uvs ty = foldr (NoteTy . UsgForAll) ty uvs + +splitUsForAllTys :: Type -> ([UVar],Type) +splitUsForAllTys ty = split ty [] + where split (NoteTy (UsgForAll u) ty) uvs = split ty (u:uvs) + split other_ty uvs = (reverse uvs, other_ty) + +substUsTy :: VarEnv UsageAnn -> Type -> Type +-- assumes range is fresh uvars, so no conflicts +substUsTy ve (NoteTy note@(UsgNote (UsVar u)) + ty ) = NoteTy (case lookupVarEnv ve u of + Just ua -> UsgNote ua + Nothing -> note) + (substUsTy ve ty) +substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) (substUsTy ve ty2) +substUsTy ve (NoteTy note ty) = NoteTy note (substUsTy ve ty) + +substUsTy ve (PredTy (Class c tys)) = PredTy (Class c (map (substUsTy ve) tys)) +substUsTy ve (PredTy (IParam n ty)) = PredTy (IParam n (substUsTy ve ty)) +substUsTy ve (TyVarTy tv) = TyVarTy tv +substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1) (substUsTy ve ty2) +substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1) (substUsTy ve ty2) +substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys) +substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty) +\end{code} -mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi -mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi) -splitForAllTy_maybe (NoteTy _ ty) = splitForAllTy_maybe ty -splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty) -splitForAllTy_maybe _ = Nothing +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ -isForAllTy :: GenType flexi -> Bool -isForAllTy (NoteTy _ ty) = isForAllTy ty -isForAllTy (ForAllTy tyvar ty) = True -isForAllTy _ = False +We need to be clever here with usage annotations; they need to be +lifted or lowered through the forall as appropriate. -splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi) -splitForAllTys ty = split ty ty [] +\begin{code} +mkForAllTy :: TyVar -> Type -> Type +mkForAllTy tyvar ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> NoteTy (UsgNote usg) + (ForAllTy tyvar ty') + Nothing -> ForAllTy tyvar ty + +mkForAllTys :: [TyVar] -> Type -> Type +mkForAllTys tyvars ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> NoteTy (UsgNote usg) + (foldr ForAllTy ty' tyvars) + Nothing -> foldr ForAllTy ty tyvars + +splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTy_maybe ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty' + return (tyvar, NoteTy (UsgNote usg) ty'') + Nothing -> splitFAT_m ty + where + splitFAT_m (NoteTy _ ty) = splitFAT_m ty + splitFAT_m (PredTy p) = splitFAT_m (predRepTy p) + splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) + splitFAT_m _ = Nothing + +splitForAllTys :: Type -> ([TyVar], Type) +splitForAllTys ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> let (tvs,ty'') = split ty' ty' [] + in (tvs, NoteTy (UsgNote usg) ty'') + Nothing -> split ty ty [] where - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs + split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs + split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} -@mkPiType@ makes a (->) type or a forall type, depending on whether -it is given a type variable or a term variable. +-- (mkPiType now in CoreUtils) -\begin{code} -mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work... -mkPiType v ty | isId v = mkFunTy (idType v) ty - | otherwise = ForAllTy v ty -\end{code} +Applying a for-all to its arguments \begin{code} -applyTy :: GenType flexi -> GenType flexi -> GenType flexi -applyTy (NoteTy _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = substTy (mkVarEnv [(tv,arg)]) ty -applyTy other arg = panic "applyTy" - -applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi +applyTy :: Type -> Type -> Type +applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg) +applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg) +applyTy (PredTy p) arg = applyTy (predRepTy p) arg +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg ) + substTy (mkTyVarSubst [tv] [arg]) ty +applyTy other arg = panic "applyTy" + +applyTys :: Type -> [Type] -> Type applyTys fun_ty arg_tys - = go [] fun_ty arg_tys + = substTy (mkTyVarSubst tvs arg_tys) ty where - go env ty [] = substTy (mkVarEnv env) ty - go env (NoteTy _ fun) args = go env fun args - go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args - go env other args = panic "applyTys" + (tvs, ty) = split fun_ty arg_tys + + split fun_ty [] = ([], fun_ty) + split (NoteTy note@(UsgNote _) fun_ty) + args = case split fun_ty args of + (tvs, ty) -> (tvs, NoteTy note ty) + split (NoteTy note@(UsgForAll _) fun_ty) + args = case split fun_ty args of + (tvs, ty) -> (tvs, NoteTy note ty) + split (NoteTy _ fun_ty) args = split fun_ty args + split (PredTy p) args = split (predRepTy p) args + split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$ + text "in application of" <+> pprType fun_ty) + case split fun_ty args of + (tvs, ty) -> (tv:tvs, ty) + split other_ty args = panic "applyTys" +\end{code} + +Note that we allow applications to be of usage-annotated- types, as an +extension: we handle them by lifting the annotation outside. The +argument, however, must still be unannotated. + +\begin{code} +hoistForAllTys :: Type -> Type + -- Move all the foralls to the top + -- e.g. T -> forall a. a ==> forall a. T -> a +hoistForAllTys ty + = case hoist ty of { (tvs, body) -> mkForAllTys tvs body } + where + hoist :: Type -> ([TyVar], Type) + hoist ty = case splitFunTys ty of { (args, res) -> + case splitForAllTys res of { + ([], body) -> ([], ty) ; + (tvs1, body1) -> case hoist body1 of { (tvs2,body2) -> + (tvs1 ++ tvs2, mkFunTys args body2) + }}} \end{code} %************************************************************************ %* * \subsection{Stuff to do with the source-language types} + +PredType and ThetaType are used in types for expressions and bindings. +ClassPred and ClassContext are used in class and instance declarations. %* * %************************************************************************ +"Dictionary" types are just ordinary data types, but you can +tell from the type constructor whether it's a dictionary or not. + \begin{code} -type RhoType = Type -type TauType = Type -type ThetaType = [(Class, [Type])] -type SigmaType = Type +mkClassPred clas tys = Class clas tys + +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = mkPredTy (Class clas tys) + +mkDictTys :: ClassContext -> [Type] +mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt] + +mkPredTy :: PredType -> Type +mkPredTy pred = PredTy pred + +predRepTy :: PredType -> Type +-- Convert a predicate to its "representation type"; +-- the type of evidence for that predicate, which is actually passed at runtime +predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys +predRepTy (IParam n ty) = ty + +isPredTy :: Type -> Bool +isPredTy (NoteTy _ ty) = isPredTy ty +isPredTy (PredTy _) = True +isPredTy _ = False + +isDictTy :: Type -> Bool +isDictTy (NoteTy _ ty) = isDictTy ty +isDictTy (PredTy (Class _ _)) = True +isDictTy other = False + +splitPredTy_maybe :: Type -> Maybe PredType +splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty +splitPredTy_maybe (PredTy p) = Just p +splitPredTy_maybe other = Nothing + +splitDictTy_maybe :: Type -> Maybe (Class, [Type]) +splitDictTy_maybe ty = case splitPredTy_maybe ty of + Just p -> getClassTys_maybe p + Nothing -> Nothing + +getClassTys_maybe :: PredType -> Maybe ClassPred +getClassTys_maybe (Class clas tys) = Just (clas, tys) +getClassTys_maybe _ = Nothing + +ipName_maybe :: PredType -> Maybe Name +ipName_maybe (IParam n _) = Just n +ipName_maybe _ = Nothing + +classesToPreds :: ClassContext -> ThetaType +classesToPreds cts = map (uncurry Class) cts + +classesOfPreds :: ThetaType -> ClassContext +classesOfPreds theta = [(clas,tys) | Class clas tys <- theta] \end{code} @isTauTy@ tests for nested for-alls. \begin{code} -isTauTy :: GenType flexi -> Bool -isTauTy (TyVarTy v) = True +isTauTy :: Type -> Bool +isTauTy (TyVarTy v) = True isTauTy (TyConApp _ tys) = all isTauTy tys -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (NoteTy _ ty) = isTauTy ty -isTauTy other = False +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b +isTauTy (PredTy p) = isTauTy (predRepTy p) +isTauTy (NoteTy _ ty) = isTauTy ty +isTauTy other = False \end{code} \begin{code} -mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi -mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta +mkRhoTy :: [PredType] -> Type -> Type +mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta -splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi) +splitRhoTy :: Type -> ([PredType], Type) splitRhoTy ty = split ty ty [] where - split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of - Just pair -> split res res (pair:ts) - Nothing -> (reverse ts, orig_ty) - split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts - split orig_ty ty ts = (reverse ts, orig_ty) + split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of + Just p -> split res res (p:ts) + Nothing -> (reverse ts, orig_ty) + split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts + split orig_ty ty ts = (reverse ts, orig_ty) \end{code} +isSigmaType returns true of any qualified type. It doesn't *necessarily* have +any foralls. E.g. + f :: (?x::Int) => Int -> Int \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) -splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi) +isSigmaTy :: Type -> Bool +isSigmaTy (ForAllTy tyvar ty) = True +isSigmaTy (FunTy a b) = isPredTy a +isSigmaTy (NoteTy _ ty) = isSigmaTy ty +isSigmaTy _ = False + +splitSigmaTy :: Type -> ([TyVar], [PredType], Type) splitSigmaTy ty = (tyvars, theta, tau) where @@ -585,6 +758,18 @@ splitSigmaTy ty = (theta,tau) = splitRhoTy rho \end{code} +\begin{code} +getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to + -- construct a dictionary function name +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (NoteTy _ t) = getDFunTyKey t +getDFunTyKey (FunTy arg _) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +-- PredTy shouldn't happen +\end{code} + %************************************************************************ %* * @@ -596,19 +781,29 @@ splitSigmaTy ty = Finding the kind of a type ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} --- typeKind is only ever used on Types, never Kinds --- If it were used on Kinds, the typeKind of FunTy would not be boxedTypeKind; --- yet at the type level functions are boxed even if neither argument nor --- result are boxed. This seems pretty fishy to me. - -typeKind :: GenType flexi -> Kind +typeKind :: Type -> Kind -typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys typeKind (NoteTy _ ty) = typeKind ty -typeKind (FunTy fun arg) = boxedTypeKind +typeKind (PredTy _) = boxedTypeKind -- Predicates are always + -- represented by boxed types typeKind (AppTy fun arg) = funResultTy (typeKind fun) -typeKind (ForAllTy _ _) = boxedTypeKind + +typeKind (FunTy arg res) = fix_up (typeKind res) + where + fix_up (TyConApp tycon _) | tycon == typeCon + || tycon == openKindCon = boxedTypeKind + 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 boxed 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 (ForAllTy tv ty) = typeKind ty \end{code} @@ -616,31 +811,45 @@ typeKind (ForAllTy _ _) = boxedTypeKind Free variables of a type ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: GenType flexi -> GenTyVarSet flexi +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 (UsgNote _) ty) = tyVarsOfType ty +tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty +tyVarsOfType (PredTy p) = tyVarsOfPred p 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 -tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi +tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys +tyVarsOfPred :: PredType -> TyVarSet +tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys +tyVarsOfPred (IParam n ty) = tyVarsOfType ty + +tyVarsOfTheta :: ThetaType -> TyVarSet +tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet + -- Add a Note with the free tyvars to the top of the type -addFreeTyVars :: GenType flexi -> GenType flexi -addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty -addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty +-- (but under a usage if there is one) +addFreeTyVars :: Type -> Type +addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty) +addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty) +addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty +addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty -- Find the free names of a type, including the type constructors and classes it mentions -namesOfType :: GenType flexi -> NameSet +namesOfType :: Type -> NameSet namesOfType (TyVarTy tv) = unitNameSet (getName tv) namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` namesOfTypes tys namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1 namesOfType (NoteTy other_note ty2) = namesOfType ty2 +namesOfType (PredTy p) = namesOfType (predRepTy p) namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar) @@ -651,103 +860,88 @@ namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys %************************************************************************ %* * -\subsection{Instantiating a type} +\subsection{TidyType} %* * %************************************************************************ -@substTy@ applies a substitution to a type. It deals correctly with name capture. - -\begin{code} -substTy :: GenTyVarSubst flexi -> GenType flexi -> GenType flexi -substTy tenv ty = subst_ty tenv tset ty - where - tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv - -- If ty doesn't have any for-alls, then this thunk - -- will never be evaluated -\end{code} +tidyTy tidies up a type for printing in an error message, or in +an interface file. -@fullSubstTy@ is like @substTy@ except that it needs to be given a set -of in-scope type variables. In exchange it's a bit more efficient, at least -if you happen to have that set lying around. +It doesn't change the uniques at all, just the print names. \begin{code} -fullSubstTy :: GenTyVarSubst flexi -- Substitution to apply - -> GenTyVarSet flexi -- Superset of the free tyvars of - -- the range of the tyvar env - -> GenType flexi -> GenType flexi --- ASSUMPTION: The substitution is idempotent. --- Equivalently: No tyvar is both in scope, and in the domain of the substitution. -fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty - | otherwise = subst_ty tenv tset ty - --- subst_ty does the business -subst_ty tenv tset ty - = go ty +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. where - go (TyConApp tc tys) = TyConApp tc (map go tys) - go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2) - go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note - go (FunTy arg res) = FunTy (go arg) (go res) - go (AppTy fun arg) = mkAppTy (go fun) (go arg) - go ty@(TyVarTy tv) = case (lookupVarEnv tenv tv) of - Nothing -> ty - Just ty' -> ty' - go (ForAllTy tv ty) = case substTyVar tenv tset tv of - (tenv', tset', tv') -> ForAllTy tv' (subst_ty tenv' tset' ty) - -substTyVar :: GenTyVarSubst flexi -> GenTyVarSet flexi -> GenTyVar flexi - -> (GenTyVarSubst flexi, GenTyVarSet flexi, GenTyVar flexi) - -substTyVar tenv tset tv - | not (tv `elemVarSet` tset) -- No need to clone - -- But must delete from substitution - = (tenv `delVarEnv` tv, tset `extendVarSet` tv, tv) - - | otherwise -- The forall's variable is in scope so - -- we'd better rename it away from the in-scope variables - -- Extending the substitution to do this renaming also - -- has the (correct) effect of discarding any existing - -- substitution for that variable - = (extendVarEnv tenv tv (TyVarTy tv'), tset `extendVarSet` tv', tv') - where - tv' = uniqAway tset tv -\end{code} + name = tyVarName tyvar +tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars -@substFlexiTy@ applies a substitution to a (GenType flexi1) returning -a (GenType flexi2). Note that we convert from one flexi status to another. +tidyType :: TidyEnv -> Type -> Type +tidyType env@(tidy_env, subst) ty + = go ty + where + go (TyVarTy tv) = case lookupVarEnv subst tv of + Nothing -> TyVarTy tv + 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 (PredTy p) = PredTy (go_pred p) + 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) + where + (envp, tvp) = tidyTyVar env tv + + go_note (SynNote ty) = SynNote SAPPLY (go ty) + go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars + go_note note@(UsgNote _) = note -- Usage annotation is already tidy + go_note note@(UsgForAll _) = note -- Uvar binder is already tidy + + go_pred (Class c tys) = Class c (tidyTypes env tys) + go_pred (IParam n ty) = IParam n (go ty) + +tidyTypes env tys = map (tidyType env) tys +\end{code} -Two assumptions, for (substFlexiTy env ty) - (a) the substitution, env, must cover all free tyvars of the type, ty - (b) the free vars of the range of the substitution must be - different than any of the forall'd variables in the type, ty -The latter assumption is reasonable because, after all, ty has a different -type to the range of the substitution. +@tidyOpenType@ grabs the free type variables, tidies them +and then uses @tidyType@ to work over the type itself \begin{code} -substFlexiTy :: GenTyVarSubst flexi2 -> GenType flexi1 -> GenType flexi2 -substFlexiTy env ty = go ty +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType env' ty) where - go (TyVarTy tv) = case lookupVarEnv env tv of - Just ty -> ty - Nothing -> pprPanic "substFlexiTy" (ppr tv) - go (TyConApp tc tys) = TyConApp tc (map go tys) - go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2) - go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free tyvar note - go (FunTy arg res) = FunTy (go arg) (go res) - go (AppTy fun arg) = mkAppTy (go fun) (go arg) - go (ForAllTy tv ty) = ForAllTy tv' (substFlexiTy env' ty) - where - tv' = removeTyVarFlexi tv - env' = extendVarEnv env tv (TyVarTy tv') - -substFlexiTheta :: GenTyVarSubst flexi2 -> [(Class, [GenType flexi1])] - -> [(Class, [GenType flexi2])] -substFlexiTheta env theta = [(clas, map (substFlexiTy env) tys) | (clas,tys) <- theta] + env' = foldl go env (varSetElems (tyVarsOfType ty)) + go env tyvar = fst (tidyTyVar env tyvar) + +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys + +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty \end{code} + %************************************************************************ %* * \subsection{Boxedness and liftedness} @@ -755,144 +949,152 @@ substFlexiTheta env theta = [(clas, map (substFlexiTy env) tys) | (clas,tys) <- %************************************************************************ \begin{code} -isUnboxedType :: GenType flexi -> Bool +isUnboxedType :: Type -> Bool isUnboxedType ty = not (isFollowableRep (typePrimRep ty)) -isUnLiftedType :: GenType flexi -> Bool -isUnLiftedType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> isUnLiftedTyCon tc - other -> False +isUnLiftedType :: Type -> Bool + -- isUnLiftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them -isUnboxedTupleType :: GenType flexi -> Bool +isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty +isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty +isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType other = False + +isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> isUnboxedTupleTyCon tc other -> False -isAlgType :: GenType flexi -> Bool +-- Should only be applied to *types*; hence the assert +isAlgType :: Type -> Bool isAlgType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> isAlgTyCon tc + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isAlgTyCon tc + other -> False + +-- Should only be applied to *types*; hence the assert +isDataType :: Type -> Bool +isDataType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isDataTyCon tc other -> False -typePrimRep :: GenType flexi -> PrimRep -typePrimRep ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> tyConPrimRep tc - other -> PtrRep +isNewType :: Type -> Bool +isNewType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isNewTyCon tc + other -> False \end{code} + +%************************************************************************ +%* * +\subsection{Sequencing on types +%* * +%************************************************************************ + +\begin{code} +seqType :: Type -> () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (NoteTy note t2) = seqNote note `seq` seqType t2 +seqType (PredTy p) = seqPred p +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy tv ty) = tv `seq` seqType ty + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +seqNote :: TyNote -> () +seqNote (SynNote ty) = seqType ty +seqNote (FTVNote set) = sizeUniqSet set `seq` () +seqNote (UsgNote usg) = usg `seq` () + +seqPred :: PredType -> () +seqPred (Class c tys) = c `seq` seqTypes tys +seqPred (IParam n ty) = n `seq` seqType ty +\end{code} + + %************************************************************************ %* * \subsection{Equality on types} %* * %************************************************************************ + For the moment at least, type comparisons don't work if there are embedded for-alls. \begin{code} -instance Eq (GenType flexi) where - ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False } +instance Eq Type where + ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False } -instance Ord (GenType flexi) where - compare ty1 ty2 = cmpTy ty1 ty2 +instance Ord Type where + compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2 -cmpTy :: GenType flexi -> GenType flexi -> Ordering -cmpTy ty1 ty2 - = cmp emptyVarEnv ty1 ty2 - where +cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering -- The "env" maps type variables in ty1 to type variables in ty2 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2) -- we in effect substitute tv2 for tv1 in t1 before continuing - lookup env tv1 = case lookupVarEnv env tv1 of - Just tv2 -> tv2 - Nothing -> tv1 -- Get rid of NoteTy - cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2 - cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2 - +cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2 +cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2 + + -- Get rid of PredTy +cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2 +cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2 +cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2) + -- Deal with equal constructors - cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2 - cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2 - cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2 - cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2) - cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2 +cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of + Just tv1a -> tv1a `compare` tv2 + Nothing -> tv1 `compare` tv2 + +cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 +cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 +cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) +cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy - cmp env (AppTy _ _) (TyVarTy _) = GT +cmpTy env (AppTy _ _) (TyVarTy _) = GT - cmp env (FunTy _ _) (TyVarTy _) = GT - cmp env (FunTy _ _) (AppTy _ _) = GT +cmpTy env (FunTy _ _) (TyVarTy _) = GT +cmpTy env (FunTy _ _) (AppTy _ _) = GT - cmp env (TyConApp _ _) (TyVarTy _) = GT - cmp env (TyConApp _ _) (AppTy _ _) = GT - cmp env (TyConApp _ _) (FunTy _ _) = GT +cmpTy env (TyConApp _ _) (TyVarTy _) = GT +cmpTy env (TyConApp _ _) (AppTy _ _) = GT +cmpTy env (TyConApp _ _) (FunTy _ _) = GT - cmp env (ForAllTy _ _) other = GT +cmpTy env (ForAllTy _ _) other = GT - cmp env _ _ = LT - - cmps env [] [] = EQ - cmps env (t:ts) [] = GT - cmps env [] (t:ts) = LT - cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s -\end{code} - - - -%************************************************************************ -%* * -\subsection{Grime} -%* * -%************************************************************************ +cmpTy env _ _ = LT +cmpTys env [] [] = EQ +cmpTys env (t:ts) [] = GT +cmpTys env [] (t:ts) = LT +cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s +\end{code} \begin{code} -showTypeCategory :: Type -> Char - {- - {C,I,F,D} char, int, float, double - T tuple - S other single-constructor type - {c,i,f,d} unboxed ditto - t *unpacked* tuple - s *unpacked" single-cons... - - v void# - a primitive array - - E enumeration type - + dictionary, unless it's a ... - L List - > function - M other (multi-constructor) data-con type - . other type - - reserved for others to mark as "uninteresting" - -} -showTypeCategory ty - = if isDictTy ty - then '+' - else - case splitTyConApp_maybe ty of - Nothing -> if maybeToBool (splitFunTy_maybe ty) - then '>' - else '.' - - Just (tycon, _) -> - let utc = getUnique tycon in - if utc == charDataConKey then 'C' - else if utc == intDataConKey then 'I' - else if utc == floatDataConKey then 'F' - else if utc == doubleDataConKey then 'D' - else if utc == integerDataConKey then 'J' - else if utc == charPrimTyConKey then 'c' - else if (utc == intPrimTyConKey || utc == wordPrimTyConKey - || utc == addrPrimTyConKey) then 'i' - else if utc == floatPrimTyConKey then 'f' - else if utc == doublePrimTyConKey then 'd' - else if isPrimTyCon tycon {- array, we hope -} then 'A' - else if isEnumerationTyCon tycon then 'E' - else if isTupleTyCon tycon then 'T' - else if maybeToBool (maybeTyConSingleCon tycon) then 'S' - else if utc == listTyConKey then 'L' - else 'M' -- oh, well... +instance Eq PredType where + p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False } + +instance Ord PredType where + compare p1 p2 = cmpPred emptyVarEnv p1 p2 + +cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering +cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2 + -- Just compare the names! +cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) +cmpPred env (IParam _ _) (Class _ _) = LT +cmpPred env (Class _ _) (IParam _ _) = GT \end{code}