X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=ec4160499853f5a13d86560fcdbb65d2c45ec1de;hb=957bf3756ffd56f5329a2aabe1022d6f996dd641;hp=0b9b29423fdd740b29f0768e8847fd207cf10eb1;hpb=be33dbc967b4915cfdb0307ae1b7ae3cee651b8c;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 0b9b294..ec41604 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,99 +1,166 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[Type]{Type - public interface} + \begin{code} module Type ( - GenType(..), Type, + -- re-exports from TypeRep: + Type, PredType, ThetaType, + Kind, TyVarSubst, + + TyThing(..), isTyClThing, + + superKind, superBoxity, -- KX and BX respectively + liftedBoxity, unliftedBoxity, -- :: BX + openKindCon, -- :: KX + typeCon, -- :: BX -> KX + liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX + mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX + isTypeKind, isAnyTypeKind, + funTyCon, + + -- exports from this module: + hasMoreBoxityInfo, defaultKind, mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, + mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, + funResultTy, funArgTy, zipFunTys, isFunTy, - mkTyConApp, mkTyConTy, splitTyConApp_maybe, - splitAlgTyConApp_maybe, splitAlgTyConApp, - mkDictTy, splitDictTy_maybe, isDictTy, + mkGenTyConApp, mkTyConApp, mkTyConTy, + tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, - mkSynTy, isSynTy, + mkSynTy, - mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, + repType, typePrimRep, - TauType, RhoType, SigmaType, ThetaType, - isTauTy, - mkRhoTy, splitRhoTy, - mkSigmaTy, splitSigmaTy, + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + applyTy, applyTys, isForAllTy, dropForAlls, - isUnpointedType, isUnboxedType, typePrimRep, + -- Source types + SourceType(..), sourceTypeRep, mkPredTy, mkPredTys, - matchTy, matchTys, + -- Newtypes + splitNewType_maybe, - tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + -- Lifting and boxity + isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType, - instantiateTy, instantiateTauTy, instantiateThetaTy, + -- Free variables + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, + typeKind, addFreeTyVars, + + -- Tidying up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVarBndr, tidyFreeTyVars, + tidyOpenTyVar, tidyOpenTyVars, + tidyTopType, tidyPred, + + -- Comparison + eqType, eqKind, + + -- 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 #-} PprType( pprType ) -- Only called in debug messages +import {-# SOURCE #-} Subst ( substTyWith ) -- friends: -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 Var ( Id, TyVar, tyVarKind, tyVarName, setTyVarName ) +import VarEnv +import VarSet + +import Name ( NamedThing(..), mkInternalName, tidyOccName ) +import Class ( Class, classTyCon ) +import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, + isUnboxedTupleTyCon, isUnLiftedTyCon, + isFunTyCon, isNewTyCon, newTyConRep, + isAlgTyCon, isSynTyCon, tyConArity, + tyConKind, getSynTyConDefn, + tyConPrimRep, ) -- others -import BasicTypes ( Unused ) -import Maybes ( maybeToBool, assocMaybe ) -import PrimRep ( PrimRep(..) ) -import Unique -- quite a few *Keys -import Util ( thenCmp, panic ) +import CmdLineOpts ( opt_DictsStrict ) +import SrcLoc ( noSrcLoc ) +import PrimRep ( PrimRep(..) ) +import Unique ( Uniquable(..) ) +import Util ( mapAccumL, seqList, lengthIs, snocView ) +import Outputable +import UniqSet ( sizeUniqSet ) -- Should come via VarSet +import Maybe ( isJust ) \end{code} - %************************************************************************ %* * -\subsection{The data type} + TyThing %* * %************************************************************************ - \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) +data TyThing = AnId Id + | ATyCon TyCon + | AClass Class + +isTyClThing :: TyThing -> Bool +isTyClThing (ATyCon _) = True +isTyClThing (AClass _) = True +isTyClThing (AnId _) = False + +instance NamedThing TyThing where + getName (AnId id) = getName id + getName (ATyCon tc) = getName tc + getName (AClass cl) = getName cl +\end{code} - | 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) +%************************************************************************ +%* * +\subsection{Stuff to do with kinds.} +%* * +%************************************************************************ - | SynTy -- Saturated application of a type synonym - (GenType flexi) -- The unexpanded version; always a TyConTy - (GenType flexi) -- The expanded version +\begin{code} +hasMoreBoxityInfo :: Kind -> Kind -> Bool +-- (k1 `hasMoreBoxityInfo` k2) checks that k1 <: k2 +hasMoreBoxityInfo k1 k2 + | k2 `eqKind` openTypeKind = isAnyTypeKind k1 + | otherwise = k1 `eqKind` k2 + where - | ForAllTy - (GenTyVar flexi) - (GenType flexi) -- TypeKind +isAnyTypeKind :: Kind -> Bool +-- True of kind * and *# and ? +isAnyTypeKind (TyConApp tc _) = tc == typeCon || tc == openKindCon +isAnyTypeKind (NoteTy _ k) = isAnyTypeKind k +isAnyTypeKind other = False + +isTypeKind :: Kind -> Bool +-- True of kind * and *# +isTypeKind (TyConApp tc _) = tc == typeCon +isTypeKind (NoteTy _ k) = isTypeKind k +isTypeKind other = False + +defaultKind :: Kind -> Kind +-- Used when generalising: default kind '?' to '*' +defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind + | otherwise = kind \end{code} @@ -108,26 +175,29 @@ 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 msg (TyVarTy tv) = tv -getTyVar msg (SynTy _ t) = getTyVar msg t -getTyVar msg other = panic ("getTyVar: " ++ msg) - -getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi) -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe (SynTy _ t) = getTyVar_maybe t -getTyVar_maybe other = Nothing - -isTyVarTy :: GenType flexi -> Bool -isTyVarTy (TyVarTy tv) = True -isTyVarTy (SynTy _ ty) = isTyVarTy ty -isTyVarTy other = False +getTyVar :: String -> Type -> TyVar +getTyVar msg (TyVarTy tv) = tv +getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p) +getTyVar msg (NoteTy _ t) = getTyVar msg t +getTyVar msg other = panic ("getTyVar: " ++ msg) + +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p) +getTyVar_maybe other = Nothing + +isTyVarTy :: Type -> Bool +isTyVarTy (TyVarTy tv) = True +isTyVarTy (NoteTy _ ty) = isTyVarTy ty +isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p) +isTyVarTy other = False \end{code} @@ -139,42 +209,60 @@ 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 + = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * + mk_app orig_ty1 where - mk_app (SynTy _ ty1) = mk_app ty1 - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) + mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2]) mk_app ty1 = AppTy orig_ty1 orig_ty2 - -mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi + -- We call mkGenTyConApp because the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + +mkAppTys :: Type -> [Type] -> Type mkAppTys orig_ty1 [] = orig_ty1 -- This check for an empty list of type arguments - -- avoids the needless of a type synonym constructor. + -- avoids the needless loss 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 + = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * + 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 [] - where - split [ty2] acc = (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 :: Type -> Maybe (Type, Type) +splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) +splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty +splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) +splitAppTy_maybe (TyConApp tc tys) = case snocView tys of + Nothing -> Nothing + Just (tys',ty') -> Just (TyConApp tc tys', ty') +splitAppTy_maybe other = Nothing + +splitAppTy :: Type -> (Type, Type) +splitAppTy ty = case splitAppTy_maybe ty of + 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 (SourceTy p) args = split orig_ty (sourceTypeRep p) 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} @@ -185,44 +273,85 @@ 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) +isFunTy :: Type -> Bool +isFunTy ty = isJust (splitFunTy_maybe ty) + +splitFunTy :: Type -> (Type, Type) +splitFunTy (FunTy arg res) = (arg, res) +splitFunTy (NoteTy _ ty) = splitFunTy ty +splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) + +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 (SourceTy p) = splitFunTy_maybe (sourceTypeRep 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 (SynTy _ ty) = split args orig_ty ty + split args orig_ty (NoteTy _ ty) = split args orig_ty ty + split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) split args orig_ty ty = (reverse args, orig_ty) -\end{code} +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 (SourceTy p) = split acc xs nty (sourceTypeRep 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 (SourceTy p) = funResultTy (sourceTypeRep p) +funResultTy ty = pprPanic "funResultTy" (pprType ty) + +funArgTy :: Type -> Type +funArgTy (FunTy arg res) = arg +funArgTy (NoteTy _ ty) = funArgTy ty +funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) +funArgTy ty = pprPanic "funArgTy" (pprType ty) +\end{code} --------------------------------------------------------------------- TyConApp ~~~~~~~~ +@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy, +as apppropriate. \begin{code} -mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi +mkGenTyConApp :: TyCon -> [Type] -> Type +mkGenTyConApp tc tys + | isSynTyCon tc = mkSynTy tc tys + | otherwise = mkTyConApp tc tys + +mkTyConApp :: TyCon -> [Type] -> Type +-- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those mkTyConApp tycon tys - | isFunTyCon tycon && length tys == 2 - = case tys of - (ty1:ty2:_) -> FunTy ty1 ty2 + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy ty1 ty2 + + | isNewTyCon tycon, -- A saturated newtype application; + not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them) + tys `lengthIs` tyConArity tycon -- use the SourceType form + = SourceTy (NType tycon tys) | otherwise = ASSERT(not (isSynTyCon tycon)) TyConApp tycon tys -mkTyConTy :: TyCon -> GenType flexi +mkTyConTy :: TyCon -> Type mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) TyConApp tycon [] @@ -230,57 +359,23 @@ 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 (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (mkFunTyCon, [arg,res]) -splitTyConApp_maybe (SynTy _ ty) = splitTyConApp_maybe ty -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. - -splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id]) -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 - -splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id]) - -- 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 -\end{code} +tyConAppTyCon :: Type -> TyCon +tyConAppTyCon ty = fst (splitTyConApp ty) -y"Dictionary" types are just ordinary data types, but you can -tell from the type constructor whether it's a dictionary or not. +tyConAppArgs :: Type -> [Type] +tyConAppArgs ty = snd (splitTyConApp ty) -\begin{code} -mkDictTy :: Class -> [GenType flexi] -> GenType flexi -mkDictTy clas tys = TyConApp (classTyCon clas) tys +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = case splitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitTyConApp" (pprType ty) -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 (SynTy _ 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 (SynTy _ ty) = isDictTy ty -isDictTy other = False +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 (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p) +splitTyConApp_maybe other = Nothing \end{code} @@ -289,15 +384,29 @@ isDictTy other = False ~~~~~ \begin{code} -mkSynTy syn_tycon tys - = ASSERT(isSynTyCon syn_tycon) - SynTy (TyConApp syn_tycon tys) - (instantiateTauTy (zipTyVarEnv tyvars tys) body) +mkSynTy tycon tys + | n_args == arity -- Exactly saturated + = mk_syn tys + | n_args > arity -- Over-saturated + = case splitAt arity tys of { (as,bs) -> mkAppTys (mk_syn as) bs } + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because (mk_syn as) might well return a partially-applied + -- type constructor; indeed, usually will! + | otherwise -- Un-saturated + = TyConApp tycon tys + -- For the un-saturated case we build TyConApp directly + -- (mkTyConApp ASSERTs that the tc isn't a SynTyCon). + -- Here we are relying on checkValidType to find + -- the error. What we can't do is use mkSynTy with + -- too few arg tys, because that is utterly bogus. + where - (tyvars, body) = getSynTyConDefn syn_tycon + mk_syn tys = NoteTy (SynNote (TyConApp tycon tys)) + (substTyWith tyvars tys body) -isSynTy (SynTy _ _) = True -isSynTy other = False + (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon + arity = tyConArity tycon + n_args = length tys \end{code} Notes on type synonyms @@ -315,6 +424,38 @@ 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) synonyms + (c) predicates + (d) usage annotations + (e) [recursive] newtypes +It's useful in the back end. + +Remember, non-recursive newtypes get expanded as part of the SourceTy case, +but recursive ones are represented by TyConApps and have to be expanded +by steam. + +\begin{code} +repType :: Type -> Type +repType (ForAllTy _ ty) = repType ty +repType (NoteTy _ ty) = repType ty +repType (SourceTy p) = repType (sourceTypeRep p) +repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc + = repType (newTypeRep tc tys) +repType ty = ty + + +typePrimRep :: Type -> PrimRep +typePrimRep ty = case repType ty of + TyConApp tc _ -> tyConPrimRep tc + FunTy _ _ -> PtrRep + AppTy _ _ -> PtrRep -- ?? + TyVarTy _ -> PtrRep +\end{code} + --------------------------------------------------------------------- @@ -322,83 +463,116 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. ~~~~~~~~ \begin{code} -mkForAllTy = ForAllTy +mkForAllTy :: TyVar -> Type -> Type +mkForAllTy tyvar ty + = mkForAllTys [tyvar] ty -mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi +mkForAllTys :: [TyVar] -> Type -> Type 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 +isForAllTy :: Type -> Bool +isForAllTy (NoteTy _ ty) = isForAllTy ty +isForAllTy (ForAllTy _ _) = True +isForAllTy other_ty = False -splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi) +splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTy_maybe ty = splitFAT_m ty + where + splitFAT_m (NoteTy _ ty) = splitFAT_m ty + splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p) + splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) + splitFAT_m _ = Nothing + +splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = 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 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 (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs + split orig_ty t tvs = (reverse tvs, orig_ty) + +dropForAlls :: Type -> Type +dropForAlls ty = snd (splitForAllTys ty) \end{code} +-- (mkPiType now in CoreUtils) + +Applying a for-all to its arguments. Lift usage annotation as required. \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 :: Type -> Type -> Type +applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty applyTy other arg = panic "applyTy" + +applyTys :: Type -> [Type] -> Type +applyTys orig_fun_ty arg_tys + = substTyWith tvs arg_tys ty + where + (tvs, ty) = split orig_fun_ty arg_tys + + split fun_ty [] = ([], fun_ty) + split (NoteTy _ fun_ty) args = split fun_ty args + split (SourceTy p) args = split (sourceTypeRep p) args + split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of + (tvs, ty) -> (tv:tvs, ty) + split other_ty args = panic "applyTys" + -- No show instance for Type yet \end{code} %************************************************************************ %* * -\subsection{Stuff to do with the source-language types} +\subsection{Source types} %* * %************************************************************************ -\begin{code} -type RhoType = Type -type TauType = Type -type ThetaType = [(Class, [Type])] -type SigmaType = Type -\end{code} - -@isTauTy@ tests for nested for-alls. - -\begin{code} -isTauTy :: GenType flexi -> 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 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 - -splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi) -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 ty ts = (reverse ts, orig_ty) -\end{code} +A "source type" is a type that is a separate type as far as the type checker is +concerned, but which has low-level representation as far as the back end is concerned. +Source types are always lifted. +The key function is sourceTypeRep which gives the representation of a source type: \begin{code} -mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) - -splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi) -splitSigmaTy ty = - (tyvars, theta, tau) - where - (tyvars,rho) = splitForAllTys ty - (theta,tau) = splitRhoTy rho +mkPredTy :: PredType -> Type +mkPredTy pred = SourceTy pred + +mkPredTys :: ThetaType -> [Type] +mkPredTys preds = map SourceTy preds + +sourceTypeRep :: SourceType -> Type +-- Convert a predicate to its "representation type"; +-- the type of evidence for that predicate, which is actually passed at runtime +sourceTypeRep (IParam _ ty) = ty +sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys + -- Note the mkTyConApp; the classTyCon might be a newtype! +sourceTypeRep (NType tc tys) = newTypeRep tc tys + -- ToDo: Consider caching this substitution in a NType + +isSourceTy :: Type -> Bool +isSourceTy (NoteTy _ ty) = isSourceTy ty +isSourceTy (SourceTy sty) = True +isSourceTy _ = False + + +splitNewType_maybe :: Type -> Maybe Type +-- Newtypes that are recursive are reprsented by TyConApp, just +-- as they always were. Occasionally we want to find their representation type. +-- NB: remember that in this module, non-recursive newtypes are transparent + +splitNewType_maybe ty + = case splitTyConApp_maybe ty of + Just (tc,tys) | isNewTyCon tc -> ASSERT( tys `lengthIs` tyConArity tc ) + -- The assert should hold because repType should + -- only be applied to *types* (of kind *) + Just (newTypeRep tc tys) + other -> Nothing + +-- A local helper function (not exported) +newTypeRep new_tycon tys = case newTyConRep new_tycon of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty \end{code} @@ -412,14 +586,29 @@ 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 (SourceTy _) = liftedTypeKind -- Predicates are always + -- represented by lifted types +typeKind (AppTy fun arg) = funResultTy (typeKind fun) + +typeKind (FunTy arg res) = fix_up (typeKind res) + where + fix_up (TyConApp tycon _) | tycon == typeCon + || tycon == openKindCon = liftedTypeKind + fix_up (NoteTy _ kind) = fix_up kind + fix_up kind = kind + -- The basic story is + -- typeKind (FunTy arg res) = typeKind res + -- But a function is lifted regardless of its result type + -- Hence the strange fix-up. + -- Note that 'res', being the result of a FunTy, can't have + -- a strange kind like (*->*). + +typeKind (ForAllTy tv ty) = typeKind ty \end{code} @@ -427,325 +616,283 @@ typeKind (ForAllTy _ _) = mkBoxedTypeKind Free variables of a type ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: GenType flexi -> GenTyVarSet flexi - -tyVarsOfType (TyVarTy tv) = unitTyVarSet tv +tyVarsOfType :: Type -> TyVarSet +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 - --- Find the free names of a type, including the type constructors and classes it mentions -namesOfType :: GenType flexi -> NameSet -namesOfType (TyVarTy tv) = unitNameSet (getName tv) -namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` - namesOfTypes tys -namesOfType (SynTy ty1 ty2) = namesOfType ty1 -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) - -namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys -\end{code} +tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs +tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty2 -- See note [Syn] below +tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res +tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg +tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar + +-- Note [Syn] +-- Consider +-- type T a = Int +-- What are the free tyvars of (T x)? Empty, of course! +-- Here's the example that Ralf Laemmel showed me: +-- foo :: (forall a. C u a -> C u a) -> u +-- mappend :: Monoid u => u -> u -> u +-- +-- bar :: Monoid u => u +-- bar = foo (\t -> t `mappend` t) +-- We have to generalise at the arg to f, and we don't +-- want to capture the constraint (Monad (C u a)) because +-- it appears to mention a. Pretty silly, but it was useful to him. + +tyVarsOfTypes :: [Type] -> TyVarSet +tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys + +tyVarsOfPred :: PredType -> TyVarSet +tyVarsOfPred = tyVarsOfSourceType -- Just a subtype + +tyVarsOfSourceType :: SourceType -> TyVarSet +tyVarsOfSourceType (IParam _ ty) = tyVarsOfType ty +tyVarsOfSourceType (ClassP _ tys) = tyVarsOfTypes tys +tyVarsOfSourceType (NType _ tys) = tyVarsOfTypes tys + +tyVarsOfTheta :: ThetaType -> TyVarSet +tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet + +-- Add a Note with the free tyvars to the top of the type +addFreeTyVars :: Type -> Type +addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty +addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty +\end{code} %************************************************************************ %* * -\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. +tidyTy tidies up a type for printing in an error message, or in +an interface file. -instantiateTy tenv ty - | isEmptyTyVarEnv tenv - = ty +It doesn't change the uniques at all, just the print names. - | otherwise - = go tenv ty +\begin{code} +tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVarBndr (tidy_env, subst) tyvar + = case tidyOccName tidy_env (getOccName name) of + (tidy', occ') -> -- New occname reqd + ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarName tyvar name' + name' = mkInternalName (getUnique name) occ' noSrcLoc + -- Note: make a *user* tyvar, so it printes nicely + -- Could extract src loc, but no need. + where + name = tyVarName tyvar + +tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv +-- Add the free tyvars to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) + +tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars + +tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +-- Treat a new tyvar as a binder, and give it a fresh tidy name +tidyOpenTyVar env@(tidy_env, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder + +tidyType :: TidyEnv -> Type -> Type +tidyType env@(tidy_env, subst) ty + = go 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) + 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 $! (go_note note)) $! (go ty) + go (SourceTy sty) = SourceTy (tidySourceType env sty) + go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) + go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) + go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) where - tenv' = case lookupTyVarEnv tenv tv of - Nothing -> tenv - Just _ -> delFromTyVarEnv tenv tv + (envp, tvp) = tidyTyVarBndr env tv --- 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 + go_note (SynNote ty) = SynNote $! (go ty) + go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars -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} +tidyTypes env tys = map (tidyType env) tys +tidyPred :: TidyEnv -> SourceType -> SourceType +tidyPred = tidySourceType -%************************************************************************ -%* * -\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. +tidySourceType :: TidyEnv -> SourceType -> SourceType +tidySourceType env (IParam n ty) = IParam n (tidyType env ty) +tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys) +tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys) +\end{code} - *primitive* iff it is a built-in type that can't be expressed - in Haskell -Currently, all primitive types are unpointed, but that's not necessarily -the case. (E.g. Int could be primitive.) +@tidyOpenType@ grabs the free type variables, tidies them +and then uses @tidyType@ to work over the type itself \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 +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType env' ty) + where + env' = tidyFreeTyVars env (tyVarsOfType ty) -typePrimRep :: Type -> PrimRep -typePrimRep ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> tyConPrimRep tc - other -> PtrRep +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys + +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty \end{code} + %************************************************************************ %* * -\subsection{Matching on types} +\subsection{Liftedness} %* * %************************************************************************ -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. +\begin{code} +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 (SourceTy _) = False -- All source types are lifted +isUnLiftedType other = False + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> isUnboxedTupleTyCon tc + other -> False + +-- Should only be applied to *types*; hence the assert +isAlgType :: Type -> Bool +isAlgType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + other -> False +\end{code} -@matchTys@ matches corresponding elements of a list of templates and -types. +@isStrictType@ computes whether an argument (or let RHS) should +be computed strictly or lazily, based only on its type. +Works just like isUnLiftedType, except that it has a special case +for dictionaries. Since it takes account of ClassP, you might think +this function should be in TcType, but isStrictType is used by DataCon, +which is below TcType in the hierarchy, so it's convenient to put it here. \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 +isStrictType (ForAllTy tv ty) = isStrictType ty +isStrictType (NoteTy _ ty) = isStrictType ty +isStrictType (TyConApp tc _) = isUnLiftedTyCon tc +isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) + -- We may be strict in dictionary types, but only if it + -- has more than one component. + -- [Being strict in a single-component dictionary risks + -- poking the dictionary component, which is wrong.] +isStrictType other = False \end{code} -@match@ is the main function. - \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) +isPrimitiveType :: Type -> Bool +-- Returns types that are opaque to Haskell. +-- Most of these are unlifted, but now that we interact with .NET, we +-- may have primtive (foreign-imported) types that are lifted +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + other -> False \end{code} + %************************************************************************ %* * -\subsection{Equality on types} +\subsection{Sequencing 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 Ord (GenType flexi) where - compare ty1 ty2 = cmpTy ty1 ty2 - -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 - - 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 +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 (SourceTy 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` () + +seqPred :: SourceType -> () +seqPred (ClassP c tys) = c `seq` seqTypes tys +seqPred (NType tc tys) = tc `seq` seqTypes tys +seqPred (IParam n ty) = n `seq` seqType ty \end{code} - %************************************************************************ %* * -\subsection{Grime} +\subsection{Equality on types} %* * %************************************************************************ +Comparison; don't use instances so that we know where it happens. +Look through newtypes but not usage types. +Note that eqType can respond 'False' for partial applications of newtypes. +Consider + newtype Parser m a = MkParser (Foogle m a) + +Does + Monad (Parser m) `eqType` Monad (Foogle m) + +Well, yes, but eqType won't see that they are the same. +I don't think this is harmful, but it's soemthing to watch out for. \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... +eqType t1 t2 = eq_ty emptyVarEnv t1 t2 +eqKind = eqType -- No worries about looking + +-- Look through Notes +eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2 +eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2 + +-- Look through SourceTy. This is where the looping danger comes from +eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2 +eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2) + +-- The rest is plain sailing +eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of + Just tv1a -> tv1a == tv2 + Nothing -> tv1 == tv2 +eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2) + | tv1 == tv2 = eq_ty (delVarEnv env tv1) t1 t2 + | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2 +eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) +eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) +eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2) +eq_ty env t1 t2 = False + +eq_tys env [] [] = True +eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2) +eq_tys env tys1 tys2 = False \end{code} +