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,
mkTyConTy, getTyCon_maybe, applyTyCon,
mkSynTy,
- mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy,
+ mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy, splitForAllTyExpandingDicts,
mkForAllUsageTy, getForAllUsageTy,
applyTy,
#ifdef DEBUG
isTauTy,
- tyVarsOfType, tyVarsOfTypes, typeKind
+ tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
+ showTypeCategory
) where
IMP_Ubiq()
---IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+#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 Class ( classSig, classOpLocalType, GenClass{-instances-}, SYN_IE(Class) )
import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon,
- isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
+import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
+ isPrimTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
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 UniqFM ( Uniquable(..) )
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-}
+-- Pretty
+--import {-mumble-}
+-- PprStyle
--import {-mumble-}
-- PprType --(pprType )
-import {-mumble-}
- UniqFM (ufmToList )
-import {-mumble-}
- Outputable
+--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.
-- 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)
-- 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
+ go syn_t (SynTy _ _ t) = go syn_t t
+ go syn_t other = Nothing
getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
-> Type
(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
- 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
+ | 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)
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
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
getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty)
getForAllTyExpandingDicts_maybe _ = Nothing
-splitForAllTy :: GenType t u-> ([t], GenType t u)
-splitForAllTy t = go t []
+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 (GenTyVar any) uvar
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))]) $
- isDataTyCon tycon &&
+ 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)
= 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
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 (SynTy _ _ fun) arg = applyTy fun arg
-applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
-applyTy other arg = panic "applyTy"
+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}
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
,(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}
matchTys tys1 tys2 = go [] tys1 tys2
where
go s [] tys2 = Just (s,tys2)
- go s (ty1:tys1) [] = panic "matchTys"
+ 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.
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