X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=8271ce32f389168eac64f3219f2002b90aef3ae9;hb=938f825c4c3aac524459a801816db10718dff9de;hp=b52b884cb2c9da70e59151779ce5059581964797;hpb=d3e697b8d842bd43329d470f2bc424a6dcb88d89;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index b52b884..8271ce3 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,100 +1,132 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[Type]{Type - public interface} + \begin{code} module Type ( - GenType(..), Type, + -- re-exports from TypeRep: + Type, + Kind, TyVarSubst, + + superKind, superBoxity, -- :: SuperKind + + boxedKind, -- :: Kind :: BX + anyBoxKind, -- :: Kind :: BX + typeCon, -- :: KindCon :: BX -> KX + anyBoxCon, -- :: KindCon :: BX + + boxedTypeKind, unboxedTypeKind, openTypeKind, -- Kind :: superKind + + mkArrowKind, mkArrowKinds, -- mentioned below: hasMoreBoxityInfo, + + funTyCon, + + -- exports from this module: + hasMoreBoxityInfo, mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, + mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN, + funResultTy, funArgTy, zipFunTys, mkTyConApp, mkTyConTy, splitTyConApp_maybe, - splitAlgTyConApp_maybe, splitAlgTyConApp, + splitAlgTyConApp_maybe, splitAlgTyConApp, mkDictTy, splitDictTy_maybe, isDictTy, - mkSynTy, isSynTy, + mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe, + + UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, + mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, + isForAllTy, applyTy, applyTys, mkPiType, TauType, RhoType, SigmaType, ThetaType, isTauTy, mkRhoTy, splitRhoTy, mkSigmaTy, splitSigmaTy, - isUnpointedType, isUnboxedType, typePrimRep, - - matchTy, matchTys, + -- Lifting and boxity + isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType, + typePrimRep, + -- Free variables tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + addFreeTyVars, + + -- Tidying up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVar, tidyTyVars, + tidyTopType, - instantiateTy, instantiateTauTy, instantiateThetaTy, + -- Seq + seqType, seqTypes - showTypeCategory ) where #include "HsVersions.h" -import {-# SOURCE #-} Id ( Id ) +-- 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, dataConType ) +import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages +import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy ) -- friends: +import Var ( TyVar, IdOrTyVar, UVar, + tyVarKind, tyVarName, setTyVarName, isId, idType, + ) +import VarEnv +import VarSet + +import Name ( NamedThing(..), mkLocalName, tidyOccName, + ) +import NameSet import Class ( classTyCon, Class ) -import Kind ( mkBoxedTypeKind, resultKind, Kind ) -import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon, - isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity, - tyConKind, tyConDataCons, getSynTyConDefn, - tyConPrimRep, tyConClass_maybe, TyCon ) -import TyVar ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar, - tyVarKind, emptyTyVarSet, unionTyVarSets, minusTyVarSet, - unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv, - emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv ) -import Name ( NamedThing(..), - NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet +import TyCon ( TyCon, + isUnboxedTupleTyCon, isUnLiftedTyCon, + isFunTyCon, isDataTyCon, isNewTyCon, + isAlgTyCon, isSynTyCon, tyConArity, + tyConKind, tyConDataCons, getSynTyConDefn, + tyConPrimRep, tyConClass_maybe ) -- others -import BasicTypes ( Unused ) -import Maybes ( maybeToBool, assocMaybe ) -import PrimRep ( PrimRep(..) ) -import Unique -- quite a few *Keys -import Util ( thenCmp, panic, assertPanic ) +import SrcLoc ( noSrcLoc ) +import Maybes ( maybeToBool ) +import PrimRep ( PrimRep(..), isFollowableRep ) +import Unique ( Uniquable(..) ) +import Util ( mapAccumL, seqList ) +import Outputable +import UniqSet ( sizeUniqSet ) -- Should come via VarSet \end{code} - %************************************************************************ %* * -\subsection{The data type} +\subsection{Stuff to do with kinds.} %* * %************************************************************************ - \begin{code} -type Type = GenType Unused -- Used after typechecker - -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) - - | SynTy -- Saturated application of a type synonym - (GenType flexi) -- The unexpanded version; always a TyConTy - (GenType flexi) -- The expanded version - - | ForAllTy - (GenTyVar flexi) - (GenType flexi) -- TypeKind +hasMoreBoxityInfo :: Kind -> Kind -> Bool +hasMoreBoxityInfo k1 k2 + | k2 == openTypeKind = ASSERT( is_type_kind k1) True + | otherwise = k1 == k2 + where + -- Returns true for things of form (Type x) + is_type_kind k = case splitTyConApp_maybe k of + Just (tc,[_]) -> tc == typeCon + Nothing -> False \end{code} @@ -109,26 +141,26 @@ data GenType flexi -- Parameterised over the "flexi" part of a type variable 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 (SynTy _ t) = getTyVar msg t +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 (SynTy _ t) = getTyVar_maybe t +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t getTyVar_maybe other = Nothing -isTyVarTy :: GenType flexi -> Bool -isTyVarTy (TyVarTy tv) = True -isTyVarTy (SynTy _ ty) = isTyVarTy ty -isTyVarTy other = False +isTyVarTy :: Type -> Bool +isTyVarTy (TyVarTy tv) = True +isTyVarTy (NoteTy _ ty) = isTyVarTy ty +isTyVarTy other = False \end{code} @@ -140,42 +172,52 @@ 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 ) + mk_app orig_ty1 where - mk_app (SynTy _ ty1) = mk_app ty1 + 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 ) + mk_app orig_ty1 where - mk_app (SynTy _ ty1) = mk_app ty1 + 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 - -splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi) -splitAppTy (FunTy ty1 ty2) = (TyConApp mkFunTyCon [ty1], ty2) -splitAppTy (AppTy ty1 ty2) = (ty1, ty2) -splitAppTy (SynTy _ ty) = splitAppTy ty -splitAppTy (TyConApp tc tys) = split tys [] + 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 :: 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 (TyConApp tc []) = Nothing +splitAppTy_maybe (TyConApp tc tys) = split tys [] where - split [ty2] acc = (TyConApp tc (reverse acc), ty2) + split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) split (ty:tys) acc = split tys (ty:acc) -splitAppTy other = panic "splitAppTy" -splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi]) +splitAppTy_maybe other = Nothing + +splitAppTy :: Type -> (Type, Type) +splitAppTy ty = case splitAppTy_maybe ty of + Just pr -> pr + Nothing -> panic "splitAppTy" + +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 (SynTy _ ty) args = split orig_ty ty args + split orig_ty (NoteTy _ ty) args = split orig_ty ty args split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) - (TyConApp mkFunTyCon [], [ty1,ty2]) + (TyConApp funTyCon [], [ty1,ty2]) split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) split orig_ty ty args = (orig_ty, args) \end{code} @@ -186,26 +228,50 @@ 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_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe (SynTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty 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 (SynTy _ ty) = split args orig_ty ty + split args orig_ty (NoteTy _ ty) = split args orig_ty ty split args orig_ty ty = (reverse args, orig_ty) -\end{code} +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 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 (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 = pprPanic "funResultTy" (pprType ty) + +funArgTy :: Type -> Type +funArgTy (FunTy arg res) = arg +funArgTy (NoteTy _ ty) = funArgTy ty +funArgTy ty = pprPanic "funArgTy" (pprType ty) +\end{code} --------------------------------------------------------------------- @@ -213,7 +279,7 @@ splitFunTys ty = split [] ty ty ~~~~~~~~ \begin{code} -mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi +mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon && length tys == 2 = case tys of @@ -223,7 +289,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 [] @@ -231,10 +297,10 @@ 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 (mkFunTyCon, [arg,res]) -splitTyConApp_maybe (SynTy _ ty) = splitTyConApp_maybe ty +splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe other = Nothing -- splitAlgTyConApp_maybe looks for @@ -242,28 +308,28 @@ splitTyConApp_maybe other = Nothing -- "Algebraic" => newtype, data type, or dictionary (not function types) -- We return the constructors too. -splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id]) +splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon]) splitAlgTyConApp_maybe (TyConApp tc tys) | isAlgTyCon tc && - tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) -splitAlgTyConApp_maybe (SynTy _ ty) = splitAlgTyConApp_maybe ty -splitAlgTyConApp_maybe other = Nothing + tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) +splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty +splitAlgTyConApp_maybe other = Nothing -splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id]) +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 (SynTy _ ty) = splitAlgTyConApp ty +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 :: Class -> [Type] -> Type mkDictTy clas tys = TyConApp (classTyCon clas) tys -splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi]) +splitDictTy_maybe :: Type -> Maybe (Class, [Type]) splitDictTy_maybe (TyConApp tc tys) | maybeToBool maybe_class && tyConArity tc == length tys = Just (clas, tys) @@ -271,34 +337,44 @@ splitDictTy_maybe (TyConApp tc tys) maybe_class = tyConClass_maybe tc Just clas = maybe_class -splitDictTy_maybe (SynTy _ ty) = splitDictTy_maybe ty +splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty splitDictTy_maybe other = Nothing -isDictTy :: GenType flexi -> Bool +isDictTy :: Type -> Bool -- This version is slightly more efficient than (maybeToBool . splitDictTy) isDictTy (TyConApp tc tys) | maybeToBool (tyConClass_maybe tc) && tyConArity tc == length tys = True -isDictTy (SynTy _ ty) = isDictTy ty -isDictTy other = False +isDictTy (NoteTy _ ty) = isDictTy ty +isDictTy other = False \end{code} - --------------------------------------------------------------------- SynTy ~~~~~ \begin{code} mkSynTy syn_tycon tys - = ASSERT(isSynTyCon syn_tycon) - SynTy (TyConApp syn_tycon tys) - (instantiateTauTy (zipTyVarEnv tyvars tys) body) + = ASSERT( isSynTyCon syn_tycon ) + ASSERT( isNotUsgTy body ) + ASSERT( length tyvars == length tys ) + NoteTy (SynNote (TyConApp syn_tycon tys)) + (substTy (mkTyVarSubst tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon -isSynTy (SynTy _ _) = True -isSynTy other = False +isSynTy (NoteTy (SynNote _) _) = True +isSynTy other = False + +deNoteType :: Type -> Type + -- Sorry for the cute name +deNoteType ty@(TyVarTy tyvar) = ty +deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) +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 @@ -317,47 +393,237 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. +repType looks through + (a) for-alls, and + (b) newtypes +in addition to synonyms. It's useful in the back end where we're not +interested in newtypes anymore. + +\begin{code} +repType :: Type -> Type +repType (NoteTy _ ty) = repType ty +repType (ForAllTy _ ty) = repType ty +repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys) +repType other_ty = other_ty + +splitNewType_maybe :: Type -> Maybe Type +-- Find the representation of a newtype, if it is one +-- Looks through multiple levels of newtype +splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty +splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of + Just rep_ty' -> Just rep_ty' + Nothing -> Just rep_ty + where + rep_ty = new_type_rep tc tys + +splitNewType_maybe other = Nothing + +new_type_rep :: TyCon -> [Type] -> Type +-- The representation type for (T t1 .. tn), where T is a newtype +-- Looks through one layer only +new_type_rep tc tys + = ASSERT( isNewTyCon tc ) + case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of + Just (rep_ty, _) -> rep_ty +\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 note@(UsgNote _) ty ) = NoteTy note (substUsTy ve ty) +substUsTy ve (NoteTy note@(UsgForAll _) ty ) = NoteTy note (substUsTy ve ty) +substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) + (substUsTy ve ty2) +substUsTy ve (NoteTy note@(FTVNote _) ty ) = NoteTy note (substUsTy ve ty) +substUsTy ve ty@(TyVarTy _ ) = ty +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 (SynTy _ ty) = splitForAllTy_maybe ty -splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty) -splitForAllTy_maybe _ = Nothing +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ + +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 (ForAllTy tyvar ty) = Just(tyvar, ty) + splitFAT_m _ = Nothing + +isForAllTy :: Type -> Bool +isForAllTy (NoteTy _ ty) = isForAllTy ty +isForAllTy (ForAllTy tyvar ty) = True +isForAllTy _ = False + +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 (SynTy _ ty) tvs = split orig_ty ty tvs + split orig_ty (NoteTy _ ty) tvs = split orig_ty ty 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. \begin{code} -applyTy :: GenType flexi -> GenType flexi -> GenType flexi -applyTy (SynTy _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty -applyTy other arg = panic "applyTy" +mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work... +mkPiType v ty | isId v = mkFunTy (idType v) ty + | otherwise = mkForAllTy v ty +\end{code} -applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi +Applying a for-all to its arguments + +\begin{code} +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 (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 [] = instantiateTy (mkTyVarEnv env) ty - go env (SynTy _ 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 (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. + %************************************************************************ %* * @@ -375,26 +641,26 @@ type SigmaType = Type @isTauTy@ tests for nested for-alls. \begin{code} -isTauTy :: GenType flexi -> Bool +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 (SynTy _ ty) = isTauTy ty +isTauTy (NoteTy _ ty) = isTauTy ty isTauTy other = False \end{code} \begin{code} -mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi +mkRhoTy :: [(Class, [Type])] -> Type -> Type mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta -splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi) +splitRhoTy :: Type -> ([(Class, [Type])], 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 (SynTy _ ty) ts = split orig_ty ty ts + split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts split orig_ty ty ts = (reverse ts, orig_ty) \end{code} @@ -403,7 +669,7 @@ splitRhoTy ty = split ty ty [] \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) -splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi) +splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type) splitSigmaTy ty = (tyvars, theta, tau) where @@ -422,14 +688,18 @@ splitSigmaTy ty = Finding the kind of a type ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -typeKind :: GenType flexi -> Kind - -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (TyConApp tycon tys) = foldr (\_ k -> resultKind k) (tyConKind tycon) tys -typeKind (SynTy _ ty) = typeKind ty -typeKind (FunTy fun arg) = mkBoxedTypeKind -typeKind (AppTy fun arg) = resultKind (typeKind fun) -typeKind (ForAllTy _ _) = mkBoxedTypeKind +typeKind :: Type -> Kind + +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys +typeKind (NoteTy _ ty) = typeKind ty +typeKind (AppTy fun arg) = funResultTy (typeKind fun) + +typeKind (FunTy arg res) = boxedTypeKind -- A function is boxed regardless of its result type + -- No functions at the type level, hence we don't need + -- to say (typeKind res). + +typeKind (ForAllTy tv ty) = typeKind ty \end{code} @@ -437,24 +707,36 @@ typeKind (ForAllTy _ _) = mkBoxedTypeKind Free variables of a type ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: GenType flexi -> GenTyVarSet flexi +tyVarsOfType :: Type -> TyVarSet -tyVarsOfType (TyVarTy tv) = unitTyVarSet tv +tyVarsOfType (TyVarTy tv) = unitVarSet tv tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys -tyVarsOfType (SynTy ty1 ty2) = tyVarsOfType ty1 -tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res -tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg -tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar - -tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi -tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet 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 (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 :: [Type] -> TyVarSet +tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys + +-- Add a Note with the free tyvars to the top of the type +-- (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 (SynTy ty1 ty2) = namesOfType ty1 +namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1 +namesOfType (NoteTy other_note ty2) = namesOfType ty2 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) @@ -465,297 +747,159 @@ namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys %************************************************************************ %* * -\subsection{Instantiating a type} +\subsection{TidyType} %* * %************************************************************************ -\begin{code} -instantiateTy :: TyVarEnv (GenType flexi) -> GenType flexi -> GenType flexi -instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2 - - --- instantiateTy applies a type environment to a type. --- It can handle shadowing; for example: --- f = /\ t1 t2 -> \ d -> --- letrec f' = /\ t1 -> \x -> ...(f' t1 x')... --- in f' t1 --- Here, when we clone t1 to t1', say, we'll come across shadowing --- when applying the clone environment to the type of f'. --- --- As a sanity check, we should also check that name capture --- doesn't occur, but that means keeping track of the free variables of the --- range of the TyVarEnv, which I don't do just yet. - -instantiateTy tenv ty - | isEmptyTyVarEnv tenv - = ty +tidyTy tidies up a type for printing in an error message, or in +an interface file. - | otherwise - = go tenv ty - where - go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of - Nothing -> ty - Just ty -> ty - go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys) - go tenv (SynTy ty1 ty2) = SynTy (go tenv ty1) (go tenv ty2) - go tenv (FunTy arg res) = FunTy (go tenv arg) (go tenv res) - go tenv (AppTy fun arg) = mkAppTy (go tenv fun) (go tenv arg) - go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty) - where - tenv' = case lookupTyVarEnv tenv tv of - Nothing -> tenv - Just _ -> delFromTyVarEnv tenv tv +It doesn't change the uniques at all, just the print names. --- instantiateTauTy works only (a) on types with no ForAlls, --- and when (b) all the type variables are being instantiated --- In return it is more polymorphic than instantiateTy +\begin{code} +tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVar env@(tidy_env, subst) tyvar + = case lookupVarEnv subst tyvar of -instantiateTauTy tenv ty = go ty - where - go ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of - Just ty -> ty -- Must succeed - go (TyConApp tc tys) = TyConApp tc (map go tys) - go (SynTy ty1 ty2) = SynTy (go ty1) (go ty2) - go (FunTy arg res) = FunTy (go arg) (go res) - go (AppTy fun arg) = mkAppTy (go fun) (go arg) - go (ForAllTy tv ty) = panic "instantiateTauTy" - - -instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType -instantiateThetaTy tenv theta - = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta] -\end{code} + Just tyvar' -> -- Already substituted + (env, tyvar') + Nothing -> -- Make a new nice name for it -%************************************************************************ -%* * -\subsection{Boxedness and pointedness} -%* * -%************************************************************************ - -A type is - *unboxed* iff its representation is other than a pointer - Unboxed types cannot instantiate a type variable - Unboxed types are always unpointed. - - *unpointed* iff it can't be a thunk, and cannot have value bottom - An unpointed type may or may not be unboxed. - (E.g. Array# is unpointed, but boxed.) - An unpointed type *can* instantiate a type variable, - provided it is boxed. + 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 - *primitive* iff it is a built-in type that can't be expressed - in Haskell +tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars -Currently, all primitive types are unpointed, but that's not necessarily -the case. (E.g. Int could be primitive.) +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 (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 -\begin{code} -isUnboxedType :: Type -> Bool -isUnboxedType ty = case typePrimRep ty of - PtrRep -> False - other -> True - --- Danger! Currently the unpointed types are precisely --- the primitive ones, but that might not always be the case -isUnpointedType :: Type -> Bool -isUnpointedType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> isPrimTyCon tc - other -> False + 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 -typePrimRep :: Type -> PrimRep -typePrimRep ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> tyConPrimRep tc - other -> PtrRep +tidyTypes env tys = map (tidyType env) tys \end{code} -%************************************************************************ -%* * -\subsection{Matching on types} -%* * -%************************************************************************ - -Matching is a {\em unidirectional} process, matching a type against a -template (which is just a type with type variables in it). The -matcher assumes that there are no repeated type variables in the -template, so that it simply returns a mapping of type variables to -types. It also fails on nested foralls. - -@matchTys@ matches corresponding elements of a list of templates and -types. +@tidyOpenType@ grabs the free type variables, tidies them +and then uses @tidyType@ to work over the type itself \begin{code} -matchTy :: GenType flexi1 -- Template - -> GenType flexi2 -- Proposed instance of template - -> Maybe (TyVarEnv (GenType flexi2)) -- Matching substitution - - -matchTys :: [GenType flexi1] -- Templates - -> [GenType flexi2] -- Proposed instance of template - -> Maybe (TyVarEnv (GenType flexi2), -- Matching substitution - [GenType flexi2]) -- Left over instance types - -matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) emptyTyVarEnv -matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv -\end{code} +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType env' ty) + where + env' = foldl go env (varSetElems (tyVarsOfType ty)) + go env tyvar = fst (tidyTyVar env tyvar) -@match@ is the main function. +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys -\begin{code} -match :: GenType flexi1 -> GenType flexi2 -- Current match pair - -> (TyVarEnv (GenType flexi2) -> Maybe result) -- Continuation - -> TyVarEnv (GenType flexi2) -- Current substitution - -> Maybe result - --- When matching against a type variable, see if the variable --- has already been bound. If so, check that what it's bound to --- is the same as ty; if not, bind it and carry on. - -match (TyVarTy v) ty k = \s -> case lookupTyVarEnv s v of - Nothing -> k (addToTyVarEnv s v ty) - Just ty' | ty' == ty -> k s -- Succeeds - | otherwise -> Nothing -- Fails - -match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k) -match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k) -match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2 - = match_list tys1 tys2 ( \(s,tys2') -> - if null tys2' then - k s -- Succeed - else - Nothing -- Fail - ) - - -- With type synonyms, we have to be careful for the exact - -- same reasons as in the unifier. Please see the - -- considerable commentary there before changing anything - -- here! (WDP 95/05) -match (SynTy _ ty1) ty2 k = match ty1 ty2 k -match ty1 (SynTy _ ty2) k = match ty1 ty2 k - --- Catch-all fails -match _ _ _ = \s -> Nothing - -match_list [] tys2 k = \s -> k (s, tys2) -match_list (ty1:tys1) [] k = panic "match_list" -match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty \end{code} + %************************************************************************ %* * -\subsection{Equality on types} +\subsection{Boxedness and liftedness} %* * %************************************************************************ -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 Ord (GenType flexi) where - compare ty1 ty2 = cmpTy ty1 ty2 +isUnboxedType :: Type -> Bool +isUnboxedType ty = not (isFollowableRep (typePrimRep ty)) + +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 + +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 -cmpTy :: GenType flexi -> GenType flexi -> Ordering -cmpTy ty1 ty2 - = cmp emptyTyVarEnv ty1 ty2 - where - -- 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 lookupTyVarEnv env tv1 of - Just tv2 -> tv2 - Nothing -> tv1 - - -- Get rid of SynTy - cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2 - cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2 - - -- 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 (addToTyVarEnv env tv1 tv2) t1 t2 - - -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy - cmp env (AppTy _ _) (TyVarTy _) = GT - - cmp env (FunTy _ _) (TyVarTy _) = GT - cmp env (FunTy _ _) (AppTy _ _) = GT - - cmp env (TyConApp _ _) (TyVarTy _) = GT - cmp env (TyConApp _ _) (AppTy _ _) = GT - cmp env (TyConApp _ _) (FunTy _ _) = GT - - cmp env (ForAllTy _ _) other = GT - - cmp env _ _ = LT +-- 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 ) + 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 + +isNewType :: Type -> Bool +isNewType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isNewTyCon tc + other -> False - 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 +typePrimRep :: Type -> PrimRep +typePrimRep ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> tyConPrimRep tc + other -> PtrRep \end{code} - %************************************************************************ %* * -\subsection{Grime} +\subsection{Sequencing on types %* * %************************************************************************ - - \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 = uniqueOf 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... +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 (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` () \end{code} +