GenType(..), SYN_IE(Type), SYN_IE(TauType),
mkTyVarTy, mkTyVarTys,
getTyVar, getTyVar_maybe, isTyVarTy,
- mkAppTy, mkAppTys, splitAppTy,
+ mkAppTy, mkAppTys, splitAppTy, splitAppTys,
mkFunTy, mkFunTys,
splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking,
getFunTy_maybe, getFunTyExpandingDicts_maybe,
SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
mkDictTy,
- mkRhoTy, splitRhoTy, mkTheta,
+ mkRhoTy, splitRhoTy, mkTheta, isDictTy,
mkSigmaTy, splitSigmaTy,
maybeAppTyCon, getAppTyCon,
isTauTy,
- tyVarsOfType, tyVarsOfTypes, typeKind
+ tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
+ showTypeCategory
) where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
+--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, notArrowKind, Kind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon,
+import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
- unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
+ 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 Unique -- quite a few *Keys
import Util ( thenCmp, zipEqual, assoc,
- panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
+ 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 {-mumble-}
+-- Pretty
+--import {-mumble-}
+-- PprStyle
+--import {-mumble-}
+-- PprType --(pprType )
+--import {-mumble-}
+-- UniqFM (ufmToList )
+--import {-mumble-}
+-- Outputable
+--import PprEnv
\end{code}
Data types
-- 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)
(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
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
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)) $
+ = 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
= map cvt dict_tys
where
cvt (DictTy clas ty _) = (clas, ty)
- cvt other = pprPanic "mkTheta:" (pprType PprDebug other)
+ cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
+
+isDictTy (DictTy _ _ _) = True
+isDictTy (SynTy _ _ t) = isDictTy t
+isDictTy _ = False
\end{code}
Nothing -> Nothing
Just tycon -> Just (tycon, arg_tys)
where
- (app_ty, arg_tys) = splitAppTy ty
+ (app_ty, arg_tys) = splitAppTys ty
getAppTyCon
maybe_app_data_tycon expand ty
= let
expanded_ty = expand ty
- (app_ty, arg_tys) = splitAppTy expanded_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))]) $
= case maybe ty of
Just stuff -> stuff
#ifdef DEBUG
- Nothing -> panic "Type.getAppDataTyCon" -- (pprGenType PprShowAll ty)
+ Nothing -> panic "Type.getAppDataTyCon"-- (pprGenType PprShowAll ty)
#endif
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 :: GenType (GenTyVar flexi) uvar
- -> GenType (GenTyVar flexi) uvar
- -> GenType (GenTyVar flexi) uvar
+-- applyTy :: GenType (GenTyVar flexi) uvar
+-- -> GenType (GenTyVar flexi) uvar
+-- -> GenType (GenTyVar flexi) uvar
+
+applyTy :: Type -> Type -> Type
-applyTy (SynTy _ _ fun) arg = applyTy fun arg
-applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
-applyTy other arg = panic "applyTy"
+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}
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 tenv ty
- = instant_help ty lookup_tv deflt_tv choose_tycon
- if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
+ = go tenv ty
where
- lookup_tv = lookupTyVarEnv tenv
- deflt_tv tv = TyVarTy tv
- choose_tycon ty _ _ = ty
- if_usage ty = ty
- if_forall ty = ty
- bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing)
- deflt_forall_tv tv = case (lookup_tv tv) of
- Nothing -> tv
- Just (TyVarTy tv2) -> tv2
- _ -> pprPanic "applyTypeEnvToTy:" (ppAbove (ppr PprShowAll tv) (ppr PprShowAll ty))
+ 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}
\begin{code}
typePrimRep (TyConTy tc _)
| isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
Just xx -> xx
- Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
+ Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
| otherwise = case maybeNewTyCon tc of
Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
,(stablePtrPrimTyConKey, StablePtrRep)
,(statePrimTyConKey, VoidRep)
,(synchVarPrimTyConKey, PtrRep)
- ,(voidTyConKey, VoidRep)
+ ,(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 "matchTys" 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}
%************************************************************************
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