X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=229b5aedcccf6f2e59ef5caf35da9e38c76f47ee;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=c094e1efa9a9db3dccb291f217e5a16f2057bfea;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index c094e1e..229b5ae 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, 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,37 +37,53 @@ module Type ( isTauTy, - tyVarsOfType, tyVarsOfTypes, typeKind + tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + showTypeCategory ) where -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking -import PrelLoop -- for paranoia checking - --- ToDo:rm ---import PprType ( pprGenType ) -- ToDo: rm ---import PprStyle ( PprStyle(..) ) ---import Util ( pprPanic ) +IMP_Ubiq() +--IMPORT_DELOOPER(IdLoop) -- for paranoia checking +IMPORT_DELOOPER(TyLoop) +--IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -- friends: import Class ( classSig, classOpLocalType, GenClass{-instances-} ) -import Kind ( mkBoxedTypeKind, resultKind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity, +import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind ) +import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon, + isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) -import TyVar ( tyVarKind, 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 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 {-mumble-} +-- UniqFM (ufmToList ) +--import {-mumble-} +-- Outputable +--import PprEnv \end{code} Data types @@ -132,6 +154,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 @@ -140,7 +164,7 @@ 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 @@ -187,8 +211,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) @@ -203,6 +232,13 @@ 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) @@ -210,17 +246,52 @@ getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) 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 [] +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 + +getFunTyExpandingDicts_maybe peek other + | not peek = Nothing -- that was easy + | otherwise + = case (maybeAppTyCon other) of + Nothing -> Nothing + Just (tc, arg_tys) + | not (isNewTyCon tc) -> Nothing + | otherwise -> + let + [newtype_con] = tyConDataCons tc -- there must be exactly one... + [inside_ty] = dataConArgTys newtype_con arg_tys + in + getFunTyExpandingDicts_maybe peek inside_ty + +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 + -- 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} @@ -232,18 +303,26 @@ mkTyConTy tycon 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 +getTyCon_maybe :: GenType t u -> Maybe TyCon +--getTyConExpandingDicts_maybe :: Type -> 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 = ASSERT(isSynTyCon syn_tycon) - SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body) + SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon \end{code} @@ -282,6 +361,19 @@ splitRhoTy t = = go r ((c,t):ts) go (SynTy _ _ t) ts = go t ts go t ts = (reverse ts, 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} @@ -298,6 +390,12 @@ 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 [] where @@ -329,7 +427,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 @@ -349,34 +447,53 @@ Applied data tycons (give back constrs) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \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 | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $ + isDataTyCon tycon && + 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: " -- (pprGenType PprShowAll ty) + Nothing -> panic "Type.getAppDataTyCon"-- (pprGenType PprShowAll ty) #endif @@ -409,6 +526,7 @@ 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 @@ -436,101 +554,165 @@ 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 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 @@ -538,12 +720,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} %************************************************************************ @@ -565,30 +775,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 @@ -596,10 +812,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} %************************************************************************ @@ -631,7 +844,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 @@ -680,7 +893,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 @@ -691,8 +904,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 _ _ _) = @@ -717,3 +938,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}