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
+ liftedBoxity, unliftedBoxity, -- :: BX
+ openKindCon, -- :: KX
+ typeCon, -- :: BX -> KX
+ liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
+ mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
funTyCon,
+ usageKindCon, -- :: KX
+ usageTypeKind, -- :: KX
+ usOnceTyCon, usManyTyCon, -- :: $
+ usOnce, usMany, -- :: $
+
-- exports from this module:
- hasMoreBoxityInfo,
+ hasMoreBoxityInfo, defaultKind,
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
- mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN,
+ mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
funResultTy, funArgTy, zipFunTys,
- mkTyConApp, mkTyConTy, splitTyConApp_maybe,
+ mkTyConApp, mkTyConTy,
+ tyConAppTyCon, tyConAppArgs,
+ splitTyConApp_maybe, splitTyConApp,
splitAlgTyConApp_maybe, splitAlgTyConApp,
- mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy,
- mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe,
+ mkUTy, splitUTy, splitUTy_maybe,
+ isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
+ isUsageKind, isUsage, isUTyVar,
+
+ mkSynTy, deNoteType,
- UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
- mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
+ repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- isForAllTy, applyTy, applyTys, mkPiType,
+ applyTy, applyTys, hoistForAllTys, isForAllTy,
+
+ -- Predicates and the like
+ PredType(..), getClassPredTys_maybe, getClassPredTys,
+ isPredTy, isClassPred, isTyVarClassPred,
+ mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique,
+ splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
+ mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
- TauType, RhoType, SigmaType, PredType(..), ThetaType,
- ClassPred, ClassContext, mkClassPred,
- getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
- isTauTy, mkRhoTy, splitRhoTy,
- mkSigmaTy, splitSigmaTy,
+ -- Tau, Rho, Sigma
+ TauType, RhoType, SigmaType, ThetaType,
+ isTauTy, mkRhoTy, splitRhoTy, splitMethodTy,
+ mkSigmaTy, isSigmaTy, splitSigmaTy,
+ getDFunTyKey,
-- Lifting and boxity
- isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
- typePrimRep,
+ isUnLiftedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- namesOfType, typeKind, addFreeTyVars,
+ namesOfType, usageAnnOfType, typeKind, addFreeTyVars,
+ namesOfDFunHead,
-- Tidying up for printing
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
- tidyTyVar, tidyTyVars,
- tidyTopType,
+ tidyTyVar, tidyTyVars, tidyFreeTyVars,
+ tidyTopType, tidyPred,
-- Seq
seqType, seqTypes
-- Other imports:
-import {-# SOURCE #-} DataCon( DataCon, dataConType )
-import {-# SOURCE #-} PprType( pprType, pprPred ) -- Only called in debug messages
+import {-# SOURCE #-} DataCon( DataCon )
+import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
-import Var ( TyVar, IdOrTyVar, UVar,
- tyVarKind, tyVarName, setTyVarName, isId, idType,
- )
+import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
import VarEnv
import VarSet
-import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
- )
+import OccName ( mkDictOcc )
+import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
import NameSet
import Class ( classTyCon, Class )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isDataTyCon, isNewTyCon,
+ isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
- tyConPrimRep, tyConClass_maybe
+ tyConPrimRep
)
-- others
-import SrcLoc ( noSrcLoc )
import Maybes ( maybeToBool )
-import PrimRep ( PrimRep(..), isFollowableRep )
-import Unique ( Uniquable(..) )
-import Util ( mapAccumL, seqList )
+import SrcLoc ( SrcLoc, noSrcLoc )
+import PrimRep ( PrimRep(..) )
+import Unique ( Unique, Uniquable(..) )
+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 = liftedTypeKind
+ | 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 ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
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 ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
getTyVar_maybe other = Nothing
isTyVarTy :: Type -> Bool
isTyVarTy (TyVarTy tv) = True
isTyVarTy (NoteTy _ ty) = isTyVarTy ty
+isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
+isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
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
+ = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
+ UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
+ -- argument must be unannotated
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
+ mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
mk_app ty1 = AppTy orig_ty1 orig_ty2
mkAppTys :: Type -> [Type] -> Type
mkAppTys orig_ty1 [] = orig_ty1
-- This check for an empty list of type arguments
- -- avoids the needless of a type synonym constructor.
+ -- avoids the needless loss of a type synonym constructor.
-- 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
+ = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
+ UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
+ -- arguments must be unannotated
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
- mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
- foldl AppTy orig_ty1 orig_tys2
+ mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
+ mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
splitAppTy_maybe :: Type -> Maybe (Type, Type)
-splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
+splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy 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
split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
split (ty:tys) acc = split tys (ty:acc)
+splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
splitAppTy_maybe other = Nothing
splitAppTy :: Type -> (Type, Type)
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])
+ (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
+ split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
split orig_ty ty args = (orig_ty, args)
\end{code}
\begin{code}
mkFunTy :: Type -> Type -> Type
-mkFunTy arg res = FunTy arg res
+mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
+ FunTy arg res
mkFunTys :: [Type] -> Type -> Type
-mkFunTys tys ty = foldr FunTy ty tys
+mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
+ foldr FunTy ty tys
+
+splitFunTy :: Type -> (Type, Type)
+splitFunTy (FunTy arg res) = (arg, res)
+splitFunTy (NoteTy _ ty) = splitFunTy ty
+splitFunTy (PredTy p) = splitFunTy (predRepTy p)
+splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
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 ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
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 (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
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 (UsageTy _ _) = pprPanic "splitFunTysN: UTy:" (pprType orig_ty)
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 xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
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 (UsageTy _ ty) = funResultTy ty
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 (UsageTy _ ty) = funArgTy ty
funArgTy ty = pprPanic "funArgTy" (pprType ty)
\end{code}
mkTyConApp tycon tys
| isFunTyCon tycon && length tys == 2
= case tys of
- (ty1:ty2:_) -> FunTy ty1 ty2
+ (ty1:ty2:_) -> FunTy (mkUTyM ty1) (mkUTyM ty2)
| otherwise
= ASSERT(not (isSynTyCon tycon))
+ UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
TyConApp tycon tys
mkTyConTy :: TyCon -> Type
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..
+tyConAppTyCon :: Type -> TyCon
+tyConAppTyCon ty = case splitTyConApp_maybe ty of
+ Just (tc,_) -> tc
+ Nothing -> pprPanic "tyConAppTyCon" (pprType ty)
+
+tyConAppArgs :: Type -> [Type]
+tyConAppArgs ty = case splitTyConApp_maybe ty of
+ Just (_,args) -> args
+ Nothing -> pprPanic "tyConAppArgs" (pprType ty)
+
+splitTyConApp :: Type -> (TyCon, [Type])
+splitTyConApp ty = case splitTyConApp_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic "splitTyConApp" (pprType ty)
+
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
+splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
+splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
+splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
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 (UsageTy _ ty)= splitAlgTyConApp_maybe ty
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)
+splitAlgTyConApp (UsageTy _ ty) = splitAlgTyConApp ty
+#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
\begin{code}
mkSynTy syn_tycon tys
= ASSERT( isSynTyCon syn_tycon )
- ASSERT( isNotUsgTy body )
ASSERT( length tyvars == length tys )
NoteTy (SynNote (TyConApp syn_tycon tys))
(substTy (mkTyVarSubst tyvars tys) body)
where
(tyvars, body) = getSynTyConDefn syn_tycon
-isSynTy (NoteTy (SynNote _) _) = True
-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 (deNotePred p)
deNoteType (NoteTy _ ty) = deNoteType ty
deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
+deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
+
+deNotePred :: PredType -> PredType
+deNotePred (ClassP c tys) = ClassP c (map deNoteType tys)
+deNotePred (IParam n ty) = IParam n (deNoteType ty)
\end{code}
Notes on type synonyms
interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
+ Representation types
+ ~~~~~~~~~~~~~~~~~~~~
repType looks through
(a) for-alls, and
(b) newtypes
-in addition to synonyms. It's useful in the back end where we're not
+ (c) synonyms
+ (d) predicates
+ (e) usage annotations
+It's useful in the back end where we're not
interested in newtypes anymore.
\begin{code}
repType :: Type -> Type
-repType (NoteTy _ ty) = repType ty
-repType (ForAllTy _ ty) = repType ty
-repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys)
-repType other_ty = other_ty
+repType (ForAllTy _ ty) = repType ty
+repType (NoteTy _ ty) = repType ty
+repType (PredTy p) = repType (predRepTy p)
+repType (UsageTy _ ty) = repType ty
+repType ty = case splitNewType_maybe ty of
+ Just ty' -> repType ty' -- Still re-apply repType in case of for-all
+ Nothing -> ty
+
+splitRepFunTys :: Type -> ([Type], Type)
+-- Like splitFunTys, but looks through newtypes and for-alls
+splitRepFunTys ty = split [] (repType ty)
+ where
+ split args (FunTy arg res) = split (arg:args) (repType res)
+ split args ty = (reverse args, ty)
+
+typePrimRep :: Type -> PrimRep
+typePrimRep ty = case repType ty of
+ TyConApp tc _ -> tyConPrimRep tc
+ FunTy _ _ -> PtrRep
+ AppTy _ _ -> PtrRep -- ??
+ TyVarTy _ -> PtrRep
splitNewType_maybe :: Type -> Maybe Type
-- Find the representation of a newtype, if it is one
--- Looks through multiple levels of newtype
-splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
-splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
- Just rep_ty' -> Just rep_ty'
- Nothing -> Just rep_ty
- where
- rep_ty = new_type_rep tc tys
-
-splitNewType_maybe other = Nothing
-
-new_type_rep :: TyCon -> [Type] -> Type
--- The representation type for (T t1 .. tn), where T is a newtype
--- Looks through one layer only
-new_type_rep tc tys
- = ASSERT( isNewTyCon tc )
- case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
- Just (rep_ty, _) -> rep_ty
+-- 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 (UsageTy _ ty) = splitNewType_maybe ty
+splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
+ Just rep_ty -> ASSERT( length tys == tyConArity tc )
+ -- The assert should hold because repType should
+ -- only be applied to *types* (of kind *)
+ Just (applyTys rep_ty tys)
+ Nothing -> Nothing
+splitNewType_maybe other = Nothing
\end{code}
---------------------------------------------------------------------
- UsgNote
- ~~~~~~~
-
-NB: Invariant: if present, usage note is at the very top of the type.
-This should be carefully preserved.
-
-In some parts of the compiler, comments use the _Once Upon a
-Polymorphic Type_ (POPL'99) usage of "rho = generalised
-usage-annotated type; sigma = usage-annotated type; tau =
-usage-annotated type except on top"; unfortunately this conflicts with
-the rho/tau/theta/sigma usage in the rest of the compiler. (KSW
-1999-07)
-
-\begin{code}
-mkUsgTy :: UsageAnn -> Type -> Type
-#ifndef USMANY
-mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
- ty
-#endif
-mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty )
- NoteTy (UsgNote usg) ty
-
--- The isUsgTy function is utterly useless if UsManys are omitted.
--- Be warned! KSW 1999-04.
-isUsgTy :: Type -> Bool
-#ifndef USMANY
-isUsgTy _ = True
-#else
-isUsgTy (NoteTy (UsgForAll _) ty) = isUsgTy ty
-isUsgTy (NoteTy (UsgNote _) _ ) = True
-isUsgTy other = False
-#endif
-
--- The isNotUsgTy function may return a false True if UsManys are omitted;
--- in other words, A SSERT( isNotUsgTy ty ) may be useful but
--- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
-isNotUsgTy :: Type -> Bool
-isNotUsgTy (NoteTy (UsgForAll _) _) = False
-isNotUsgTy (NoteTy (UsgNote _) _) = False
-isNotUsgTy other = True
-
--- splitUsgTy_maybe is not exported, since it is meaningless if
--- UsManys are omitted. It is used in several places in this module,
--- however. KSW 1999-04.
-splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
-splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
- Just (usg,ty2)
-splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty
-splitUsgTy_maybe ty = Nothing
-
-splitUsgTy :: Type -> (UsageAnn,Type)
-splitUsgTy ty = case splitUsgTy_maybe ty of
- Just ans -> ans
- Nothing ->
-#ifndef USMANY
- (UsMany,ty)
-#else
- pprPanic "splitUsgTy: no usage annot:" $ pprType ty
-#endif
-
-tyUsg :: Type -> UsageAnn
-tyUsg = fst . splitUsgTy
-
-unUsgTy :: Type -> Type
--- strip outer usage annotation if present
-unUsgTy ty = case splitUsgTy_maybe ty of
- Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
- ty1
- Nothing -> ty
-
-mkUsForAllTy :: UVar -> Type -> Type
-mkUsForAllTy uv ty = NoteTy (UsgForAll uv) ty
-
-mkUsForAllTys :: [UVar] -> Type -> Type
-mkUsForAllTys uvs ty = foldr (NoteTy . UsgForAll) ty uvs
-
-splitUsForAllTys :: Type -> ([UVar],Type)
-splitUsForAllTys ty = split ty []
- where split (NoteTy (UsgForAll u) ty) uvs = split ty (u:uvs)
- split other_ty uvs = (reverse uvs, other_ty)
-
-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)
-\end{code}
-
-
----------------------------------------------------------------------
ForAllTy
~~~~~~~~
-We need to be clever here with usage annotations; they need to be
-lifted or lowered through the forall as appropriate.
-
\begin{code}
mkForAllTy :: TyVar -> Type -> Type
-mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
- Just (usg,ty') -> NoteTy (UsgNote usg)
- (ForAllTy tyvar ty')
- Nothing -> ForAllTy tyvar ty
+mkForAllTy tyvar ty
+ = mkForAllTys [tyvar] ty
mkForAllTys :: [TyVar] -> Type -> Type
-mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
- Just (usg,ty') -> NoteTy (UsgNote usg)
- (foldr ForAllTy ty' tyvars)
- Nothing -> foldr ForAllTy ty tyvars
+mkForAllTys tyvars ty
+ = case splitUTy_maybe ty of
+ Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
+ ptext SLIT("mkForAllTys: usage scope")
+ <+> ppr tyvars <+> pprType ty )
+ mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
+ Nothing -> foldr ForAllTy ty tyvars
+
+isForAllTy :: Type -> Bool
+isForAllTy (NoteTy _ ty) = isForAllTy ty
+isForAllTy (ForAllTy _ _) = True
+isForAllTy (UsageTy _ ty) = isForAllTy ty
+isForAllTy other_ty = False
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
-splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
- Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
- return (tyvar, NoteTy (UsgNote usg) ty'')
- Nothing -> splitFAT_m ty
+splitForAllTy_maybe ty = 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 (UsageTy _ ty) = splitFAT_m ty
+ splitFAT_m _ = Nothing
splitForAllTys :: Type -> ([TyVar], Type)
-splitForAllTys ty = case splitUsgTy_maybe ty of
- Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
- in (tvs, NoteTy (UsgNote usg) ty'')
- Nothing -> split ty ty []
+splitForAllTys ty = 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 (UsageTy _ ty) tvs = split orig_ty ty 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.
+-- (mkPiType now in CoreUtils)
-\begin{code}
-mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work...
-mkPiType v ty | isId v = mkFunTy (idType v) ty
- | otherwise = mkForAllTy v ty
-\end{code}
-
-Applying a for-all to its arguments
+Applying a for-all to its arguments. Lift usage annotation as required.
\begin{code}
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 )
+applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
+ ptext SLIT("applyTy")
+ <+> pprType ty <+> pprType arg )
substTy (mkTyVarSubst [tv] [arg]) ty
+applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
applyTy other arg = panic "applyTy"
applyTys :: Type -> [Type] -> Type
applyTys fun_ty arg_tys
- = substTy (mkTyVarSubst tvs arg_tys) ty
+ = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
+ (case mu of
+ Just u -> UsageTy u
+ Nothing -> id) $
+ substTy (mkTyVarSubst tvs arg_tys) ty
where
- (tvs, ty) = split fun_ty arg_tys
+ (mu, tvs, ty) = split fun_ty arg_tys
- split fun_ty [] = ([], fun_ty)
- split (NoteTy note@(UsgNote _) fun_ty)
- args = case split fun_ty args of
- (tvs, ty) -> (tvs, NoteTy note ty)
- split (NoteTy note@(UsgForAll _) fun_ty)
- args = case split fun_ty args of
- (tvs, ty) -> (tvs, NoteTy note ty)
+ split fun_ty [] = (Nothing, [], fun_ty)
split (NoteTy _ fun_ty) args = split fun_ty 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
- (tvs, ty) -> (tv:tvs, ty)
+ split (PredTy p) args = split (predRepTy p) args
+ split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
+ (mu, tvs, ty) -> (mu, tv:tvs, ty)
+ split (UsageTy u ty) args = case split ty args of
+ (Nothing, tvs, ty) -> (Just u, tvs, ty)
+ (Just _ , _ , _ ) -> pprPanic "applyTys:"
+ (pprType fun_ty)
split other_ty args = panic "applyTys"
\end{code}
-Note that we allow applications to be of usage-annotated- types, as an
-extension: we handle them by lifting the annotation outside. The
-argument, however, must still be unannotated.
+\begin{code}
+hoistForAllTys :: Type -> Type
+ -- Move all the foralls to the top
+ -- e.g. T -> forall a. a ==> forall a. T -> a
+ -- Careful: LOSES USAGE ANNOTATIONS!
+hoistForAllTys ty
+ = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
+ where
+ hoist :: Type -> ([TyVar], Type)
+ hoist ty = case splitFunTys ty of { (args, res) ->
+ case splitForAllTys res of {
+ ([], body) -> ([], ty) ;
+ (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
+ (tvs1 ++ tvs2, mkFunTys args body2)
+ }}}
+\end{code}
-%************************************************************************
-%* *
-\subsection{Stuff to do with the source-language types}
+---------------------------------------------------------------------
+ UsageTy
+ ~~~~~~~
-PredType and ThetaType are used in types for expressions and bindings.
-ClassPred and ClassContext are used in class and instance declarations.
-%* *
-%************************************************************************
+Constructing and taking apart usage types.
\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
+mkUTy :: Type -> Type -> Type
+mkUTy u ty
+ = ASSERT2( typeKind u == usageTypeKind, ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
+ UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
+ -- if u == usMany then ty else : ToDo? KSW 2000-10
+#ifdef DO_USAGES
+ UsageTy u ty
+#else
+ ty
+#endif
+
+splitUTy :: Type -> (Type {- :: $ -}, Type)
+splitUTy orig_ty
+ = case splitUTy_maybe orig_ty of
+ Just (u,ty) -> (u,ty)
+#ifdef DO_USAGES
+ Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
+#else
+ Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
+#endif
+
+splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
+splitUTy_maybe (UsageTy u ty) = Just (u,ty)
+splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
+splitUTy_maybe other_ty = Nothing
+
+isUTy :: Type -> Bool
+ -- has usage annotation
+isUTy = maybeToBool . splitUTy_maybe
+
+uaUTy :: Type -> Type
+ -- extract annotation
+uaUTy = fst . splitUTy
+
+unUTy :: Type -> Type
+ -- extract unannotated type
+unUTy = snd . splitUTy
\end{code}
\begin{code}
-instance Outputable PredType where
- ppr = pprPred
+liftUTy :: (Type -> Type) -> Type -> Type
+ -- lift outer usage annot over operation on unannotated types
+liftUTy f ty
+ = let
+ (u,ty') = splitUTy ty
+ in
+ mkUTy u (f ty')
\end{code}
\begin{code}
-mkClassPred clas tys = Class clas tys
+mkUTyM :: Type -> Type
+ -- put TOP (no info) annotation on unannotated type
+mkUTyM ty = mkUTy usMany ty
+\end{code}
-getClassTys_maybe :: PredType -> Maybe ClassPred
-getClassTys_maybe (Class clas tys) = Just (clas, tys)
-getClassTys_maybe _ = Nothing
+\begin{code}
+isUsageKind :: Kind -> Bool
+isUsageKind k
+ = ASSERT( typeKind k == superKind )
+ k == usageTypeKind
+
+isUsage :: Type -> Bool
+isUsage ty
+ = isUsageKind (typeKind ty)
+
+isUTyVar :: Var -> Bool
+isUTyVar v
+ = isUsageKind (tyVarKind v)
+\end{code}
-ipName_maybe :: PredType -> Maybe Name
-ipName_maybe (IParam n _) = Just n
-ipName_maybe _ = Nothing
-classesToPreds cts = map (uncurry Class) cts
+%************************************************************************
+%* *
+\subsection{Predicates}
+%* *
+%************************************************************************
+
+"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 = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
+ ClassP clas tys
-classesOfPreds theta = concatMap cvt theta
- where cvt (Class clas tys) = [(clas, tys)]
- cvt (IParam _ _ ) = []
+isClassPred (ClassP clas tys) = True
+isClassPred other = False
+
+isIPPred (IParam _ _) = True
+isIPPred other = False
+
+isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys
+isTyVarClassPred other = False
+
+getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
+getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
+getClassPredTys_maybe _ = Nothing
+
+getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys (ClassP clas tys) = (clas, tys)
+
+inheritablePred :: PredType -> Bool
+-- Can be inherited by a context. For example, consider
+-- f x = let g y = (?v, y+x)
+-- in (g 3 with ?v = 8,
+-- g 4 with ?v = 9)
+-- The point is that g's type must be quantifed over ?v:
+-- g :: (?v :: a) => a -> a
+-- but it doesn't need to be quantified over the Num a dictionary
+-- which can be free in g's rhs, and shared by both calls to g
+inheritablePred (ClassP _ _) = True
+inheritablePred other = False
+
+predMentionsIPs :: PredType -> NameSet -> Bool
+predMentionsIPs (IParam n _) ns = n `elemNameSet` ns
+predMentionsIPs other ns = False
+
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
+ mkPredTy (ClassP clas tys)
+
+mkPredTy :: PredType -> Type
+mkPredTy pred = PredTy pred
+
+mkPredTys :: ThetaType -> [Type]
+mkPredTys preds = map PredTy preds
+
+predTyUnique :: PredType -> Unique
+predTyUnique (IParam n _) = getUnique n
+predTyUnique (ClassP clas tys) = getUnique clas
+
+predRepTy :: PredType -> Type
+-- Convert a predicate to its "representation type";
+-- the type of evidence for that predicate, which is actually passed at runtime
+predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys
+predRepTy (IParam n ty) = ty
+
+isPredTy :: Type -> Bool
+isPredTy (NoteTy _ ty) = isPredTy ty
+isPredTy (PredTy _) = True
+isPredTy (UsageTy _ ty)= isPredTy ty
+isPredTy _ = False
+
+isDictTy :: Type -> Bool
+isDictTy (NoteTy _ ty) = isDictTy ty
+isDictTy (PredTy (ClassP _ _)) = True
+isDictTy (UsageTy _ ty) = isDictTy ty
+isDictTy other = False
+
+splitPredTy_maybe :: Type -> Maybe PredType
+splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
+splitPredTy_maybe (PredTy p) = Just p
+splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty
+splitPredTy_maybe other = Nothing
+
+splitDictTy :: Type -> (Class, [Type])
+splitDictTy (NoteTy _ ty) = splitDictTy ty
+splitDictTy (PredTy (ClassP clas tys)) = (clas, tys)
+
+splitDictTy_maybe :: Type -> Maybe (Class, [Type])
+splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
+splitDictTy_maybe (PredTy (ClassP clas tys)) = Just (clas, tys)
+splitDictTy_maybe other = Nothing
+
+splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
+-- Split the type of a dictionary function
+splitDFunTy ty
+ = case splitSigmaTy ty of { (tvs, theta, tau) ->
+ case splitDictTy tau of { (clas, tys) ->
+ (tvs, theta, clas, tys) }}
+
+namesOfDFunHead :: Type -> NameSet
+-- Find the free type constructors and classes
+-- of the head of the dfun instance type
+-- The 'dfun_head_type' is because of
+-- instance Foo a => Baz T where ...
+-- The decl is an orphan if Baz and T are both not locally defined,
+-- even if Foo *is* locally defined
+namesOfDFunHead dfun_ty = case splitSigmaTy dfun_ty of
+ (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
+ (map getName tvs)
+
+mkPredName :: Unique -> SrcLoc -> PredType -> Name
+mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
+mkPredName uniq loc (IParam name ty) = name
\end{code}
+%************************************************************************
+%* *
+\subsection{Tau, sigma and rho}
+%* *
+%************************************************************************
+
@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 (UsageTy _ ty) = isTauTy ty
+isTauTy other = False
\end{code}
\begin{code}
mkRhoTy :: [PredType] -> Type -> Type
-mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
+mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty )
+ foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta
splitRhoTy :: Type -> ([PredType], Type)
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 (UsageTy _ ty) ts = split orig_ty ty ts
+ split orig_ty ty ts = (reverse ts, orig_ty)
+\end{code}
+
+The type of a method for class C is always of the form:
+ Forall a1..an. C a1..an => sig_ty
+where sig_ty is the type given by the method's signature, and thus in general
+is a ForallTy. At the point that splitMethodTy is called, it is expected
+that the outer Forall has already been stripped off. splitMethodTy then
+returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
+Usages stripped off.
+
+\begin{code}
+splitMethodTy :: Type -> (PredType, Type)
+splitMethodTy ty = split ty
+ where
+ split (FunTy arg res) = case splitPredTy_maybe arg of
+ Just p -> (p, res)
+ Nothing -> panic "splitMethodTy"
+ split (NoteTy _ ty) = split ty
+ split (UsageTy _ ty) = split ty
+ split _ = panic "splitMethodTy"
\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 (UsageTy _ 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
+getDFunTyKey (UsageTy _ 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 _) = liftedTypeKind -- Predicates are always
+ -- represented by lifted 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 = liftedTypeKind
+ 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 lifted 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
+typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
\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
+tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
tyVarsOfTypes :: [Type] -> TyVarSet
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
-tyVarsOfPred (IParam n ty) = tyVarsOfType ty
+tyVarsOfPred (ClassP clas tys) = tyVarsOfTypes tys
+tyVarsOfPred (IParam n ty) = tyVarsOfType ty
tyVarsOfTheta :: ThetaType -> TyVarSet
tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
-- Add a Note with the free tyvars to the top of the type
--- (but under a usage if there is one)
addFreeTyVars :: Type -> Type
-addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
-addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty)
addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
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)
+namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
+namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty
namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
\end{code}
+Usage annotations of a type
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Get a list of usage annotations of a type, *in left-to-right pre-order*.
+
+\begin{code}
+usageAnnOfType :: Type -> [Type]
+usageAnnOfType ty
+ = goS ty
+ where
+ goT (TyVarTy _) = []
+ goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
+ goT (TyConApp tc tys) = concatMap goT tys
+ goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
+ goT (ForAllTy mv ty) = goT ty
+ goT (PredTy p) = goT (predRepTy p)
+ goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
+ goT (NoteTy note ty) = goT ty
+
+ goS sty = case splitUTy sty of
+ (u,tty) -> u : goT tty
+\end{code}
+
%************************************************************************
%* *
where
name = tyVarName tyvar
+tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
+tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
+-- Add the free tyvars to the env in tidy form,
+-- so that we can tidy the type they are free in
+tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
+ where
+ add env tv = fst (tidyTyVar env tv)
+
tidyType :: TidyEnv -> Type -> Type
tidyType env@(tidy_env, subst) ty
= go ty
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 (tidyPred env 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)
where
(envp, tvp) = tidyTyVar env tv
+ go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
go_note (SynNote ty) = SynNote SAPPLY (go 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
+tidyTypes env tys = map (tidyType env) tys
+
+tidyPred :: TidyEnv -> PredType -> PredType
+tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
+tidyPred env (IParam n ty) = IParam n (tidyType env ty)
\end{code}
tidyOpenType env ty
= (env', tidyType env' ty)
where
- env' = foldl go env (varSetElems (tyVarsOfType ty))
- go env tyvar = fst (tidyTyVar env tyvar)
+ env' = tidyFreeTyVars env (tyVarsOfType ty)
tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
-\begin{code}
-tidyIPName :: Name -> Name
-tidyIPName name
- = mkLocalName (getUnique name) (getOccName name) noSrcLoc
-\end{code}
%************************************************************************
%* *
-\subsection{Boxedness and liftedness}
+\subsection{Liftedness}
%* *
%************************************************************************
\begin{code}
-isUnboxedType :: Type -> Bool
-isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
-
isUnLiftedType :: Type -> Bool
-- isUnLiftedType returns True for forall'd unlifted types:
-- x :: forall a. Int#
isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
+isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
isUnLiftedType other = False
isUnboxedTupleType :: Type -> Bool
Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
isNewTyCon tc
other -> False
-
-typePrimRep :: Type -> PrimRep
-typePrimRep ty = case splitTyConApp_maybe (repType ty) of
- Just (tc, ty_args) -> tyConPrimRep tc
- other -> PtrRep
\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
+seqType (UsageTy u ty) = seqType u `seq` seqType ty
seqTypes :: [Type] -> ()
seqTypes [] = ()
seqNote :: TyNote -> ()
seqNote (SynNote ty) = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
-seqNote (UsgNote usg) = usg `seq` ()
-seqNote (IPNote nm) = nm `seq` ()
+
+seqPred :: PredType -> ()
+seqPred (ClassP c tys) = c `seq` seqTypes tys
+seqPred (IParam n ty) = n `seq` seqType ty
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Equality on types}
+%* *
+%************************************************************************
+
+
+\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
+cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2
+
+ -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy
+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 _ _) (TyVarTy _) = GT
+cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
+cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
+cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
+
+cmpTy env (UsageTy _ _) 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 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
+ -- Compare types as well as names for implicit parameters
+ -- This comparison is used exclusively (I think) for the
+ -- finite map built in TcSimplify
+cmpPred env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
+cmpPred env (IParam _ _) (ClassP _ _) = LT
+cmpPred env (ClassP _ _) (IParam _ _) = GT
+\end{code}
projects / ghc-hetmet.git / blobdiff