Type,
Kind, TyVarSubst,
- superKind, superBoxity, -- :: SuperKind
-
- boxedKind, -- :: Kind :: BX
- anyBoxKind, -- :: Kind :: BX
- typeCon, -- :: KindCon :: BX -> KX
- anyBoxCon, -- :: KindCon :: BX
-
- boxedTypeKind, unboxedTypeKind, openTypeKind, -- Kind :: superKind
-
- mkArrowKind, mkArrowKinds, -- mentioned below: hasMoreBoxityInfo,
+ superKind, superBoxity, -- KX and BX respectively
+ boxedBoxity, unboxedBoxity, -- :: BX
+ openKindCon, -- :: KX
+ typeCon, -- :: BX -> KX
+ boxedTypeKind, unboxedTypeKind, openTypeKind, -- :: KX
+ mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
funTyCon,
-- exports from this module:
- hasMoreBoxityInfo,
+ hasMoreBoxityInfo, defaultKind,
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
- mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy,
+
+ -- Predicates and the like
+ mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
+ splitDictTy_maybe, isDictTy, predRepTy,
mkSynTy, isSynTy, deNoteType,
mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys,
+ applyTy, applyTys, hoistForAllTys,
TauType, RhoType, SigmaType, PredType(..), ThetaType,
ClassPred, ClassContext, mkClassPred,
getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
isTauTy, mkRhoTy, splitRhoTy,
- mkSigmaTy, splitSigmaTy,
+ mkSigmaTy, isSigmaTy, splitSigmaTy,
+ getDFunTyKey,
-- Lifting and boxity
isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
-- Other imports:
import {-# SOURCE #-} DataCon( DataCon, dataConRepType )
-import {-# SOURCE #-} PprType( pprType, pprPred ) -- Only called in debug messages
+import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
import VarEnv
import VarSet
-import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
- )
+import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
import NameSet
-import Class ( classTyCon, Class )
+import Class ( classTyCon, Class, ClassPred, ClassContext )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
- tyConPrimRep, tyConClass_maybe
+ tyConPrimRep
)
-- others
import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Uniquable(..) )
-import Util ( mapAccumL, seqList )
+import Util ( mapAccumL, seqList, thenCmp )
import Outputable
import UniqSet ( sizeUniqSet ) -- Should come via VarSet
\end{code}
\begin{code}
hasMoreBoxityInfo :: Kind -> Kind -> Bool
hasMoreBoxityInfo k1 k2
- | k2 == openTypeKind = ASSERT( is_type_kind k1) True
+ | k2 == openTypeKind = True
| otherwise = k1 == k2
- where
- -- Returns true for things of form (Type x)
- is_type_kind k = case splitTyConApp_maybe k of
- Just (tc,[_]) -> tc == typeCon
- Nothing -> False
+
+defaultKind :: Kind -> Kind
+-- Used when generalising: default kind '?' to '*'
+defaultKind kind | kind == openTypeKind = boxedTypeKind
+ | otherwise = kind
\end{code}
getTyVar :: String -> Type -> TyVar
getTyVar msg (TyVarTy tv) = tv
+getTyVar msg (PredTy p) = getTyVar msg (predRepTy p)
getTyVar msg (NoteTy _ t) = getTyVar msg t
getTyVar msg other = panic ("getTyVar: " ++ msg)
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe (TyVarTy tv) = Just tv
getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
+getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p)
getTyVar_maybe other = Nothing
isTyVarTy :: Type -> Bool
isTyVarTy (TyVarTy tv) = True
isTyVarTy (NoteTy _ ty) = isTyVarTy ty
+isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
isTyVarTy other = False
\end{code}
invariant: use it.
\begin{code}
-mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
- mk_app orig_ty1
+mkAppTy orig_ty1 orig_ty2
+ = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
+ ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
-- For example: mkAppTys Rational []
-- returns to (Ratio Integer), which has needlessly lost
-- the Rational part.
-mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
- mk_app orig_ty1
+mkAppTys orig_ty1 orig_tys2
+ = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
+ ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
+splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p)
splitAppTy_maybe (TyConApp tc []) = Nothing
splitAppTy_maybe (TyConApp tc tys) = split tys []
where
where
split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
split orig_ty (NoteTy _ ty) args = split orig_ty ty args
+ split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args
split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
(TyConApp funTyCon [], [ty1,ty2])
split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
splitFunTy :: Type -> (Type, Type)
splitFunTy (FunTy arg res) = (arg, res)
splitFunTy (NoteTy _ ty) = splitFunTy ty
+splitFunTy (PredTy p) = splitFunTy (predRepTy p)
splitFunTy_maybe :: Type -> Maybe (Type, Type)
splitFunTy_maybe (FunTy arg res) = Just (arg, res)
splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
+splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p)
splitFunTy_maybe other = Nothing
splitFunTys :: Type -> ([Type], Type)
where
split args orig_ty (FunTy arg res) = split (arg:args) res res
split args orig_ty (NoteTy _ ty) = split args orig_ty ty
+ split args orig_ty (PredTy p) = split args orig_ty (predRepTy p)
split args orig_ty ty = (reverse args, orig_ty)
splitFunTysN :: String -> Int -> Type -> ([Type], Type)
split 0 args syn_ty ty = (reverse args, syn_ty)
split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
+ split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p)
split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
split acc [] nty ty = (reverse acc, nty)
split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
split acc xs nty (NoteTy _ ty) = split acc xs nty ty
+ split acc xs nty (PredTy p) = split acc xs nty (predRepTy p)
split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
funResultTy :: Type -> Type
funResultTy (FunTy arg res) = res
funResultTy (NoteTy _ ty) = funResultTy ty
+funResultTy (PredTy p) = funResultTy (predRepTy p)
funResultTy ty = pprPanic "funResultTy" (pprType ty)
funArgTy :: Type -> Type
funArgTy (FunTy arg res) = arg
funArgTy (NoteTy _ ty) = funArgTy ty
+funArgTy (PredTy p) = funArgTy (predRepTy p)
funArgTy ty = pprPanic "funArgTy" (pprType ty)
\end{code}
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
+splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
splitTyConApp_maybe other = Nothing
-- splitAlgTyConApp_maybe looks for
-- *saturated* applications of *algebraic* data types
-- "Algebraic" => newtype, data type, or dictionary (not function types)
--- We return the constructors too.
+-- We return the constructors too, so there had better be some.
splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
splitAlgTyConApp_maybe (TyConApp tc tys)
- | isAlgTyCon tc &&
+ | isAlgTyCon tc &&
tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
+splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p)
splitAlgTyConApp_maybe other = Nothing
splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
(tc, tys, tyConDataCons tc)
splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
+splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p)
+#ifdef DEBUG
+splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
+#endif
\end{code}
-"Dictionary" types are just ordinary data types, but you can
-tell from the type constructor whether it's a dictionary or not.
-
-\begin{code}
-mkDictTy :: Class -> [Type] -> Type
-mkDictTy clas tys = TyConApp (classTyCon clas) tys
-
-mkPredTy :: PredType -> Type
-mkPredTy (Class clas tys) = TyConApp (classTyCon clas) tys
-mkPredTy (IParam n ty) = NoteTy (IPNote n) ty
-
-{-
-splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe (TyConApp tc tys)
- | maybeToBool maybe_class
- && tyConArity tc == length tys = Just (clas, tys)
- where
- maybe_class = tyConClass_maybe tc
- Just clas = maybe_class
-
-splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
-splitDictTy_maybe other = Nothing
--}
-
-splitPredTy_maybe :: Type -> Maybe PredType
-splitPredTy_maybe (TyConApp tc tys)
- | maybeToBool maybe_class
- && tyConArity tc == length tys = Just (Class clas tys)
- where
- maybe_class = tyConClass_maybe tc
- Just clas = maybe_class
-
-splitPredTy_maybe (NoteTy (IPNote n) ty)
- = Just (IParam n ty)
-splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
-splitPredTy_maybe other = Nothing
-
-splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe ty
- = case splitPredTy_maybe ty of
- Just p -> getClassTys_maybe p
- Nothing -> Nothing
-
-isDictTy :: Type -> Bool
- -- This version is slightly more efficient than (maybeToBool . splitDictTy)
-isDictTy (TyConApp tc tys)
- | maybeToBool (tyConClass_maybe tc)
- && tyConArity tc == length tys
- = True
-isDictTy (NoteTy _ ty) = isDictTy ty
-isDictTy other = False
-\end{code}
---------------------------------------------------------------------
SynTy
isSynTy other = False
deNoteType :: Type -> Type
- -- Sorry for the cute name
+ -- Remove synonyms, but not Preds
deNoteType ty@(TyVarTy tyvar) = ty
deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
+deNoteType (PredTy p) = PredTy p
deNoteType (NoteTy _ ty) = deNoteType ty
deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
(a) for-alls, and
(b) newtypes
(c) synonyms
+ (d) predicates
It's useful in the back end where we're not
interested in newtypes anymore.
repType :: Type -> Type
repType (ForAllTy _ ty) = repType ty
repType (NoteTy _ ty) = repType ty
+repType (PredTy p) = repType (predRepTy p)
repType ty = case splitNewType_maybe ty of
Just ty' -> repType ty' -- Still re-apply repType in case of for-all
Nothing -> ty
-- Find the representation of a newtype, if it is one
-- Looks through multiple levels of newtype, but does not look through for-alls
splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
+splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p)
splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
Just rep_ty -> ASSERT( length tys == tyConArity tc )
-- The assert should hold because repType should
substUsTy :: VarEnv UsageAnn -> Type -> Type
-- assumes range is fresh uvars, so no conflicts
-substUsTy ve (NoteTy note@(UsgNote (UsVar u))
- ty ) = NoteTy (case lookupVarEnv ve u of
- Just ua -> UsgNote ua
- Nothing -> note)
- (substUsTy ve ty)
-substUsTy ve (NoteTy note@(UsgNote _) ty ) = NoteTy note (substUsTy ve ty)
-substUsTy ve (NoteTy note@(UsgForAll _) ty ) = NoteTy note (substUsTy ve ty)
-substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1))
- (substUsTy ve ty2)
-substUsTy ve (NoteTy note@(FTVNote _) ty ) = NoteTy note (substUsTy ve ty)
-substUsTy ve ty@(TyVarTy _ ) = ty
-substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1)
- (substUsTy ve ty2)
-substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1)
- (substUsTy ve ty2)
-substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys)
-substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty)
+substUsTy ve (NoteTy note@(UsgNote (UsVar u))
+ ty ) = NoteTy (case lookupVarEnv ve u of
+ Just ua -> UsgNote ua
+ Nothing -> note)
+ (substUsTy ve ty)
+substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) (substUsTy ve ty2)
+substUsTy ve (NoteTy note ty) = NoteTy note (substUsTy ve ty)
+
+substUsTy ve (PredTy (Class c tys)) = PredTy (Class c (map (substUsTy ve) tys))
+substUsTy ve (PredTy (IParam n ty)) = PredTy (IParam n (substUsTy ve ty))
+substUsTy ve (TyVarTy tv) = TyVarTy tv
+substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1) (substUsTy ve ty2)
+substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1) (substUsTy ve ty2)
+substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys)
+substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty)
\end{code}
return (tyvar, NoteTy (UsgNote usg) ty'')
Nothing -> splitFAT_m ty
where
- splitFAT_m (NoteTy _ ty) = splitFAT_m ty
- splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
- splitFAT_m _ = Nothing
-
-isForAllTy :: Type -> Bool
-isForAllTy (NoteTy _ ty) = isForAllTy ty
-isForAllTy (ForAllTy tyvar ty) = True
-isForAllTy _ = False
+ splitFAT_m (NoteTy _ ty) = splitFAT_m ty
+ splitFAT_m (PredTy p) = splitFAT_m (predRepTy p)
+ splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
+ splitFAT_m _ = Nothing
splitForAllTys :: Type -> ([TyVar], Type)
splitForAllTys ty = case splitUsgTy_maybe ty of
in (tvs, NoteTy (UsgNote usg) ty'')
Nothing -> split ty ty []
where
- split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
- split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
- split orig_ty t tvs = (reverse tvs, orig_ty)
+ split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+ split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
+ split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs
+ split orig_ty t tvs = (reverse tvs, orig_ty)
\end{code}
-@mkPiType@ makes a (->) type or a forall type, depending on whether
-it is given a type variable or a term variable.
-
-\begin{code}
-mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
-mkPiType v ty | isId v = mkFunTy (idType v) ty
- | otherwise = mkForAllTy v ty
-\end{code}
+-- (mkPiType now in CoreUtils)
Applying a for-all to its arguments
applyTy :: Type -> Type -> Type
applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg)
+applyTy (PredTy p) arg = applyTy (predRepTy p) arg
applyTy (NoteTy _ fun) arg = applyTy fun arg
applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
substTy (mkTyVarSubst [tv] [arg]) ty
args = case split fun_ty args of
(tvs, ty) -> (tvs, NoteTy note ty)
split (NoteTy _ fun_ty) args = split fun_ty args
+ split (PredTy p) args = split (predRepTy p) args
split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
text "in application of" <+> pprType fun_ty)
case split fun_ty args of
%* *
%************************************************************************
-\begin{code}
-type RhoType = Type
-type TauType = Type
-data PredType = Class Class [Type]
- | IParam Name Type
-type ThetaType = [PredType]
-type ClassPred = (Class, [Type])
-type ClassContext = [ClassPred]
-type SigmaType = Type
-\end{code}
-
-\begin{code}
-instance Outputable PredType where
- ppr = pprPred
-\end{code}
+"Dictionary" types are just ordinary data types, but you can
+tell from the type constructor whether it's a dictionary or not.
\begin{code}
mkClassPred clas tys = Class clas tys
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = mkPredTy (Class clas tys)
+
+mkDictTys :: ClassContext -> [Type]
+mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
+
+mkPredTy :: PredType -> Type
+mkPredTy pred = PredTy pred
+
+predRepTy :: PredType -> Type
+-- Convert a predicate to its "representation type";
+-- the type of evidence for that predicate, which is actually passed at runtime
+predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys
+predRepTy (IParam n ty) = ty
+
+isPredTy :: Type -> Bool
+isPredTy (NoteTy _ ty) = isPredTy ty
+isPredTy (PredTy _) = True
+isPredTy _ = False
+
+isDictTy :: Type -> Bool
+isDictTy (NoteTy _ ty) = isDictTy ty
+isDictTy (PredTy (Class _ _)) = True
+isDictTy other = False
+
+splitPredTy_maybe :: Type -> Maybe PredType
+splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
+splitPredTy_maybe (PredTy p) = Just p
+splitPredTy_maybe other = Nothing
+
+splitDictTy_maybe :: Type -> Maybe (Class, [Type])
+splitDictTy_maybe ty = case splitPredTy_maybe ty of
+ Just p -> getClassTys_maybe p
+ Nothing -> Nothing
+
getClassTys_maybe :: PredType -> Maybe ClassPred
getClassTys_maybe (Class clas tys) = Just (clas, tys)
-getClassTys_maybe _ = Nothing
+getClassTys_maybe _ = Nothing
ipName_maybe :: PredType -> Maybe Name
ipName_maybe (IParam n _) = Just n
ipName_maybe _ = Nothing
+classesToPreds :: ClassContext -> ThetaType
classesToPreds cts = map (uncurry Class) cts
-classesOfPreds theta = concatMap cvt theta
- where cvt (Class clas tys) = [(clas, tys)]
- cvt (IParam _ _ ) = []
+classesOfPreds :: ThetaType -> ClassContext
+classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
\end{code}
@isTauTy@ tests for nested for-alls.
\begin{code}
isTauTy :: Type -> Bool
-isTauTy (TyVarTy v) = True
+isTauTy (TyVarTy v) = True
isTauTy (TyConApp _ tys) = all isTauTy tys
-isTauTy (AppTy a b) = isTauTy a && isTauTy b
-isTauTy (FunTy a b) = isTauTy a && isTauTy b
-isTauTy (NoteTy _ ty) = isTauTy ty
-isTauTy other = False
+isTauTy (AppTy a b) = isTauTy a && isTauTy b
+isTauTy (FunTy a b) = isTauTy a && isTauTy b
+isTauTy (PredTy p) = isTauTy (predRepTy p)
+isTauTy (NoteTy _ ty) = isTauTy ty
+isTauTy other = False
\end{code}
\begin{code}
splitRhoTy ty = split ty ty []
where
split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
- Just p -> split res res (p:ts)
- Nothing -> (reverse ts, orig_ty)
- split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
- split orig_ty ty ts = (reverse ts, orig_ty)
+ Just p -> split res res (p:ts)
+ Nothing -> (reverse ts, orig_ty)
+ split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
+ split orig_ty ty ts = (reverse ts, orig_ty)
\end{code}
+isSigmaType returns true of any qualified type. It doesn't *necessarily* have
+any foralls. E.g.
+ f :: (?x::Int) => Int -> Int
\begin{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
+isSigmaTy :: Type -> Bool
+isSigmaTy (ForAllTy tyvar ty) = True
+isSigmaTy (FunTy a b) = isPredTy a
+isSigmaTy (NoteTy _ ty) = isSigmaTy ty
+isSigmaTy _ = False
+
splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
splitSigmaTy ty =
(tyvars, theta, tau)
(theta,tau) = splitRhoTy rho
\end{code}
+\begin{code}
+getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
+ -- construct a dictionary function name
+getDFunTyKey (TyVarTy tv) = getOccName tv
+getDFunTyKey (TyConApp tc _) = getOccName tc
+getDFunTyKey (AppTy fun _) = getDFunTyKey fun
+getDFunTyKey (NoteTy _ t) = getDFunTyKey t
+getDFunTyKey (FunTy arg _) = getOccName funTyCon
+getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
+-- PredTy shouldn't happen
+\end{code}
+
%************************************************************************
%* *
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
typeKind (NoteTy _ ty) = typeKind ty
+typeKind (PredTy _) = boxedTypeKind -- Predicates are always
+ -- represented by boxed types
typeKind (AppTy fun arg) = funResultTy (typeKind fun)
-typeKind (FunTy arg res) = boxedTypeKind -- A function is boxed regardless of its result type
- -- No functions at the type level, hence we don't need
- -- to say (typeKind res).
+typeKind (FunTy arg res) = fix_up (typeKind res)
+ where
+ fix_up (TyConApp tycon _) | tycon == typeCon
+ || tycon == openKindCon = boxedTypeKind
+ fix_up (NoteTy _ kind) = fix_up kind
+ fix_up kind = kind
+ -- The basic story is
+ -- typeKind (FunTy arg res) = typeKind res
+ -- But a function is boxed regardless of its result type
+ -- Hence the strange fix-up.
+ -- Note that 'res', being the result of a FunTy, can't have
+ -- a strange kind like (*->*).
typeKind (ForAllTy tv ty) = typeKind ty
\end{code}
Free variables of a type
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tyVarsOfType :: Type -> TyVarSet
+tyVarsOfType :: Type -> TyVarSet
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
-tyVarsOfType (NoteTy (IPNote _) ty) = tyVarsOfType ty
+tyVarsOfType (PredTy p) = tyVarsOfPred p
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
namesOfTypes tys
namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
namesOfType (NoteTy other_note ty2) = namesOfType ty2
+namesOfType (PredTy p) = namesOfType (predRepTy p)
namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
+ go (PredTy p) = PredTy (go_pred p)
go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
go_note note@(UsgNote _) = note -- Usage annotation is already tidy
go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
- go_note (IPNote n) = IPNote (tidyIPName n)
-tidyTypes env tys = map (tidyType env) tys
+ go_pred (Class c tys) = Class c (tidyTypes env tys)
+ go_pred (IParam n ty) = IParam n (go ty)
+
+tidyTypes env tys = map (tidyType env) tys
\end{code}
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
-\begin{code}
-tidyIPName :: Name -> Name
-tidyIPName name
- = mkLocalName (getUnique name) (getOccName name) noSrcLoc
-\end{code}
%************************************************************************
seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
seqType (NoteTy note t2) = seqNote note `seq` seqType t2
+seqType (PredTy p) = seqPred p
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
seqNote (SynNote ty) = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqNote (UsgNote usg) = usg `seq` ()
-seqNote (IPNote nm) = nm `seq` ()
+
+seqPred :: PredType -> ()
+seqPred (Class c tys) = c `seq` seqTypes tys
+seqPred (IParam n ty) = n `seq` seqType ty
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Equality on types}
+%* *
+%************************************************************************
+
+
+For the moment at least, type comparisons don't work if
+there are embedded for-alls.
+
+\begin{code}
+instance Eq Type where
+ ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
+
+instance Ord Type where
+ compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
+
+cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
+ -- The "env" maps type variables in ty1 to type variables in ty2
+ -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
+ -- we in effect substitute tv2 for tv1 in t1 before continuing
+
+ -- Get rid of NoteTy
+cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
+cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
+
+ -- Get rid of PredTy
+cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
+cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
+cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
+
+ -- Deal with equal constructors
+cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
+ Just tv1a -> tv1a `compare` tv2
+ Nothing -> tv1 `compare` tv2
+
+cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
+cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
+cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
+cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
+
+ -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
+cmpTy env (AppTy _ _) (TyVarTy _) = GT
+
+cmpTy env (FunTy _ _) (TyVarTy _) = GT
+cmpTy env (FunTy _ _) (AppTy _ _) = GT
+
+cmpTy env (TyConApp _ _) (TyVarTy _) = GT
+cmpTy env (TyConApp _ _) (AppTy _ _) = GT
+cmpTy env (TyConApp _ _) (FunTy _ _) = GT
+
+cmpTy env (ForAllTy _ _) other = GT
+
+cmpTy env _ _ = LT
+
+
+cmpTys env [] [] = EQ
+cmpTys env (t:ts) [] = GT
+cmpTys env [] (t:ts) = LT
+cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
+\end{code}
+
+\begin{code}
+instance Eq PredType where
+ p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
+
+instance Ord PredType where
+ compare p1 p2 = cmpPred emptyVarEnv p1 p2
+
+cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
+cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
+ -- Just compare the names!
+cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
+cmpPred env (IParam _ _) (Class _ _) = LT
+cmpPred env (Class _ _) (IParam _ _) = GT
+\end{code}
projects / ghc-hetmet.git / blobdiff