X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=c0e20d204736c25b888022f798888e1464354919;hb=18976e614fd90a8d81ced2c3e9cd8e38d72a1f40;hp=a237cd4053e2c91410962cc89d52bb77154456ce;hpb=ba16832735be750fbf6bd7a6c59d87e0cd176240;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index a237cd4..c0e20d2 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,875 +1,940 @@ \begin{code} -#include "HsVersions.h" - module Type ( - GenType(..), SYN_IE(Type), SYN_IE(TauType), - mkTyVarTy, mkTyVarTys, - getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, - mkFunTy, mkFunTys, - splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking, - getFunTy_maybe, getFunTyExpandingDicts_maybe, - mkTyConTy, getTyCon_maybe, applyTyCon, - mkSynTy, - mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, - splitForAllTy, splitForAllTyExpandingDicts, - mkForAllUsageTy, getForAllUsageTy, - applyTy, specialiseTy, -#ifdef DEBUG - expandTy, -- only let out for debugging (ToDo: rm?) -#endif - isPrimType, isUnboxedType, typePrimRep, - - SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType), - mkDictTy, - mkRhoTy, splitRhoTy, mkTheta, isDictTy, - mkSigmaTy, splitSigmaTy, + Type(..), TyNote(..), -- Representation visible to friends + Kind, TyVarSubst, + + superKind, superBoxity, -- :: SuperKind + + boxedKind, -- :: Kind :: BX + anyBoxKind, -- :: Kind :: BX + typeCon, -- :: KindCon :: BX -> KX + anyBoxCon, -- :: KindCon :: BX + + boxedTypeKind, unboxedTypeKind, openTypeKind, -- Kind :: superKind + + mkArrowKind, mkArrowKinds, hasMoreBoxityInfo, + + funTyCon, - maybeAppTyCon, getAppTyCon, - maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon, - maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts, - getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts, - maybeBoxedPrimType, + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - instantiateTy, instantiateTauTy, instantiateUsage, - applyTypeEnvToTy, + mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, funResultTy, + zipFunTys, + mkTyConApp, mkTyConTy, splitTyConApp_maybe, + splitAlgTyConApp_maybe, splitAlgTyConApp, + mkDictTy, splitDictTy_maybe, isDictTy, + + mkSynTy, isSynTy, deNoteType, + + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + applyTy, applyTys, isForAllTy, + mkPiType, + + TauType, RhoType, SigmaType, ThetaType, isTauTy, + mkRhoTy, splitRhoTy, + mkSigmaTy, splitSigmaTy, + -- Lifting and boxity + isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, + typePrimRep, + + -- Free variables tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, - showTypeCategory + addFreeTyVars, + + -- Substitution + substTy, substTheta, fullSubstTy, substTyVar, + substTopTy, substTopTheta, + + -- Tidying up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVar, tidyTyVars, + tidyTopType ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -- for paranoia checking -IMPORT_DELOOPER(TyLoop) ---IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -#else -import {-# SOURCE #-} Id ( Id, dataConArgTys ) -import {-# SOURCE #-} TysPrim ( voidTy ) -import {-# SOURCE #-} TysWiredIn ( tupleTyCon ) -#endif +#include "HsVersions.h" + +import {-# SOURCE #-} DataCon( DataCon ) +import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages -- friends: -import Class ( classDictArgTys, GenClass{-instances-}, SYN_IE(Class) ) -import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind ) -import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon, - isPrimTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, - tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) -import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), - emptyTyVarSet, unionTyVarSets, minusTyVarSet, - unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv, - addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) ) -import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv), - nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, - eqUsage ) - -import Name ( NamedThing(..), - NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet +import Var ( Id, TyVar, IdOrTyVar, + tyVarKind, tyVarName, isId, idType, setTyVarName ) +import VarEnv +import VarSet --- others -import Maybes ( maybeToBool, assocMaybe ) -import PrimRep ( PrimRep(..) ) -import Unique -- quite a few *Keys -import Util ( thenCmp, zipEqual, assoc, - panic, panic#, assertPanic, pprPanic, - Ord3(..){-instances-} +import Name ( NamedThing(..), Provenance(..), ExportFlag(..), + mkWiredInTyConName, mkGlobalName, mkLocalName, mkKindOccFS, tcName, + tidyOccName, TidyOccEnv + ) +import NameSet +import Class ( classTyCon, Class ) +import TyCon ( TyCon, KindCon, + mkFunTyCon, mkKindCon, mkSuperKindCon, + matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, + isFunTyCon, isDataTyCon, + isAlgTyCon, isSynTyCon, tyConArity, + tyConKind, tyConDataCons, getSynTyConDefn, + tyConPrimRep, tyConClass_maybe ) --- ToDo:rm all these ---import {-mumble-} --- Pretty ---import {-mumble-} --- PprStyle ---import {-mumble-} --- PprType --(pprType ) ---import PprEnv + +-- others +import BasicTypes ( Unused ) +import SrcLoc ( mkBuiltinSrcLoc, noSrcLoc ) +import PrelMods ( pREL_GHC ) +import Maybes ( maybeToBool ) +import PrimRep ( PrimRep(..), isFollowableRep ) +import Unique -- quite a few *Keys +import Util ( thenCmp, mapAccumL ) +import Outputable + \end{code} -Data types -~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Type Classifications} +%* * +%************************************************************************ + +A type is + + *unboxed* iff its representation is other than a pointer + Unboxed types cannot instantiate a type variable + Unboxed types are always unlifted. + + *lifted* A type is lifted iff it has bottom as an element. + Closures always have lifted types: i.e. any + let-bound identifier in Core must have a lifted + type. Operationally, a lifted object is one that + can be entered. + (NOTE: previously "pointed"). + + *algebraic* A type with one or more constructors, whether declared + with "data" or "newtype". + An algebraic type is one that can be deconstructed + with a case expression. + + *NOT* the same as lifted types, because we also + include unboxed tuples in this classification. + + *data* A type declared with "data". Also boxed tuples. + + *primitive* iff it is a built-in type that can't be expressed + in Haskell. + +Currently, all primitive types are unlifted, but that's not necessarily +the case. (E.g. Int could be primitive.) + +Some primitive types are unboxed, such as Int#, whereas some are boxed +but unlifted (such as ByteArray#). The only primitive types that we +classify as algebraic are the unboxed tuples. + +examples of type classifications: + +Type primitive boxed lifted algebraic +----------------------------------------------------------------------------- +Int#, Yes No No No +ByteArray# Yes Yes No No +(# a, b #) Yes No No Yes +( a, b ) No Yes Yes Yes +[a] No Yes Yes Yes + +%************************************************************************ +%* * +\subsection{The data type} +%* * +%************************************************************************ + \begin{code} -type Type = GenType TyVar UVar -- Used after typechecker +type SuperKind = Type +type Kind = Type -data GenType tyvar uvar -- Parameterised over type and usage variables - = TyVarTy tyvar +type TyVarSubst = TyVarEnv Type + +data Type + = TyVarTy TyVar | AppTy - (GenType tyvar uvar) - (GenType tyvar uvar) + Type -- Function is *not* a TyConApp + Type + + | TyConApp -- Application of a TyCon + TyCon -- *Invariant* saturated appliations of FunTyCon and + -- synonyms have their own constructors, below. + [Type] -- Might not be saturated. - | TyConTy -- Constants of a specified kind - TyCon -- Must *not* be a SynTyCon - (GenUsage uvar) -- Usage gives uvar of the full application, - -- iff the full application is of kind Type - -- c.f. the Usage field in TyVars + | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2] + Type + Type - | SynTy -- Synonyms must be saturated, and contain their expansion - TyCon -- Must be a SynTyCon - [GenType tyvar uvar] - (GenType tyvar uvar) -- Expansion! + | NoteTy -- Saturated application of a type synonym + TyNote + Type -- The expanded version | ForAllTy - tyvar - (GenType tyvar uvar) -- TypeKind - - | ForAllUsageTy - uvar -- Quantify over this - [uvar] -- Bounds; the quantified var must be - -- less than or equal to all these - (GenType tyvar uvar) - - -- Two special cases that save a *lot* of administrative - -- overhead: - - | FunTy -- BoxedTypeKind - (GenType tyvar uvar) -- Both args are of TypeKind - (GenType tyvar uvar) - (GenUsage uvar) - - | DictTy -- TypeKind - Class -- Class - (GenType tyvar uvar) -- Arg has kind TypeKind - (GenUsage uvar) + TyVar + Type -- TypeKind + +data TyNote + = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp + | FTVNote TyVarSet -- The free type variables of the noted expression +\end{code} + + +%************************************************************************ +%* * +\subsection{Kinds} +%* * +%************************************************************************ + +Kinds +~~~~~ +k::K = Type bx + | k -> k + | kv + +kv :: KX is a kind variable + +Type :: BX -> KX + +bx::BX = Boxed + | Unboxed + | AnyBox -- Used *only* for special built-in things + -- like error :: forall (a::*?). String -> a + -- Here, the 'a' can be instantiated to a boxed or + -- unboxed type. + | bv + +bxv :: BX is a boxity variable + +sk = KX -- A kind + | BX -- A boxity + | sk -> sk -- In ptic (BX -> KX) + +\begin{code} +mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str) + (LocalDef mkBuiltinSrcLoc NotExported) + -- mk_kind_name is a bit of a hack + -- The LocalDef means that we print the name without + -- a qualifier, which is what we want for these kinds. + -- It's used for both Kinds and Boxities \end{code} +Define KX, BX. + \begin{code} -type RhoType = Type -type TauType = Type -type ThetaType = [(Class, Type)] -type SigmaType = Type +superKind :: SuperKind -- KX, the type of all kinds +superKindName = mk_kind_name kindConKey SLIT("KX") +superKind = TyConApp (mkSuperKindCon superKindName) [] + +superBoxity :: SuperKind -- BX, the type of all boxities +superBoxityName = mk_kind_name boxityConKey SLIT("BX") +superBoxity = TyConApp (mkSuperKindCon superBoxityName) [] \end{code} +Define Boxed, Unboxed, AnyBox -Notes on type synonyms -~~~~~~~~~~~~~~~~~~~~~~ -The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try -to return type synonyms whereever possible. Thus +\begin{code} +boxedKind, unboxedKind, anyBoxKind :: Kind -- Of superkind superBoxity - type Foo a = a -> a +boxedConName = mk_kind_name boxedConKey SLIT("*") +boxedKind = TyConApp (mkKindCon boxedConName superBoxity) [] -we want - splitFunTys (a -> Foo a) = ([a], Foo a) -not ([a], a -> a) +unboxedConName = mk_kind_name unboxedConKey SLIT("#") +unboxedKind = TyConApp (mkKindCon unboxedConName superBoxity) [] -The reason is that we then get better (shorter) type signatures in -interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. +anyBoxConName = mk_kind_name anyBoxConKey SLIT("?") +anyBoxCon = mkKindCon anyBoxConName superBoxity -- A kind of wild card +anyBoxKind = TyConApp anyBoxCon [] +\end{code} + +Define Type +\begin{code} +typeCon :: KindCon +typeConName = mk_kind_name typeConKey SLIT("Type") +typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind) +\end{code} -Expand abbreviations -~~~~~~~~~~~~~~~~~~~~ -Removes just the top level of any abbreviations. +Define (Type Boxed), (Type Unboxed), (Type AnyBox) \begin{code} -expandTy :: Type -> Type -- Restricted to Type due to Dict expansion +boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind +boxedTypeKind = TyConApp typeCon [boxedKind] +unboxedTypeKind = TyConApp typeCon [unboxedKind] +openTypeKind = TyConApp typeCon [anyBoxKind] -expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2 -expandTy (SynTy _ _ t) = expandTy t -expandTy (DictTy clas ty u) - = case all_arg_tys of +mkArrowKind :: Kind -> Kind -> Kind +mkArrowKind k1 k2 = k1 `FunTy` k2 - [] -> voidTy -- Empty dictionary represented by Void +mkArrowKinds :: [Kind] -> Kind -> Kind +mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds +\end{code} - [arg_ty] -> expandTy arg_ty -- just the itself +\begin{code} +hasMoreBoxityInfo :: Kind -> Kind -> Bool +hasMoreBoxityInfo k1 k2 + | k2 == openTypeKind = ASSERT( is_type_kind k1) True + | otherwise = k1 == k2 + where + -- Returns true for things of form (Type x) + is_type_kind k = case splitTyConApp_maybe k of + Just (tc,[_]) -> tc == typeCon + Nothing -> False +\end{code} - -- The extra expandTy is to make sure that - -- the result isn't still a dict, which it might be - -- if the original guy was a dict with one superdict and - -- no methods! - other -> ASSERT(not (null all_arg_tys)) - foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys +%************************************************************************ +%* * +\subsection{Wired-in type constructors +%* * +%************************************************************************ - -- A tuple of 'em - -- Note: length of all_arg_tys can be 0 if the class is - -- CCallable, CReturnable (and anything else - -- *really weird* that the user writes). - where - all_arg_tys = classDictArgTys clas ty +We define a few wired-in type constructors here to avoid module knots -expandTy ty = ty +\begin{code} +funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon +funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind) \end{code} -Simple construction and analysis functions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +%************************************************************************ +%* * +\subsection{Constructor-specific functions} +%* * +%************************************************************************ + + +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ \begin{code} -mkTyVarTy :: t -> GenType t u -mkTyVarTys :: [t] -> [GenType t y] +mkTyVarTy :: TyVar -> Type mkTyVarTy = TyVarTy + +mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy -getTyVar :: String -> GenType t u -> t -getTyVar msg (TyVarTy tv) = tv -getTyVar msg (SynTy _ _ t) = getTyVar msg t -getTyVar msg other = panic ("getTyVar: " ++ msg) +getTyVar :: String -> Type -> TyVar +getTyVar msg (TyVarTy tv) = tv +getTyVar msg (NoteTy _ t) = getTyVar msg t +getTyVar msg other = panic ("getTyVar: " ++ msg) -getTyVar_maybe :: GenType t u -> Maybe t -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t -getTyVar_maybe other = Nothing +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe other = Nothing -isTyVarTy :: GenType t u -> Bool +isTyVarTy :: Type -> Bool isTyVarTy (TyVarTy tv) = True -isTyVarTy (SynTy _ _ t) = isTyVarTy t -isTyVarTy other = False +isTyVarTy (NoteTy _ ty) = isTyVarTy ty +isTyVarTy other = False \end{code} -\begin{code} -mkAppTy = AppTy - -mkAppTys :: GenType t u -> [GenType t u] -> GenType t u -mkAppTys t ts = foldl AppTy t ts -splitAppTy :: GenType t u -> (GenType t u, GenType t u) -splitAppTy (AppTy t arg) = (t,arg) -splitAppTy (SynTy _ _ t) = splitAppTy t -splitAppTy other = panic "splitAppTy" +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. -splitAppTys :: GenType t u -> (GenType t u, [GenType t u]) -splitAppTys t = go t [] +\begin{code} +mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1 + where + mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) + mk_app ty1 = AppTy orig_ty1 orig_ty2 + +mkAppTys :: Type -> [Type] -> Type +mkAppTys orig_ty1 [] = orig_ty1 + -- This check for an empty list of type arguments + -- avoids the needless of a type synonym constructor. + -- For example: mkAppTys Rational [] + -- returns to (Ratio Integer), which has needlessly lost + -- the Rational part. +mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1 where - go (AppTy t arg) ts = go t (arg:ts) - go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts) - go (SynTy _ _ t) ts = go t ts - go t ts = (t,ts) + 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_maybe :: Type -> Maybe (Type, Type) +splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) +splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty +splitAppTy_maybe (TyConApp tc []) = Nothing +splitAppTy_maybe (TyConApp tc tys) = split tys [] + where + split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) + split (ty:tys) acc = split tys (ty:acc) + +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 (NoteTy _ ty) args = split orig_ty ty args + split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) + (TyConApp funTyCon [], [ty1,ty2]) + split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) + split orig_ty ty args = (orig_ty, args) \end{code} + +--------------------------------------------------------------------- + FunTy + ~~~~~ + \begin{code} --- NB mkFunTy, mkFunTys puts in Omega usages, for now at least -mkFunTy arg res = FunTy arg res usageOmega - -mkFunTys :: [GenType t u] -> GenType t u -> GenType t u -mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts - - -- getFunTy_maybe and splitFunTy *must* have the general type given, which - -- means they *can't* do the DictTy jiggery-pokery that - -- *is* sometimes required. Hence we also have the ExpandingDicts variants - -- The relationship between these - -- two functions is like that between eqTy and eqSimpleTy. - -- ToDo: NUKE when we do dicts via newtype - -getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u) -getFunTy_maybe t - = go t t - where - -- See notes on type synonyms above - go syn_t (FunTy arg result _) = Just (arg,result) - go syn_t (AppTy (AppTy (TyConTy tycon _) arg) res) - | isFunTyCon tycon = Just (arg, res) - go syn_t (SynTy _ _ t) = go syn_t t - go syn_t other = Nothing - -getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons - -> Type - -> Maybe (Type, Type) - -getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result) -getFunTyExpandingDicts_maybe peek - (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) -getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t -getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty) - -getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty - -- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking - - -{- This is a truly disgusting bit of code. - It's used by the code generator to look at the rep of a newtype. - The code gen will have thrown away coercions involving that newtype, so - this is the other side of the coin. - Gruesome in the extreme. --} - -getFunTyExpandingDicts_maybe peek other - | not peek = Nothing -- that was easy - | otherwise - = case (maybeAppTyCon other) of - Just (tc, arg_tys) - | isNewTyCon tc && not (null data_cons) - -> getFunTyExpandingDicts_maybe peek inside_ty - where - data_cons = tyConDataCons tc - [the_con] = data_cons - [inside_ty] = dataConArgTys the_con arg_tys - - other -> Nothing - - -splitFunTy :: GenType t u -> ([GenType t u], GenType t u) -splitFunTyExpandingDicts :: Type -> ([Type], Type) -splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type) - -splitFunTy t = split_fun_ty getFunTy_maybe t -splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t -splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t - -- This "peeking" stuff is used only by the code generator. - -- It's interested in the representation type of things, ignoring: - -- newtype Why??? Nuked SLPJ May 97. We may not know the - -- rep of an abstractly imported newtype - -- foralls - -- expanding dictionary reps - -- synonyms, of course - -split_fun_ty get t = go t [] +mkFunTy :: Type -> Type -> Type +mkFunTy arg res = FunTy arg res + +mkFunTys :: [Type] -> Type -> Type +mkFunTys tys ty = foldr FunTy ty tys + +splitFunTy_maybe :: Type -> Maybe (Type, Type) +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe other = Nothing + + +splitFunTys :: Type -> ([Type], Type) +splitFunTys ty = split [] ty ty + where + split args orig_ty (FunTy arg res) = split (arg:args) res res + split args orig_ty (NoteTy _ ty) = split args orig_ty ty + split args orig_ty 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 - go t ts = case (get t) of - Just (arg,res) -> go res (arg:ts) - Nothing -> (reverse ts, t) + split acc [] nty ty = (reverse acc, nty) + split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res + split acc xs nty (NoteTy _ ty) = split acc xs nty ty + split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) + +funResultTy :: Type -> Type +funResultTy (FunTy arg res) = res +funResultTy (NoteTy _ ty) = funResultTy ty +funResultTy ty = pprPanic "funResultTy" (pprType ty) \end{code} -\begin{code} --- NB applyTyCon puts in usageOmega, for now at least -mkTyConTy tycon - = ASSERT(not (isSynTyCon tycon)) - TyConTy tycon usageOmega -applyTyCon :: TyCon -> [GenType t u] -> GenType t u -applyTyCon tycon tys - = ASSERT (not (isSynTyCon tycon)) - --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $ - foldl AppTy (TyConTy tycon usageOmega) tys -getTyCon_maybe :: GenType t u -> Maybe TyCon +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ + +\begin{code} +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon && length tys == 2 + = case tys of + (ty1:ty2:_) -> FunTy ty1 ty2 -getTyCon_maybe (TyConTy tycon _) = Just tycon -getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t -getTyCon_maybe other_ty = Nothing + | otherwise + = ASSERT(not (isSynTyCon tycon)) + TyConApp tycon tys + +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) + TyConApp 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 :: 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 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 :: Type -> Maybe (TyCon, [Type], [DataCon]) +splitAlgTyConApp_maybe (TyConApp tc tys) + | isAlgTyCon tc && + tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) +splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty +splitAlgTyConApp_maybe other = Nothing + +splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon]) + -- Here the "algebraic" property is an *assertion* +splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys ) + (tc, tys, tyConDataCons tc) +splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty \end{code} +"Dictionary" types are just ordinary data types, but you can +tell from the type constructor whether it's a dictionary or not. + \begin{code} -specialiseTy :: Type -- The type of the Id of which the SpecId - -- is a specialised version - -> [Maybe Type] -- The types at which it is specialised - -> Int -- Number of leading dictionary args to ignore - -> Type - -specialiseTy main_ty maybe_tys dicts_to_ignore - = --false:ASSERT(isTauTy tau) TauType?? - mkSigmaTy remaining_tyvars - (instantiateThetaTy inst_env remaining_theta) - (instantiateTauTy inst_env tau) +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = TyConApp (classTyCon clas) tys + +splitDictTy_maybe :: Type -> Maybe (Class, [Type]) +splitDictTy_maybe (TyConApp tc tys) + | maybeToBool maybe_class + && tyConArity tc == length tys = Just (clas, tys) where - (tyvars, theta, tau) = splitSigmaTy main_ty -- A prefix of, but usually all, - -- the theta is discarded! - remaining_theta = drop dicts_to_ignore theta - tyvars_and_maybe_tys = tyvars `zip` maybe_tys - remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys] - inst_env = [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys] + maybe_class = tyConClass_maybe tc + Just clas = maybe_class + +splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty +splitDictTy_maybe other = Nothing + +isDictTy :: Type -> Bool + -- This version is slightly more efficient than (maybeToBool . splitDictTy) +isDictTy (TyConApp tc tys) + | maybeToBool (tyConClass_maybe tc) + && tyConArity tc == length tys + = True +isDictTy (NoteTy _ ty) = isDictTy ty +isDictTy other = False \end{code} + +--------------------------------------------------------------------- + SynTy + ~~~~~ + \begin{code} mkSynTy syn_tycon tys = ASSERT(isSynTyCon syn_tycon) - SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body) + NoteTy (SynNote (TyConApp syn_tycon tys)) + (substTopTy (zipVarEnv tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon -\end{code} -Tau stuff -~~~~~~~~~ -\begin{code} -isTauTy :: GenType t u -> Bool -isTauTy (TyVarTy v) = True -isTauTy (TyConTy _ _) = True -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b _) = isTauTy a && isTauTy b -isTauTy (SynTy _ _ ty) = isTauTy ty -isTauTy other = False +isSynTy (NoteTy (SynNote _) _) = True +isSynTy other = False + +deNoteType :: Type -> Type + -- Sorry for the cute name +deNoteType ty@(TyVarTy tyvar) = ty +deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) +deNoteType (NoteTy _ ty) = deNoteType ty +deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) +deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) +deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) \end{code} -Rho stuff -~~~~~~~~~ -NB mkRhoTy and mkDictTy put in usageOmega, for now at least +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms whereever possible. Thus -\begin{code} -mkDictTy :: Class -> GenType t u -> GenType t u -mkDictTy clas ty = DictTy clas ty usageOmega + type Foo a = a -> a -mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u -mkRhoTy theta ty = - foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) -splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u) -splitRhoTy t = - go t t [] - where - -- See notes on type synonyms above - go syn_t (FunTy (DictTy c t _) r _) ts = go r r ((c,t):ts) - go syn_t (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts - | isFunTyCon tycon - = go r r ((c,t):ts) - go syn_t (SynTy _ _ t) ts = go syn_t t ts - go syn_t t ts = (reverse ts, syn_t) - - -mkTheta :: [Type] -> ThetaType - -- recover a ThetaType from the types of some dictionaries -mkTheta dict_tys - = map cvt dict_tys - where - cvt (DictTy clas ty _) = (clas, ty) - cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other) +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. -isDictTy (DictTy _ _ _) = True -isDictTy (SynTy _ _ t) = isDictTy t -isDictTy _ = False -\end{code} -Forall stuff -~~~~~~~~~~~~ + +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ + \begin{code} mkForAllTy = ForAllTy -mkForAllTys :: [t] -> GenType t u -> GenType t u +mkForAllTys :: [TyVar] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u) -getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t -getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t) -getForAllTy_maybe _ = Nothing - -getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type) -getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t -getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t) -getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty) -getForAllTyExpandingDicts_maybe _ = Nothing - -splitForAllTy :: GenType t u -> ([t], GenType t u) -splitForAllTy t = go t t [] - where - -- See notes on type synonyms above - go syn_t (ForAllTy tv t) tvs = go t t (tv:tvs) - go syn_t (SynTy _ _ t) tvs = go syn_t t tvs - go syn_t t tvs = (reverse tvs, syn_t) - -splitForAllTyExpandingDicts :: Type -> ([TyVar], Type) -splitForAllTyExpandingDicts ty - = go [] ty - where - go tvs ty = case getForAllTyExpandingDicts_maybe ty of - Just (tv, ty') -> go (tv:tvs) ty' - Nothing -> (reverse tvs, ty) +splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTy_maybe (NoteTy _ 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 tyvar ty) = True +isForAllTy _ = False + +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 (NoteTy _ ty) tvs = split orig_ty ty tvs + split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} -\begin{code} -mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u -mkForAllUsageTy = ForAllUsageTy +@mkPiType@ makes a (->) type or a forall type, depending on whether +it is given a type variable or a term variable. -getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u) -getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t) -getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t -getForAllUsageTy _ = Nothing +\begin{code} +mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work... +mkPiType v ty | isId v = mkFunTy (idType v) ty + | otherwise = ForAllTy v ty \end{code} -Applied tycons (includes FunTyCons) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -maybeAppTyCon - :: GenType tyvar uvar - -> Maybe (TyCon, -- the type constructor - [GenType tyvar uvar]) -- types to which it is applied - -maybeAppTyCon ty - = case (getTyCon_maybe app_ty) of - Nothing -> Nothing - Just tycon -> Just (tycon, arg_tys) - where - (app_ty, arg_tys) = splitAppTys ty +applyTy :: Type -> Type -> Type +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = substTy (mkVarEnv [(tv,arg)]) ty +applyTy other arg = panic "applyTy" + +applyTys :: Type -> [Type] -> Type +applyTys fun_ty arg_tys + = go [] fun_ty arg_tys + where + go env ty [] = substTy (mkVarEnv env) ty + go env (NoteTy _ fun) args = go env fun args + go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args + go env other args = panic "applyTys" +\end{code} -getAppTyCon - :: GenType tyvar uvar - -> (TyCon, -- the type constructor - [GenType tyvar uvar]) -- types to which it is applied +%************************************************************************ +%* * +\subsection{Stuff to do with the source-language types} +%* * +%************************************************************************ -getAppTyCon ty - = case maybeAppTyCon ty of - Just stuff -> stuff -#ifdef DEBUG - Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty) -#endif +\begin{code} +type RhoType = Type +type TauType = Type +type ThetaType = [(Class, [Type])] +type SigmaType = Type \end{code} -Applied data tycons (give back constrs) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nota Bene: all these functions suceed for @newtype@ applications too! +@isTauTy@ tests for nested for-alls. \begin{code} -maybeAppDataTyCon - :: GenType (GenTyVar any) uvar - -> Maybe (TyCon, -- the type constructor - [GenType (GenTyVar any) uvar], -- types to which it is applied - [Id]) -- its family of data-constructors -maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts - :: Type -> Maybe (TyCon, [Type], [Id]) - -maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty -maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty -maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty - - -maybe_app_data_tycon expand ty - = let - expanded_ty = expand ty - (app_ty, arg_tys) = splitAppTys expanded_ty - in - case (getTyCon_maybe app_ty) of - Just tycon | isAlgTyCon tycon && -- NB "Alg"; succeeds for newtype too - notArrowKind (typeKind expanded_ty) - -- Must be saturated for ty to be a data type - -> Just (tycon, arg_tys, tyConDataCons tycon) - - other -> Nothing - -getAppDataTyCon, getAppSpecDataTyCon - :: GenType (GenTyVar any) uvar - -> (TyCon, -- the type constructor - [GenType (GenTyVar any) uvar], -- types to which it is applied - [Id]) -- its family of data-constructors -getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts - :: Type -> (TyCon, [Type], [Id]) - -getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty -getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $ - get_app_data_tycon maybeAppDataTyConExpandingDicts ty - --- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo) -getAppSpecDataTyCon = getAppDataTyCon -getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts - -get_app_data_tycon maybe ty - = case maybe ty of - Just stuff -> stuff -#ifdef DEBUG - Nothing -> panic "Type.getAppDataTyCon"-- (pprGenType PprShowAll ty) -#endif - - -maybeBoxedPrimType :: Type -> Maybe (Id, Type) - -maybeBoxedPrimType ty - = case (maybeAppDataTyCon ty) of -- Data type, - Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor - -> case (dataConArgTys data_con tys_applied) of - [data_con_arg_ty] -- Applied to exactly one type, - | isPrimType data_con_arg_ty -- which is primitive - -> Just (data_con, data_con_arg_ty) - other_cases -> Nothing - other_cases -> Nothing +isTauTy :: Type -> Bool +isTauTy (TyVarTy v) = True +isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b +isTauTy (NoteTy _ ty) = isTauTy ty +isTauTy other = False \end{code} \begin{code} -splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u) +mkRhoTy :: [(Class, [Type])] -> Type -> Type +mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta + +splitRhoTy :: Type -> ([(Class, [Type])], Type) +splitRhoTy ty = split ty ty [] + where + split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of + Just pair -> split res res (pair:ts) + Nothing -> (reverse ts, orig_ty) + split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts + split orig_ty ty ts = (reverse ts, orig_ty) +\end{code} + + + +\begin{code} +mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) + +splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type) splitSigmaTy ty = (tyvars, theta, tau) where - (tyvars,rho) = splitForAllTy ty + (tyvars,rho) = splitForAllTys ty (theta,tau) = splitRhoTy rho - -mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) \end{code} -Finding the kind of a type -~~~~~~~~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Kinds and free variables} +%* * +%************************************************************************ + +--------------------------------------------------------------------- + Finding the kind of a type + ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -typeKind :: GenType (GenTyVar any) u -> Kind - -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (TyConTy tycon usage) = tyConKind tycon -typeKind (SynTy _ _ ty) = typeKind ty -typeKind (FunTy fun arg _) = mkBoxedTypeKind -typeKind (DictTy clas arg _) = mkBoxedTypeKind -typeKind (AppTy fun arg) = resultKind (typeKind fun) -typeKind (ForAllTy _ _) = mkBoxedTypeKind -typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind +typeKind :: Type -> Kind + +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys +typeKind (NoteTy _ ty) = typeKind ty +typeKind (AppTy fun arg) = funResultTy (typeKind fun) +typeKind (FunTy fun arg) = typeKindF arg +typeKind (ForAllTy _ ty) = typeKindF ty -- We could make this a new kind polyTypeKind + -- to prevent a forall type unifying with a + -- boxed type variable, but I didn't think it + -- was worth it yet. + +-- The complication is that a *function* is boxed even if +-- its *result* type is unboxed. Seems wierd. + +typeKindF :: Type -> Kind +typeKindF (NoteTy _ ty) = typeKindF ty +typeKindF (FunTy _ ty) = typeKindF ty +typeKindF (ForAllTy _ ty) = typeKindF ty +typeKindF other = fix_up (typeKind other) + where + fix_up (TyConApp kc _) | kc == typeCon = boxedTypeKind + -- Functions at the type level are always boxed + fix_up (NoteTy _ kind) = fix_up kind + fix_up kind = kind \end{code} -Free variables of a type -~~~~~~~~~~~~~~~~~~~~~~~~ +--------------------------------------------------------------------- + Free variables of a type + ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi +tyVarsOfType :: Type -> TyVarSet -tyVarsOfType (TyVarTy tv) = unitTyVarSet tv -tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet -tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys -tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res -tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg -tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty -tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar -tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty +tyVarsOfType (TyVarTy tv) = unitVarSet tv +tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys +tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs +tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1 +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res +tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg +tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar -tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi -tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys +tyVarsOfTypes :: [Type] -> TyVarSet +tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys + +-- 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 -- Find the free names of a type, including the type constructors and classes it mentions -namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet +namesOfType :: Type -> NameSet namesOfType (TyVarTy tv) = unitNameSet (getName tv) -namesOfType (TyConTy tycon usage) = unitNameSet (getName tycon) -namesOfType (SynTy tycon tys ty) = unitNameSet (getName tycon) `unionNameSets` - namesOfType ty -namesOfType (FunTy arg res _) = namesOfType arg `unionNameSets` namesOfType res +namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` + namesOfTypes tys +namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1 +namesOfType (NoteTy other_note ty2) = namesOfType ty2 +namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg -namesOfType (DictTy clas ty _) = unitNameSet (getName clas) `unionNameSets` - namesOfType ty namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar) -namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage" -\end{code} - -Instantiating a type -~~~~~~~~~~~~~~~~~~~~ -\begin{code} --- applyTy :: GenType (GenTyVar flexi) uvar --- -> GenType (GenTyVar flexi) uvar --- -> GenType (GenTyVar flexi) uvar - -applyTy :: Type -> Type -> Type - -applyTy (SynTy _ _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty -applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg -applyTy other arg = panic "applyTy" +namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys \end{code} -\begin{code} -instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)] - -> GenType (GenTyVar flexi) uvar - -> GenType (GenTyVar flexi) uvar - -instantiateTauTy :: Eq tv => - [(tv, GenType tv' u)] - -> GenType tv u - -> GenType tv' u -applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType +%************************************************************************ +%* * +\subsection{Instantiating a type} +%* * +%************************************************************************ --- 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 +@substTy@ applies a substitution to a type. It deals correctly with name capture. -instant_help ty lookup_tv deflt_tv choose_tycon - if_usage if_forall bound_forall_tv_BAD deflt_forall_tv - = go ty - where - go (TyVarTy tv) = case (lookup_tv tv) of - Nothing -> deflt_tv tv - Just ty -> ty - go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage - go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty) - go (FunTy arg res usage) = FunTy (go arg) (go res) usage - go (AppTy fun arg) = AppTy (go fun) (go arg) - go (DictTy clas ty usage) = DictTy clas (go ty) usage - go (ForAllUsageTy uvar bds ty) = if_usage $ - ForAllUsageTy uvar bds (go ty) - go (ForAllTy tv ty) = if_forall $ - (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then - trace "instantiateTy: unexpected forall hit" - else - \x->x) ForAllTy (deflt_forall_tv tv) (go ty) - -instantiateTy [] ty = ty - -instantiateTy tenv ty - = instant_help ty lookup_tv deflt_tv choose_tycon - if_usage if_forall bound_forall_tv_BAD deflt_forall_tv - where - lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of - [] -> Nothing - [ty] -> Just ty - _ -> panic "instantiateTy:lookup_tv" - - deflt_tv tv = TyVarTy tv - choose_tycon ty _ _ = ty - if_usage ty = ty - if_forall ty = ty - bound_forall_tv_BAD = True - deflt_forall_tv tv = tv - -instantiateTauTy tenv ty - = instant_help ty lookup_tv deflt_tv choose_tycon - if_usage if_forall bound_forall_tv_BAD deflt_forall_tv +\begin{code} +substTy :: TyVarSubst -> Type -> Type +substTy tenv ty + | isEmptyVarEnv tenv = ty + | otherwise = subst_ty tenv tset ty where - lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of - [] -> Nothing - [ty] -> Just ty - _ -> panic "instantiateTauTy:lookup_tv" - - deflt_tv tv = panic "instantiateTauTy" - choose_tycon _ tycon usage = TyConTy tycon usage - if_usage ty = panic "instantiateTauTy:ForAllUsageTy" - if_forall ty = panic "instantiateTauTy:ForAllTy" - bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv" - deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv" - -instantiateThetaTy tenv theta - = [(clas,instantiateTauTy tenv ty) | (clas,ty) <- theta] - --- applyTypeEnv 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. --- --- We don't use instant_help because we need to carry in the environment - -applyTypeEnvToTy tenv ty - = go tenv ty + tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv + -- If ty doesn't have any for-alls, then this thunk + -- will never be evaluated + +substTheta :: TyVarSubst -> ThetaType -> ThetaType +substTheta tenv theta + | isEmptyVarEnv tenv = theta + | otherwise = [(clas, map (subst_ty tenv tset) tys) | (clas, tys) <- theta] where - go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of - Nothing -> ty - Just ty -> ty - go tenv ty@(TyConTy tycon usage) = ty - go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty) - go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage - go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg) - go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage - go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty) - go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty) - where - tenv' = case lookupTyVarEnv tenv tv of - Nothing -> tenv - Just _ -> delFromTyVarEnv tenv tv + tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv + -- If ty doesn't have any for-alls, then this thunk + -- will never be evaluated + +substTopTy :: TyVarSubst -> Type -> Type +substTopTy = substTy -- Called when doing top-level substitutions. + -- Here we expect that the free vars of the range of the + -- substitution will be empty; but during typechecking I'm + -- a bit dubious about that (mutable tyvars bouund to Int, say) + -- So I've left it as substTy for the moment. SLPJ Nov 98 +substTopTheta = substTheta \end{code} -\begin{code} -instantiateUsage - :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u' +@fullSubstTy@ is like @substTy@ except that it needs to be given a set +of in-scope type variables. In exchange it's a bit more efficient, at least +if you happen to have that set lying around. -instantiateUsage = panic "instantiateUsage: not implemented" +\begin{code} +fullSubstTy :: TyVarSubst -- Substitution to apply + -> TyVarSet -- Superset of the free tyvars of + -- the range of the tyvar env + -> Type -> Type +-- ASSUMPTION: The substitution is idempotent. +-- Equivalently: No tyvar is both in scope, and in the domain of the substitution. +fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty + | otherwise = subst_ty tenv tset ty + +-- subst_ty does the business +subst_ty tenv tset ty + = go ty + where + go (TyConApp tc tys) = TyConApp tc (map go tys) + go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2) + go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note + go (FunTy arg res) = FunTy (go arg) (go res) + go (AppTy fun arg) = mkAppTy (go fun) (go arg) + go ty@(TyVarTy tv) = case (lookupVarEnv tenv tv) of + Nothing -> ty + Just ty' -> ty' + go (ForAllTy tv ty) = case substTyVar tenv tset tv of + (tenv', tset', tv') -> ForAllTy tv' (subst_ty tenv' tset' ty) + +substTyVar :: TyVarSubst -> TyVarSet -> TyVar + -> (TyVarSubst, TyVarSet, TyVar) + +substTyVar tenv tset tv + | not (tv `elemVarSet` tset) -- No need to clone + -- But must delete from substitution + = (tenv `delVarEnv` tv, tset `extendVarSet` tv, tv) + + | otherwise -- The forall's variable is in scope so + -- we'd better rename it away from the in-scope variables + -- Extending the substitution to do this renaming also + -- has the (correct) effect of discarding any existing + -- substitution for that variable + = (extendVarEnv tenv tv (TyVarTy tv'), tset `extendVarSet` tv', tv') + where + tv' = uniqAway tset tv \end{code} -At present there are no unboxed non-primitive types, so -isUnboxedType is the same as isPrimType. +%************************************************************************ +%* * +\subsection{TidyType} +%* * +%************************************************************************ + +tidyTy tidies up a type for printing in an error message, or in +an interface file. -We're a bit cavalier about finding out whether something is -primitive/unboxed or not. Rather than deal with the type -arguemnts we just zoom into the function part of the type. -That is, given (T a) we just recurse into the "T" part, -ignoring "a". +It doesn't change the uniques at all, just the print names. \begin{code} -isPrimType, isUnboxedType :: Type -> Bool - -isPrimType (AppTy ty _) = isPrimType ty -isPrimType (SynTy _ _ ty) = isPrimType ty -isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of - Just (tyvars, ty) -> isPrimType ty - Nothing -> isPrimTyCon tycon +tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVar env@(tidy_env, subst) tyvar + = case lookupVarEnv subst tyvar of + + Just tyvar' -> -- Already substituted + (env, tyvar') + + Nothing -> -- Make a new nice name for it + + case tidyOccName tidy_env (getOccName name) of + (tidy', occ') -> -- New occname reqd + ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarName tyvar name' + name' = mkLocalName (getUnique name) occ' noSrcLoc + -- Note: make a *user* tyvar, so it printes nicely + -- Could extract src loc, but no need. + where + name = tyVarName tyvar -isPrimType _ = False +tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars -isUnboxedType = isPrimType +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) = TyConApp tycon (map go tys) + go (NoteTy note ty) = NoteTy (go_note note) (go ty) + go (AppTy fun arg) = AppTy (go fun) (go arg) + go (FunTy fun arg) = FunTy (go fun) (go arg) + go (ForAllTy tv ty) = ForAllTy tv' (tidyType env' ty) + where + (env', tv') = tidyTyVar env tv + + go_note (SynNote ty) = SynNote (go ty) + go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars + +tidyTypes env tys = map (tidyType env) tys \end{code} -This is *not* right: it is a placeholder (ToDo 96/03 WDP): + +@tidyOpenType@ grabs the free type varibles, tidies them +and then uses @tidyType@ to work over the type itself + \begin{code} -typePrimRep :: Type -> PrimRep +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType env' ty) + where + env' = foldl go env (varSetElems (tyVarsOfType ty)) + go env tyvar = fst (tidyTyVar env tyvar) + +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys -typePrimRep (SynTy _ _ ty) = typePrimRep ty -typePrimRep (AppTy ty _) = typePrimRep ty -typePrimRep (TyConTy tc _) - | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of - Just xx -> xx - Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc) - - | otherwise = case maybeNewTyCon tc of - Just (tyvars, ty) | isPrimType ty -> typePrimRep ty - _ -> PtrRep -- Default - -typePrimRep _ = PtrRep -- the "default" - -tc_primrep_list - = [(addrPrimTyConKey, AddrRep) - ,(arrayPrimTyConKey, ArrayRep) - ,(byteArrayPrimTyConKey, ByteArrayRep) - ,(charPrimTyConKey, CharRep) - ,(doublePrimTyConKey, DoubleRep) - ,(floatPrimTyConKey, FloatRep) - ,(foreignObjPrimTyConKey, ForeignObjRep) - ,(intPrimTyConKey, IntRep) - ,(mutableArrayPrimTyConKey, ArrayRep) - ,(mutableByteArrayPrimTyConKey, ByteArrayRep) - ,(stablePtrPrimTyConKey, StablePtrRep) - ,(statePrimTyConKey, VoidRep) - ,(synchVarPrimTyConKey, PtrRep) - ,(voidTyConKey, PtrRep) -- Not VoidRep! That's just for Void# - -- The type Void is represented by a pointer to - -- a bottom closure. - ,(wordPrimTyConKey, WordRep) - ] +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty \end{code} + %************************************************************************ %* * -\subsection{Matching on types} +\subsection{Boxedness and 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. - -@matchTys@ matches corresponding elements of a list of templates and -types. - \begin{code} -matchTy :: GenType t1 u1 -- Template - -> GenType t2 u2 -- Proposed instance of template - -> Maybe [(t1,GenType t2 u2)] -- Matching substitution - - -matchTys :: [GenType t1 u1] -- Templates - -> [GenType t2 u2] -- Proposed instance of template - -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution - [GenType t2 u2]) -- Left over instance types - -matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) [] -matchTys tys1 tys2 = go [] tys1 tys2 - where - go s [] tys2 = Just (s,tys2) - go s (ty1:tys1) [] = trace "matchTys" Nothing - go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s -\end{code} - -@match@ is the main function. +isUnboxedType :: Type -> Bool +isUnboxedType ty = not (isFollowableRep (typePrimRep ty)) + +isUnLiftedType :: Type -> Bool +isUnLiftedType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> isUnLiftedTyCon tc + 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( length ty_args == tyConArity tc ) + isAlgTyCon tc + other -> False + +-- Should only be applied to *types*; hence the assert +isDataType :: Type -> Bool +isDataType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isDataTyCon tc + other -> False -\begin{code} -match :: GenType t1 u1 -> GenType t2 u2 -- Current match pair - -> ([(t1, GenType t2 u2)] -> Maybe result) -- Continuation - -> [(t1, GenType t2 u2)] -- Current substitution - -> Maybe result - -match (TyVarTy v) ty k = \s -> k ((v,ty) : s) -match (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) k = match fun1 fun2 (match arg1 arg2 k) -match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k) -match (TyConTy con1 _) (TyConTy con2 _) k | con1 == con2 = k -match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k -match (SynTy _ _ ty1) ty2 k = match ty1 ty2 k -match ty1 (SynTy _ _ ty2) k = match ty1 ty2 k - - -- 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) - --- Catch-all fails -match _ _ _ = \s -> Nothing +typePrimRep :: Type -> PrimRep +typePrimRep ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> tyConPrimRep tc + other -> PtrRep \end{code} %************************************************************************ @@ -878,170 +943,56 @@ match _ _ _ = \s -> Nothing %* * %************************************************************************ -The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t -and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see -dictionaries or polymorphic types). The function eqTy has a more -specific type, but does the `right thing' for all types. +For the moment at least, type comparisons don't work if +there are embedded for-alls. \begin{code} -eqSimpleTheta :: (Eq t,Eq u) => - [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool +instance Eq Type where + ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False } -eqSimpleTheta [] [] = True -eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) = - c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2 -eqSimpleTheta other1 other2 = False -\end{code} +instance Ord Type where + compare ty1 ty2 = cmpTy ty1 ty2 -\begin{code} -eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool - -(TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) = - tv1 == tv2 -(AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) = - f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 -(TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) = - tc1 == tc2 --ToDo: later: && u1 == u2 - -(FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) = - f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2 -(FunTy f1 a1 u1) `eqSimpleTy` t2 = - -- Expand t1 just in case t2 matches that version - (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2 -t1 `eqSimpleTy` (FunTy f2 a2 u2) = - -- Expand t2 just in case t1 matches that version - t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2) - -(SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) = - (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2) - || t1 `eqSimpleTy` t2 -(SynTy _ _ t1) `eqSimpleTy` t2 = - t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again -t1 `eqSimpleTy` (SynTy _ _ t2) = - t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again - -(DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy" -_ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy" - -(ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy" -_ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy" - -(ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy" -_ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy" - -_ `eqSimpleTy` _ = False +cmpTy :: Type -> Type -> Ordering +cmpTy ty1 ty2 + = cmp emptyVarEnv 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 lookupVarEnv env tv1 of + Just tv2 -> tv2 + Nothing -> tv1 + + -- Get rid of NoteTy + cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2 + cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2 + + -- Deal with equal constructors + cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2 + cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2 + cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2 + cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2) + cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2 + + -- 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 \end{code} -Types are ordered so we can sort on types in the renamer etc. DNT: Since -this class is also used in CoreLint and other such places, we DO expand out -Fun/Syn/Dict types (if necessary). -\begin{code} -eqTy :: Type -> Type -> Bool - -eqTy t1 t2 = - eq nullTyVarEnv nullUVarEnv t1 t2 - where - eq tve uve (TyVarTy tv1) (TyVarTy tv2) = - tv1 == tv2 || - case (lookupTyVarEnv tve tv1) of - Just tv -> tv == tv2 - Nothing -> False - eq tve uve (AppTy f1 a1) (AppTy f2 a2) = - eq tve uve f1 f2 && eq tve uve a1 a2 - eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) = - tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2 - - eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) = - eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2 - eq tve uve (FunTy f1 a1 u1) t2 = - -- Expand t1 just in case t2 matches that version - eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2 - eq tve uve t1 (FunTy f2 a2 u2) = - -- Expand t2 just in case t1 matches that version - eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2) - - eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2) - | c1 == c2 - = eq tve uve t1 t2 && eqUsage uve u1 u2 - -- NB we use a guard for c1==c2 so that if they aren't equal we - -- fall through into expanding the type. Why? Because brain-dead - -- people might write - -- class Foo a => Baz a where {} - -- and that means that a Foo dictionary and a Baz dictionary are identical - -- Sigh. Let's hope we don't spend too much time in here! - - eq tve uve t1@(DictTy _ _ _) t2 = - eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again - eq tve uve t1 t2@(DictTy _ _ _) = - eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again - - eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) = - (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2) - || eq tve uve t1 t2 - eq tve uve (SynTy _ _ t1) t2 = - eq tve uve t1 t2 -- Expand the abbrevation and try again - eq tve uve t1 (SynTy _ _ t2) = - eq tve uve t1 t2 -- Expand the abbrevation and try again - - eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) = - eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2 - eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) = - eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2 - - eq _ _ _ _ = False - - eqBounds uve [] [] = True - eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2 - eqBounds uve _ _ = False -\end{code} - -\begin{code} -showTypeCategory :: Type -> Char - {- - {C,I,F,D} char, int, float, double - T tuple - S other single-constructor type - {c,i,f,d} unboxed ditto - t *unpacked* tuple - s *unpacked" single-cons... - - v void# - a primitive array - - E enumeration type - + dictionary, unless it's a ... - L List - > function - M other (multi-constructor) data-con type - . other type - - reserved for others to mark as "uninteresting" - -} -showTypeCategory ty - = if isDictTy ty - then '+' - else - case getTyCon_maybe ty of - Nothing -> if maybeToBool (getFunTy_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... -\end{code}