mkTyVarTy, mkTyVarTys,
getTyVar, getTyVar_maybe, isTyVarTy,
mkAppTy, mkAppTys, splitAppTy,
- mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe,
+ mkFunTy, mkFunTys, splitFunTy, splitFunTyWithDictsAsArgs,
+ getFunTy_maybe,
mkTyConTy, getTyCon_maybe, applyTyCon,
mkSynTy,
mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
isTauTy,
- tyVarsOfType, tyVarsOfTypes, getTypeKind
-
-
-) where
+ tyVarsOfType, tyVarsOfTypes, typeKind
+ ) 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 )
+
-- friends:
-import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} )
+import Class ( classSig, classOpLocalType, GenClass{-instances-} )
import Kind ( mkBoxedTypeKind, resultKind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, tyConArity,
+import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
-import TyVar ( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
+import TyVar ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
addOneToTyVarEnv, TyVarEnv(..) )
(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
-- 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}
getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
getFunTy_maybe other = Nothing
-splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
+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
+ -- two functions is like that between eqTy and eqSimpleTy.
+
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)
+ | isFunTyCon tycon = go res (arg:ts)
+ go (SynTy _ _ t) ts = go t ts
+ go t ts = (reverse ts, t)
+
+splitFunTyWithDictsAsArgs 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)
\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))
+ foldl AppTy (TyConTy tycon usageOmega) tys
getTyCon_maybe :: GenType t u -> Maybe TyCon
getTyCon_maybe (TyConTy tycon _) = Just tycon
\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 tyvars tys) body)
where
(tyvars, body) = getSynTyConDefn syn_tycon
\end{code}
= case maybeAppDataTyCon ty of
Just stuff -> stuff
#ifdef DEBUG
- Nothing -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty)
+ Nothing -> panic "Type.getAppDataTyCon: " -- (pprGenType PprShowAll ty)
#endif
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}
-- 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 _ _ _) =
projects / ghc-hetmet.git / blobdiff