X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=294f4235cd6ecb2805e5daea288f21666a78deb7;hb=3cbb4112ec0d75f517fb07ccb6ae42039686b757;hp=0d25048aa1c695b5847f8fcf2baae66d8e3b1889;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 0d25048..294f423 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -2,26 +2,32 @@ #include "HsVersions.h" module Type ( - GenType(..), Type(..), TauType(..), + GenType(..), SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, - mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, + mkFunTy, mkFunTys, + splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking, + getFunTy_maybe, getFunTyExpandingDicts_maybe, mkTyConTy, getTyCon_maybe, applyTyCon, mkSynTy, - mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy, + mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy, splitForAllTyExpandingDicts, mkForAllUsageTy, getForAllUsageTy, applyTy, - +#ifdef DEBUG + expandTy, -- only let out for debugging (ToDo: rm?) +#endif isPrimType, isUnboxedType, typePrimRep, - RhoType(..), SigmaType(..), ThetaType(..), + SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType), mkDictTy, - mkRhoTy, splitRhoTy, + mkRhoTy, splitRhoTy, mkTheta, isDictTy, mkSigmaTy, splitSigmaTy, maybeAppTyCon, getAppTyCon, - maybeAppDataTyCon, getAppDataTyCon, + maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon, + maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts, + getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts, maybeBoxedPrimType, matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta, @@ -31,34 +37,56 @@ module Type ( isTauTy, - tyVarsOfType, tyVarsOfTypes, getTypeKind - - -) where - -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking -import PrelLoop -- for paranoia checking + tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + showTypeCategory + ) 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 -- friends: -import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} ) -import Kind ( mkBoxedTypeKind, resultKind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, tyConArity, +import Class ( classSig, classOpLocalType, 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 ( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..), +import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), emptyTyVarSet, unionTyVarSets, minusTyVarSet, - unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, - addOneToTyVarEnv, TyVarEnv(..) ) -import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..), + 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 + ) + -- others +import Maybes ( maybeToBool, assocMaybe ) import PrimRep ( PrimRep(..) ) -import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, +import Unique -- quite a few *Keys +import UniqFM ( Uniquable(..) ) +import Util ( thenCmp, zipEqual, assoc, + panic, panic#, assertPanic, pprPanic, Ord3(..){-instances-} ) +-- ToDo:rm all these +--import {-mumble-} +-- Pretty +--import {-mumble-} +-- PprStyle +--import {-mumble-} +-- PprType --(pprType ) +--import PprEnv \end{code} Data types @@ -75,7 +103,7 @@ data GenType tyvar uvar -- Parameterised over type and usage variables (GenType tyvar uvar) | TyConTy -- Constants of a specified kind - TyCon + 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 @@ -117,6 +145,21 @@ type SigmaType = Type \end{code} +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms whereever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. + + Expand abbreviations ~~~~~~~~~~~~~~~~~~~~ Removes just the top level of any abbreviations. @@ -129,6 +172,8 @@ expandTy (SynTy _ _ t) = expandTy t expandTy (DictTy clas ty u) = case all_arg_tys of + [] -> voidTy -- Empty dictionary represented by Void + [arg_ty] -> expandTy arg_ty -- just the itself -- The extra expandTy is to make sure that @@ -137,19 +182,19 @@ expandTy (DictTy clas ty u) -- no methods! other -> ASSERT(not (null all_arg_tys)) - foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys + foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys -- A tuple of 'em -- Note: length of all_arg_tys can be 0 if the class is - -- _CCallable, _CReturnable (and anything else + -- CCallable, CReturnable (and anything else -- *really weird* that the user writes). where - (tyvar, super_classes, ops) = getClassSig clas + (tyvar, super_classes, ops) = classSig clas super_dict_tys = map mk_super_ty super_classes class_op_tys = map mk_op_ty ops all_arg_tys = super_dict_tys ++ class_op_tys mk_super_ty sc = DictTy sc ty usageOmega - mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op) + mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op) expandTy ty = ty \end{code} @@ -184,8 +229,13 @@ 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 t = go t [] +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" + +splitAppTys :: GenType t u -> (GenType t u, [GenType t u]) +splitAppTys t = go t [] where go (AppTy t arg) ts = go t (arg:ts) go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts) @@ -200,42 +250,111 @@ 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 (FunTy arg result _) = Just (arg,result) -getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res) +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) -getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t -getFunTy_maybe other = Nothing - -splitFunTy :: GenType t u -> ([GenType t u], GenType t u) -splitFunTy t = go t [] + 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 [] where - go (FunTy arg res _) ts = go res (arg:ts) - go (AppTy (AppTy (TyConTy tycon _) arg) res) ts - | isFunTyCon tycon - = go res (arg:ts) - go (SynTy _ _ t) ts - = go t ts - go t ts - = (reverse ts, t) + go t ts = case (get t) of + Just (arg,res) -> go res (arg:ts) + Nothing -> (reverse ts, t) \end{code} \begin{code} -- NB applyTyCon puts in usageOmega, for now at least -mkTyConTy tycon = TyConTy tycon usageOmega +mkTyConTy tycon + = ASSERT(not (isSynTyCon tycon)) + TyConTy tycon usageOmega applyTyCon :: TyCon -> [GenType t u] -> GenType t u -applyTyCon tycon tys = foldl AppTy (TyConTy tycon usageOmega) tys +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 +--getTyConExpandingDicts_maybe :: Type -> Maybe TyCon -getTyCon_maybe :: GenType t u -> Maybe TyCon getTyCon_maybe (TyConTy tycon _) = Just tycon getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t getTyCon_maybe other_ty = Nothing + +--getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon +--getTyConExpandingDicts_maybe (SynTy _ _ t) = getTyConExpandingDicts_maybe t +--getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty) +--getTyConExpandingDicts_maybe other_ty = Nothing \end{code} \begin{code} mkSynTy syn_tycon tys - = SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body) + = ASSERT(isSynTyCon syn_tycon) + SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon \end{code} @@ -266,14 +385,28 @@ mkRhoTy theta ty = splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u) splitRhoTy t = - go t [] + go t t [] where - go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts) - go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts + -- 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 ((c,t):ts) - go (SynTy _ _ t) ts = go t ts - go t ts = (reverse ts, t) + = 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) + +isDictTy (DictTy _ _ _) = True +isDictTy (SynTy _ _ t) = isDictTy t +isDictTy _ = False \end{code} @@ -290,12 +423,27 @@ getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t) getForAllTy_maybe _ = Nothing -splitForAllTy :: GenType t u-> ([t], GenType t u) -splitForAllTy t = go t [] +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 - go (ForAllTy tv t) tvs = go t (tv:tvs) - go (SynTy _ _ t) tvs = go t tvs - go t tvs = (reverse tvs, t) + -- 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) \end{code} \begin{code} @@ -321,7 +469,7 @@ maybeAppTyCon ty Nothing -> Nothing Just tycon -> Just (tycon, arg_tys) where - (app_ty, arg_tys) = splitAppTy ty + (app_ty, arg_tys) = splitAppTys ty getAppTyCon @@ -339,44 +487,64 @@ getAppTyCon ty Applied data tycons (give back constrs) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nota Bene: all these functions suceed for @newtype@ applications too! + \begin{code} maybeAppDataTyCon - :: GenType tyvar uvar + :: GenType (GenTyVar any) uvar -> Maybe (TyCon, -- the type constructor - [GenType tyvar uvar], -- types to which it is applied + [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 - = case (getTyCon_maybe app_ty) of - Just tycon | isDataTyCon tycon && - tyConArity tycon == length arg_tys +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 - where - (app_ty, arg_tys) = splitAppTy ty - -getAppDataTyCon - :: GenType tyvar uvar +getAppDataTyCon, getAppSpecDataTyCon + :: GenType (GenTyVar any) uvar -> (TyCon, -- the type constructor - [GenType tyvar uvar], -- types to which it is applied + [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 -getAppDataTyCon ty - = case maybeAppDataTyCon ty of +get_app_data_tycon maybe ty + = case maybe ty of Just stuff -> stuff #ifdef DEBUG - Nothing -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty) + 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]) -- with exactly one constructor + = 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 @@ -400,15 +568,16 @@ mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) Finding the kind of a type ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -getTypeKind :: GenType (GenTyVar any) u -> Kind -getTypeKind (TyVarTy tyvar) = getTyVarKind tyvar -getTypeKind (TyConTy tycon usage) = tyConKind tycon -getTypeKind (SynTy _ _ ty) = getTypeKind ty -getTypeKind (FunTy fun arg _) = mkBoxedTypeKind -getTypeKind (DictTy clas arg _) = mkBoxedTypeKind -getTypeKind (AppTy fun arg) = resultKind (getTypeKind fun) -getTypeKind (ForAllTy _ _) = mkBoxedTypeKind -getTypeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind +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 \end{code} @@ -428,101 +597,167 @@ tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> 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 (GenTyVar flexi) uvar -> 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 (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 :: Eq t => GenType t u -> GenType t u -> GenType t u -applyTy (SynTy _ _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty -applyTy other arg = panic "applyTy" +-- applyTy :: GenType (GenTyVar flexi) uvar +-- -> GenType (GenTyVar flexi) uvar +-- -> GenType (GenTyVar flexi) uvar -instantiateTy :: Eq t => [(t, GenType t u)] -> GenType t u -> GenType t u -instantiateTy tenv ty - = go ty - where - go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of - [] -> TyVarTy tv - (ty:_) -> ty - go ty@(TyConTy tycon usage) = ty - 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 (ForAllTy tv ty) = ASSERT(null tv_bound) - ForAllTy tv (go ty) - where - tv_bound = [() | (tv',_) <- tenv, tv==tv'] - - go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty) +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" +\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 -- 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 -instantiateTauTy :: Eq t => [(t, GenType t' u)] -> GenType t u -> GenType t' u -instantiateTauTy tenv ty +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 [ty | (tv',ty) <- tenv, tv==tv'] of - (ty:_) -> ty - [] -> panic "instantiateTauTy" - go (TyConTy tycon usage) = TyConTy 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 - -instantiateUsage - :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u' -instantiateUsage = error "instantiateUsage: not implemented" -\end{code} - -\begin{code} -type TypeEnv = TyVarEnv Type + 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 + 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" + + +-- 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 :: TypeEnv -> SigmaType -> SigmaType applyTypeEnvToTy tenv ty - = mapOverTyVars v_fn ty + = go tenv ty where - v_fn v = case (lookupTyVarEnv tenv v) of - Just ty -> ty - Nothing -> TyVarTy v + 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 \end{code} -@mapOverTyVars@ is a local function which actually does the work. It -does no cloning or other checks for shadowing, so be careful when -calling this on types with Foralls in them. - \begin{code} -mapOverTyVars :: (TyVar -> Type) -> Type -> Type +instantiateUsage + :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u' -mapOverTyVars v_fn ty - = let - mapper = mapOverTyVars v_fn - in - case ty of - TyVarTy v -> v_fn v - SynTy c as e -> SynTy c (map mapper as) (mapper e) - FunTy a r u -> FunTy (mapper a) (mapper r) u - AppTy f a -> AppTy (mapper f) (mapper a) - DictTy c t u -> DictTy c (mapper t) u - ForAllTy v t -> ForAllTy v (mapper t) - tc@(TyConTy _ _) -> tc +instantiateUsage = panic "instantiateUsage: not implemented" \end{code} + At present there are no unboxed non-primitive types, so isUnboxedType is the same as isPrimType. +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". + \begin{code} -isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool +isPrimType, isUnboxedType :: Type -> Bool isPrimType (AppTy ty _) = isPrimType ty isPrimType (SynTy _ _ ty) = isPrimType ty -isPrimType (TyConTy tycon _) = isPrimTyCon tycon +isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of + Just (tyvars, ty) -> isPrimType ty + Nothing -> isPrimTyCon tycon + isPrimType _ = False isUnboxedType = isPrimType @@ -530,12 +765,40 @@ isUnboxedType = isPrimType This is *not* right: it is a placeholder (ToDo 96/03 WDP): \begin{code} -typePrimRep :: GenType tyvar uvar -> PrimRep +typePrimRep :: Type -> PrimRep typePrimRep (SynTy _ _ ty) = typePrimRep ty -typePrimRep (TyConTy tc _) = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep 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) + ] \end{code} %************************************************************************ @@ -557,30 +820,36 @@ types. 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 - -matchTy ty1 ty2 = match [] [] ty1 ty2 -matchTys tys1 tys2 = match' [] (zipEqual tys1 tys2) + -> 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. \begin{code} -match :: [(t1, GenType t2 u2)] -- r, the accumulating result - -> [(GenType t1 u1, GenType t2 u2)] -- w, the work list - -> GenType t1 u1 -> GenType t2 u2 -- Current match pair - -> Maybe [(t1, GenType t2 u2)] - -match r w (TyVarTy v) ty = match' ((v,ty) : r) w -match r w (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) = match r ((fun1,fun2):w) arg1 arg2 -match r w (AppTy fun1 arg1) (AppTy fun2 arg2) = match r ((fun1,fun2):w) arg1 arg2 -match r w (TyConTy con1 _) (TyConTy con2 _) | con1 == con2 = match' r w -match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2 -match r w (SynTy _ _ ty1) ty2 = match r w ty1 ty2 -match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2 +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 @@ -588,10 +857,7 @@ match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2 -- here! (WDP 95/05) -- Catch-all fails -match _ _ _ _ = Nothing - -match' r [] = Just r -match' r ((ty1,ty2):w) = match r w ty1 ty2 +match _ _ _ = \s -> Nothing \end{code} %************************************************************************ @@ -623,7 +889,7 @@ eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool (AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) = f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) = - tc1 == tc2 && u1 == u2 + tc1 == tc2 --ToDo: later: && u1 == u2 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) = f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2 @@ -672,7 +938,7 @@ eqTy t1 t2 = 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 && eqUsage uve u1 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 @@ -683,8 +949,16 @@ eqTy t1 t2 = -- 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 + 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 _ _ _) = @@ -709,3 +983,53 @@ eqTy t1 t2 = 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}