X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=c7e5fa250901254842eab866d7a2e7d0edde5851;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=b52b884cb2c9da70e59151779ce5059581964797;hpb=d3e697b8d842bd43329d470f2bc424a6dcb88d89;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index b52b884..c7e5fa2 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,100 +1,104 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[Type]{Type - public interface} + \begin{code} module Type ( - GenType(..), Type, + -- re-exports from TypeRep + TyThing(..), Type, PredType(..), ThetaType, TyVarSubst, + funTyCon, - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, + -- Re-exports from Kind + module Kind, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, + -- Re-exports from TyCon + PrimRep(..), - mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - mkTyConApp, mkTyConTy, splitTyConApp_maybe, - splitAlgTyConApp_maybe, splitAlgTyConApp, - mkDictTy, splitDictTy_maybe, isDictTy, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - mkSynTy, isSynTy, + mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, + funResultTy, funArgTy, zipFunTys, isFunTy, - mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, + mkGenTyConApp, mkTyConApp, mkTyConTy, + tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, - TauType, RhoType, SigmaType, ThetaType, - isTauTy, - mkRhoTy, splitRhoTy, - mkSigmaTy, splitSigmaTy, + mkSynTy, - isUnpointedType, isUnboxedType, typePrimRep, + repType, typePrimRep, - matchTy, matchTys, + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + applyTy, applyTys, isForAllTy, dropForAlls, - tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + -- Source types + predTypeRep, mkPredTy, mkPredTys, - instantiateTy, instantiateTauTy, instantiateThetaTy, + -- Newtypes + splitRecNewType_maybe, - showTypeCategory - ) where + -- Lifting and boxity + isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType, + isStrictType, isStrictPred, -#include "HsVersions.h" + -- Free variables + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, + typeKind, addFreeTyVars, -import {-# SOURCE #-} Id ( Id ) + -- Tidying up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVarBndr, tidyFreeTyVars, + tidyOpenTyVar, tidyOpenTyVars, + tidyTopType, tidyPred, --- 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 - ) - --- others -import BasicTypes ( Unused ) -import Maybes ( maybeToBool, assocMaybe ) -import PrimRep ( PrimRep(..) ) -import Unique -- quite a few *Keys -import Util ( thenCmp, panic, assertPanic ) -\end{code} + -- Comparison + eqType, + -- Seq + seqType, seqTypes, + -- Pretty-printing + pprType, pprParendType, + pprPred, pprTheta, pprThetaArrow, pprClassPred + ) where -%************************************************************************ -%* * -\subsection{The data type} -%* * -%************************************************************************ - - -\begin{code} -type Type = GenType Unused -- Used after typechecker +#include "HsVersions.h" -data GenType flexi -- Parameterised over the "flexi" part of a type variable - = TyVarTy (GenTyVar flexi) +-- We import the representation and primitive functions from TypeRep. +-- Many things are reexported, but not the representation! - | AppTy - (GenType flexi) -- Function is *not* a TyConApp - (GenType flexi) +import TypeRep - | TyConApp -- Application of a TyCon - TyCon -- *Invariant* saturated appliations of FunTyCon and - -- synonyms have their own constructors, below. - [GenType flexi] -- Might not be saturated. +-- Other imports: - | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2] - (GenType flexi) - (GenType flexi) +import {-# SOURCE #-} Subst ( substTyWith ) - | SynTy -- Saturated application of a type synonym - (GenType flexi) -- The unexpanded version; always a TyConTy - (GenType flexi) -- The expanded version +-- friends: +import Kind +import Var ( 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, newTyConRhs, + isAlgTyCon, isSynTyCon, tyConArity, + tyConKind, getSynTyConDefn, PrimRep(..), tyConPrimRep, + ) - | ForAllTy - (GenTyVar flexi) - (GenType flexi) -- TypeKind +-- others +import CmdLineOpts ( opt_DictsStrict ) +import SrcLoc ( noSrcLoc ) +import Unique ( Uniquable(..) ) +import Util ( mapAccumL, seqList, lengthIs, snocView ) +import Outputable +import UniqSet ( sizeUniqSet ) -- Should come via VarSet +import Maybe ( isJust ) \end{code} @@ -109,26 +113,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 msg (TyVarTy tv) = tv -getTyVar msg (SynTy _ t) = getTyVar msg t -getTyVar msg other = panic ("getTyVar: " ++ msg) +getTyVar :: String -> Type -> TyVar +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> 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 :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) -isTyVarTy :: GenType flexi -> Bool -isTyVarTy (TyVarTy tv) = True -isTyVarTy (SynTy _ ty) = isTyVarTy ty -isTyVarTy other = False +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe (PredTy p) = getTyVar_maybe (predTypeRep p) +getTyVar_maybe (NewTcApp tc tys) = getTyVar_maybe (newTypeRep tc tys) +getTyVar_maybe other = Nothing \end{code} @@ -140,43 +144,67 @@ 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 + = 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 (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2]) + 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 + = mk_app orig_ty1 where - mk_app (SynTy _ ty1) = mk_app ty1 + mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2) mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) + -- Use mkTyConApp in case tc is (->) 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 (PredTy p) = splitAppTy_maybe (predTypeRep p) +splitAppTy_maybe (NewTcApp tc tys) = splitAppTy_maybe (newTypeRep tc tys) +splitAppTy_maybe (TyConApp tc tys) = case snocView tys of + Nothing -> Nothing + Just (tys',ty') -> Just (mkGenTyConApp tc tys', ty') + -- mkGenTyConApp just in case the tc is a newtype + +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 (PredTy p) args = split orig_ty (predTypeRep p) args + split orig_ty (NewTcApp tc tc_args) args = split orig_ty (newTypeRep tc tc_args) args + split orig_ty (TyConApp tc tc_args) args = (mkGenTyConApp tc [], tc_args ++ args) + -- mkGenTyConApp just in case the tc is a newtype split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) - (TyConApp mkFunTyCon [], [ty1,ty2]) - split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) + (TyConApp funTyCon [], [ty1,ty2]) split orig_ty ty args = (orig_ty, args) \end{code} @@ -186,102 +214,114 @@ 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 (FunTy arg res) = Just (arg, res) -splitFunTy_maybe (SynTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe other = Nothing +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 (PredTy p) = splitFunTy (predTypeRep p) +splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys) +splitFunTy other = pprPanic "splitFunTy" (ppr other) +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 (predTypeRep p) +splitFunTy_maybe (NewTcApp tc tys) = splitFunTy_maybe (newTypeRep tc tys) +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 ty = (reverse args, orig_ty) + 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 (predTypeRep p) + split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys) + split args orig_ty ty = (reverse args, 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 (predTypeRep p) + split acc xs nty (NewTcApp tc tys) = split acc xs nty (newTypeRep tc tys) + split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) + +funResultTy :: Type -> Type +funResultTy (FunTy arg res) = res +funResultTy (NoteTy _ ty) = funResultTy ty +funResultTy (PredTy p) = funResultTy (predTypeRep p) +funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys) +funResultTy ty = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +funArgTy (FunTy arg res) = arg +funArgTy (NoteTy _ ty) = funArgTy ty +funArgTy (PredTy p) = funArgTy (predTypeRep p) +funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys) +funArgTy ty = pprPanic "funArgTy" (ppr ty) \end{code} - --------------------------------------------------------------------- TyConApp ~~~~~~~~ +@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy, +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 + = NewTcApp tycon tys | otherwise = ASSERT(not (isSynTyCon tycon)) TyConApp tycon tys -mkTyConTy :: TyCon -> GenType flexi -mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) - TyConApp tycon [] +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = mkTyConApp tycon [] -- splitTyConApp "looks through" synonyms, because they don't -- 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) -"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" (ppr 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 (PredTy p) = splitTyConApp_maybe (predTypeRep p) +splitTyConApp_maybe (NewTcApp tc tys) = splitTyConApp_maybe (newTypeRep tc tys) +splitTyConApp_maybe other = Nothing \end{code} @@ -290,15 +330,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 @@ -316,6 +370,48 @@ 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. + +\begin{code} +repType :: Type -> Type +-- Only applied to types of kind *; hence tycons are saturated +repType (ForAllTy _ ty) = repType ty +repType (NoteTy _ ty) = repType ty +repType (PredTy p) = repType (predTypeRep p) +repType (NewTcApp tc tys) = ASSERT( tys `lengthIs` tyConArity tc ) + repType (new_type_rep tc tys) +repType ty = ty + + +-- ToDo: this could be moved to the code generator, using splitTyConApp instead +-- of inspecting the type directly. +typePrimRep :: Type -> PrimRep +typePrimRep ty = case repType ty of + TyConApp tc _ -> tyConPrimRep tc + FunTy _ _ -> PtrRep + AppTy _ _ -> PtrRep -- See note below + TyVarTy _ -> PtrRep + other -> pprPanic "typePrimRep" (ppr ty) + -- Types of the form 'f a' must be of kind *, not *#, so + -- we are guaranteed that they are represented by pointers. + -- The reason is that f must have kind *->*, not *->*#, because + -- (we claim) there is no way to constrain f's kind any other + -- way. + +-- new_type_rep doesn't ask any questions: +-- it just expands newtype, whether recursive or not +new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) + case newTyConRep new_tycon of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty +\end{code} --------------------------------------------------------------------- @@ -323,92 +419,174 @@ 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 (PredTy p) = splitFAT_m (predTypeRep p) + splitFAT_m (NewTcApp tc tys) = splitFAT_m (newTypeRep tc tys) + 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 (PredTy p) tvs = split orig_ty (predTypeRep p) tvs + split orig_ty (NewTcApp tc tys) tvs = split orig_ty (newTypeRep tc tys) tvs + split orig_ty t tvs = (reverse tvs, orig_ty) + +dropForAlls :: Type -> Type +dropForAlls ty = snd (splitForAllTys ty) \end{code} +-- (mkPiType now in CoreUtils) + +applyTy, applyTys +~~~~~~~~~~~~~~~~~ +Instantiate a for-all type with one or more type arguments. +Used when we have a polymorphic function applied to type args: + f t1 t2 +Then we use (applyTys type-of-f [t1,t2]) to compute the type of +the expression. \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" - -applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi -applyTys fun_ty arg_tys - = go [] fun_ty arg_tys - 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" +applyTy :: Type -> Type -> Type +applyTy (PredTy p) arg = applyTy (predTypeRep p) arg +applyTy (NewTcApp tc tys) arg = applyTy (newTypeRep tc tys) 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 +-- This function is interesting because +-- a) the function may have more for-alls than there are args +-- b) less obviously, it may have fewer for-alls +-- For case (b) think of +-- applyTys (forall a.a) [forall b.b, Int] +-- This really can happen, via dressing up polymorphic types with newtype +-- clothing. Here's an example: +-- newtype R = R (forall a. a->a) +-- foo = case undefined :: R of +-- R f -> f () + +applyTys orig_fun_ty [] = orig_fun_ty +applyTys orig_fun_ty arg_tys + | n_tvs == n_args -- The vastly common case + = substTyWith tvs arg_tys rho_ty + | n_tvs > n_args -- Too many for-alls + = substTyWith (take n_args tvs) arg_tys + (mkForAllTys (drop n_args tvs) rho_ty) + | otherwise -- Too many type args + = ASSERT2( n_tvs > 0, ppr orig_fun_ty ) -- Zero case gives infnite loop! + applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty) + (drop n_tvs arg_tys) + where + (tvs, rho_ty) = splitForAllTys orig_fun_ty + n_tvs = length tvs + n_args = length arg_tys \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} +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. -@isTauTy@ tests for nested for-alls. +Source types are always lifted. -\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} +The key function is predTypeRep which gives the representation of a source type: \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) +mkPredTy :: PredType -> Type +mkPredTy pred = PredTy pred + +mkPredTys :: ThetaType -> [Type] +mkPredTys preds = map PredTy preds + +predTypeRep :: PredType -> Type +-- Convert a PredType to its "representation type"; +-- the post-type-checking type used by all the Core passes of GHC. +-- Unwraps only the outermost level; for example, the result might +-- be a NewTcApp; c.f. newTypeRep +predTypeRep (IParam _ ty) = ty +predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys + -- Result might be a NewTcApp, but the consumer will + -- look through that too if necessary \end{code} +%************************************************************************ +%* * + NewTypes +%* * +%************************************************************************ \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 +splitRecNewType_maybe :: Type -> Maybe Type +-- Newtypes are always represented by a NewTcApp +-- Sometimes we want to look through a recursive newtype, and that's what happens here +-- It only strips *one layer* off, so the caller will usually call itself recursively +-- Only applied to types of kind *, hence the newtype is always saturated +splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty +splitRecNewType_maybe (PredTy p) = splitRecNewType_maybe (predTypeRep p) +splitRecNewType_maybe (NewTcApp tc tys) + | isRecursiveTyCon tc + = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc ) + -- The assert should hold because splitRecNewType_maybe + -- should only be applied to *types* (of kind *) + Just (new_type_rhs tc tys) +splitRecNewType_maybe other = Nothing + +----------------------------- +newTypeRep :: TyCon -> [Type] -> Type +-- A local helper function (not exported) +-- Expands *the outermoset level of* a newtype application to +-- *either* a vanilla TyConApp (recursive newtype, or non-saturated) +-- *or* the newtype representation (otherwise), meaning the +-- type written in the RHS of the newtype decl, +-- which may itself be a newtype +-- +-- Example: newtype R = MkR S +-- newtype S = MkS T +-- newtype T = MkT (T -> T) +-- newTypeRep on R gives NewTcApp S +-- on S gives NewTcApp T +-- on T gives TyConApp T +-- +-- NB: the returned TyConApp is always deconstructed immediately by the +-- caller... a TyConApp with a newtype type constructor never lives +-- in an ordinary type +newTypeRep tc tys + | not (isRecursiveTyCon tc), -- Not recursive and saturated + tys `lengthIs` tyConArity tc -- treat as equivalent to expansion + = new_type_rhs tc tys + | otherwise + = TyConApp tc tys + -- ToDo: Consider caching this substitution in a NType + +-- new_type_rhs doesn't ask any questions: +-- it just expands newtype one level, whether recursive or not +new_type_rhs tc tys + = case newTyConRhs tc of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty \end{code} @@ -422,14 +600,17 @@ 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 -> kindFunResult k) (tyConKind tycon) tys +typeKind (NewTcApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys +typeKind (NoteTy _ ty) = typeKind ty +typeKind (PredTy _) = liftedTypeKind -- Predicates are always + -- represented by lifted types +typeKind (AppTy fun arg) = kindFunResult (typeKind fun) +typeKind (FunTy arg res) = liftedTypeKind +typeKind (ForAllTy tv ty) = typeKind ty \end{code} @@ -437,210 +618,236 @@ 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 (NewTcApp tycon tys) = tyVarsOfTypes tys +tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs +tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty2 -- See note [Syn] below +tyVarsOfType (PredTy sty) = tyVarsOfPred 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 (IParam _ ty) = tyVarsOfType ty +tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys + +tyVarsOfTheta :: ThetaType -> TyVarSet +tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) 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} %* * %************************************************************************ +tidyTy tidies up a type for printing in an error message, or in +an interface file. + +It doesn't change the uniques at all, just the print names. + \begin{code} -instantiateTy :: TyVarEnv (GenType flexi) -> GenType flexi -> GenType flexi -instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2 +tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVarBndr (tidy_env, subst) tyvar + = case tidyOccName tidy_env (getOccName name) of + (tidy', occ') -> ((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 (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 (NewTcApp tycon tys) = let args = map go tys + in args `seqList` NewTcApp tycon args + go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty) + go (PredTy sty) = PredTy (tidyPred 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 + (envp, tvp) = tidyTyVarBndr env tv + go_note (SynNote ty) = SynNote $! (go ty) + go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars --- 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. +tidyTypes env tys = map (tidyType env) tys -instantiateTy tenv ty - | isEmptyTyVarEnv tenv - = ty +tidyPred :: TidyEnv -> PredType -> PredType +tidyPred env (IParam n ty) = IParam n (tidyType env ty) +tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) +\end{code} - | 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 --- 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 +@tidyOpenType@ grabs the free type variables, tidies them +and then uses @tidyType@ to work over the type itself -instantiateTauTy tenv ty = go ty +\begin{code} +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType env' 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] + env' = tidyFreeTyVars env (tyVarsOfType ty) + +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 pointedness} +\subsection{Liftedness} %* * %************************************************************************ -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. +\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 (PredTy _) = False -- All source types are lifted +isUnLiftedType (NewTcApp tc tys) = isUnLiftedType (newTypeRep tc tys) +isUnLiftedType other = False + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> isUnboxedTupleTyCon tc + other -> False - *primitive* iff it is a built-in type that can't be expressed - in Haskell +-- 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} -Currently, all primitive types are unpointed, but that's not necessarily -the case. (E.g. Int could be primitive.) +@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} -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 +isStrictType (ForAllTy tv ty) = isStrictType ty +isStrictType (NoteTy _ ty) = isStrictType ty +isStrictType (TyConApp tc _) = isUnLiftedTyCon tc +isStrictType (NewTcApp tc tys) = isStrictType (newTypeRep tc tys) +isStrictType (PredTy pred) = isStrictPred pred +isStrictType other = False + +isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) +isStrictPred other = False + -- 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.] +\end{code} -typePrimRep :: Type -> PrimRep -typePrimRep ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> tyConPrimRep tc - other -> PtrRep +\begin{code} +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{Matching on types} +\subsection{Sequencing 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. - \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 +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 (NewTcApp 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 :: PredType -> () +seqPred (ClassP c tys) = c `seq` seqTypes tys +seqPred (IParam n ty) = n `seq` seqType ty \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) -\end{code} %************************************************************************ %* * @@ -648,114 +855,66 @@ match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k) %* * %************************************************************************ -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 +Comparison; don't use instances so that we know where it happens. +Look through newtypes but not usage types. - 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} +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. -%************************************************************************ -%* * -\subsection{Grime} -%* * -%************************************************************************ +\begin{code} +eqType t1 t2 = eq_ty emptyVarEnv t1 t2 +-- 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 PredTy and NewTcApp. This is where the looping danger comes from. +-- We don't bother to check for the PredType/PredType case, no good reason +-- Hmm: maybe there is a good reason: see the notes below about newtypes +eq_ty env (PredTy sty1) t2 = eq_ty env (predTypeRep sty1) t2 +eq_ty env t1 (PredTy sty2) = eq_ty env t1 (predTypeRep sty2) -\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... +-- NB: we *cannot* short-cut the newtype comparison thus: +-- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) +-- | (tc1 == tc2) = (eq_tys env tys1 tys2) +-- +-- Consider: +-- newtype T a = MkT [a] +-- newtype Foo m = MkFoo (forall a. m a -> Int) +-- w1 :: Foo [] +-- w1 = ... +-- +-- w2 :: Foo T +-- w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) +-- +-- We end up with w2 = w1; so we need that Foo T = Foo [] +-- but we can only expand saturated newtypes, so just comparing +-- T with [] won't do. + +eq_ty env (NewTcApp tc1 tys1) t2 = eq_ty env (newTypeRep tc1 tys1) t2 +eq_ty env t1 (NewTcApp tc2 tys2) = eq_ty env t1 (newTypeRep tc2 tys2) + +-- 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} +