#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, splitFunTyWithDictsAsArgs,
- 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,
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()
+#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 ( classSig, classOpLocalType, GenClass{-instances-} )
-import Kind ( mkBoxedTypeKind, resultKind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, 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 ( 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 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
\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.
expandTy (DictTy clas ty u)
= case all_arg_tys of
+ [] -> voidTy -- Empty dictionary represented by Void
+
[arg_ty] -> expandTy arg_ty -- just the <whatever> itself
-- The extra expandTy is to make sure that
-- 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
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)
mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
-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)
- | 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)
-splitFunTyWithDictsAsArgs :: Type -> ([Type], Type)
- -- splitFunTy *must* have the general type given, which
- -- means it *can't* do the DictTy jiggery-pokery that
- -- *is* sometimes required. The relationship between these
+ -- 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
-splitFunTy 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)
-
-splitFunTyWithDictsAsArgs t = go t []
+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 []
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
-
- -- For a dictionary type we try expanding it to see if we get a simple
- -- function; if so we thunder on; if not we throw away the expansion.
- go t@(DictTy _ _ _) ts | null ts' = (reverse ts, t)
- | otherwise = (reverse ts ++ ts', t')
- where
- (ts', t') = go (expandTy t) []
-
- 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}
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}
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}
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}
Nothing -> Nothing
Just tycon -> Just (tycon, arg_tys)
where
- (app_ty, arg_tys) = splitAppTy ty
+ (app_ty, arg_tys) = splitAppTys ty
getAppTyCon
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: " -- (pprGenType 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
~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
typeKind :: GenType (GenTyVar any) u -> Kind
+
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (TyConTy tycon usage) = tyConKind tycon
typeKind (SynTy _ _ ty) = typeKind 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
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}
%************************************************************************
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
-- 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}
%************************************************************************
(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
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
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}
projects / ghc-hetmet.git / blobdiff