Kind, TyVarSubst,
superKind, superBoxity, -- KX and BX respectively
- boxedBoxity, unboxedBoxity, -- :: BX
+ liftedBoxity, unliftedBoxity, -- :: BX
openKindCon, -- :: KX
typeCon, -- :: BX -> KX
- boxedTypeKind, unboxedTypeKind, openTypeKind, -- :: KX
+ liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
funTyCon,
isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
isUsageKind, isUsage, isUTyVar,
- -- Predicates and the like
- mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
- splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
-
mkSynTy, deNoteType,
repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, hoistForAllTys, isForAllTy,
- TauType, RhoType, SigmaType, PredType(..), ThetaType,
- ClassPred, ClassContext, mkClassPred,
- getClassTys_maybe, ipName_maybe, classesOfPreds,
- isTauTy, mkRhoTy, splitRhoTy,
+ -- Predicates and the like
+ PredType(..), getClassPredTys_maybe, getClassPredTys,
+ isClassPred, isTyVarClassPred,
+ mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique,
+ splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
+ mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
+
+ -- Tau, Rho, Sigma
+ TauType, RhoType, SigmaType, ThetaType,
+ isTauTy, mkRhoTy, splitRhoTy, splitMethodTy,
mkSigmaTy, isSigmaTy, splitSigmaTy,
getDFunTyKey,
-- Lifting and boxity
- isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
+ isUnLiftedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
namesOfType, usageAnnOfType, typeKind, addFreeTyVars,
+ namesOfDFunHead,
-- Tidying up for printing
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
- tidyTyVar, tidyTyVars,
- tidyTopType,
+ tidyTyVar, tidyTyVars, tidyFreeTyVars,
+ tidyTopType, tidyPred,
-- Seq
seqType, seqTypes
import VarEnv
import VarSet
+import OccName ( mkDictOcc )
import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
import NameSet
-import Class ( classTyCon, Class, ClassPred, ClassContext )
+import Class ( classTyCon, Class )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
-- others
import Maybes ( maybeToBool )
-import SrcLoc ( noSrcLoc )
-import PrimRep ( PrimRep(..), isFollowableRep )
-import Unique ( Uniquable(..) )
+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
defaultKind :: Kind -> Kind
-- Used when generalising: default kind '?' to '*'
-defaultKind kind | kind == openTypeKind = boxedTypeKind
+defaultKind kind | kind == openTypeKind = liftedTypeKind
| otherwise = kind
\end{code}
deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
deNotePred :: PredType -> PredType
-deNotePred (Class c tys) = Class c (map deNoteType tys)
-deNotePred (IParam n ty) = IParam n (deNoteType ty)
+deNotePred (ClassP c tys) = ClassP c (map deNoteType tys)
+deNotePred (IParam n ty) = IParam n (deNoteType ty)
\end{code}
Notes on type synonyms
%************************************************************************
%* *
-\subsection{Stuff to do with the source-language types}
-
-PredType and ThetaType are used in types for expressions and bindings.
-ClassPred and ClassContext are used in class and instance declarations.
+\subsection{Predicates}
%* *
%************************************************************************
\begin{code}
mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
- Class clas tys
+ ClassP clas tys
+
+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 (Class clas tys)
-
-mkDictTys :: ClassContext -> [Type]
-mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
+ 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 (Class clas tys) = TyConApp (classTyCon clas) tys
-predRepTy (IParam n ty) = ty
+predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys
+predRepTy (IParam n ty) = ty
isPredTy :: Type -> Bool
isPredTy (NoteTy _ ty) = isPredTy ty
isPredTy _ = False
isDictTy :: Type -> Bool
-isDictTy (NoteTy _ ty) = isDictTy ty
-isDictTy (PredTy (Class _ _)) = True
-isDictTy (UsageTy _ ty) = isDictTy ty
-isDictTy other = False
+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
splitDictTy :: Type -> (Class, [Type])
splitDictTy (NoteTy _ ty) = splitDictTy ty
-splitDictTy (PredTy (Class clas tys)) = (clas, tys)
+splitDictTy (PredTy (ClassP clas tys)) = (clas, tys)
splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty)
-splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
-splitDictTy_maybe other = Nothing
+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
case splitDictTy tau of { (clas, tys) ->
(tvs, theta, clas, tys) }}
-getClassTys_maybe :: PredType -> Maybe ClassPred
-getClassTys_maybe (Class clas tys) = Just (clas, tys)
-getClassTys_maybe _ = Nothing
-
-ipName_maybe :: PredType -> Maybe Name
-ipName_maybe (IParam n _) = Just n
-ipName_maybe _ = Nothing
-
-classesOfPreds :: ThetaType -> ClassContext
-classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
+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}
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.
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 (PredTy _) = liftedTypeKind -- Predicates are always
+ -- represented by lifted types
typeKind (AppTy fun arg) = funResultTy (typeKind fun)
typeKind (FunTy arg res) = fix_up (typeKind res)
where
fix_up (TyConApp tycon _) | tycon == typeCon
- || tycon == openKindCon = boxedTypeKind
+ || 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 boxed regardless of its result type
+ -- 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 (*->*).
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
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 (go_pred p)
+ 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)
go_note (SynNote ty) = SynNote SAPPLY (go ty)
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
- 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
+
+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
%************************************************************************
%* *
-\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#
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqPred :: PredType -> ()
-seqPred (Class c tys) = c `seq` seqTypes tys
-seqPred (IParam n ty) = n `seq` seqType ty
+seqPred (ClassP c tys) = c `seq` seqTypes tys
+seqPred (IParam n ty) = n `seq` seqType ty
\end{code}
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
+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