\begin{code}
module TcType (
--------------------------------
+ -- TyThing
+ TyThing(..), -- instance NamedThing
+
+ --------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcKind,
tcSplitForAllTys, tcSplitPhiTy,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
- tcSplitAppTy_maybe, tcSplitAppTy, tcSplitSigmaTy,
+ tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar,
---------------------------------
tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
isSigmaTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy,
- isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy,
+ isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
isTauTy, tcIsTyVarTy, tcIsForAllTy,
allDistinctTyVars,
---------------------------------
-- Misc type manipulators
- deNoteType,
- namesOfType, namesOfDFunHead,
+ deNoteType, classNamesOfTheta,
+ tyClsNamesOfType, tyClsNamesOfDFunHead,
getDFunTyKey,
---------------------------------
-- Predicate types
- PredType, getClassPredTys_maybe, getClassPredTys,
+ getClassPredTys_maybe, getClassPredTys,
isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
- mkDictTy, tcSplitPredTy_maybe, predTyUnique,
+ mkDictTy, tcSplitPredTy_maybe,
isDictTy, tcSplitDFunTy, predTyUnique,
mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
- typeKind, eqKind, eqUsage,
+ typeKind, eqKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
) where
import {-# SOURCE #-} PprType( pprType )
+-- PprType imports TcType so that it can print intelligently
-- friends:
import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
import Type ( -- Re-exports
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- Kind, Type, SourceType(..), PredType, ThetaType,
- unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
- mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+ tyVarsOfTheta, Kind, Type, SourceType(..),
+ PredType, ThetaType, unliftedTypeKind,
+ liftedTypeKind, openTypeKind, mkArrowKind,
+ mkArrowKinds, mkForAllTy, mkForAllTys,
+ defaultKind, isTypeKind, isAnyTypeKind,
mkFunTy, mkFunTys, zipFunTys, isTyVarTy,
- mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
- mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
- isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
+ mkTyConApp, mkGenTyConApp, mkAppTy,
+ mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
+ mkPredTys, isUnLiftedType,
+ isUnboxedTupleType, isPrimitiveType,
splitNewType_maybe, splitTyConApp_maybe,
- tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
- tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, eqKind, eqUsage,
- hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
+ tidyTopType, tidyType, tidyPred, tidyTypes,
+ tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
+ tidyTyVarBndr, tidyOpenTyVar,
+ tidyOpenTyVars, eqKind,
+ hasMoreBoxityInfo, liftedBoxity,
+ superBoxity, typeKind, superKind, repType
)
+import DataCon ( DataCon )
import TyCon ( TyCon, isUnLiftedTyCon )
import Class ( classHasFDs, Class )
-import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails )
+import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails )
import ForeignCall ( Safety, playSafe )
import VarEnv
import VarSet
import BasicTypes ( IPName(..), ipNameName )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
-import Util ( cmpList, thenCmp, equalLength )
+import Util ( cmpList, thenCmp, equalLength, snocView )
import Maybes ( maybeToBool, expectJust )
import Outputable
\end{code}
%************************************************************************
%* *
+ TyThing
+%* *
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId Id
+ | ADataCon DataCon
+ | ATyCon TyCon
+ | AClass Class
+
+instance NamedThing TyThing where
+ getName (AnId id) = getName id
+ getName (ATyCon tc) = getName tc
+ getName (AClass cl) = getName cl
+ getName (ADataCon dc) = getName dc
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Types}
%* *
%************************************************************************
tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
-tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys
- --- Don't forget that newtype!
+tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys --- Don't forget that newtype!
tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys
tcSplitAppTy_maybe other = Nothing
-tc_split_app tc [] = Nothing
-tc_split_app tc tys = split tys []
- where
- split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
- split (ty:tys) acc = split tys (ty:acc)
+tc_split_app tc tys = case snocView tys of
+ Just (tys',ty') -> Just (TyConApp tc tys', ty')
+ Nothing -> Nothing
tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "tcSplitAppTy" (pprType ty)
+tcSplitAppTys :: Type -> (Type, [Type])
+tcSplitAppTys ty
+ = go ty []
+ where
+ go ty args = case tcSplitAppTy_maybe ty of
+ Just (ty', arg) -> go ty' (arg:args)
+ Nothing -> (ty,args)
+
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe (TyVarTy tv) = Just tv
tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t
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.
+returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
\begin{code}
tcSplitMethodTy :: Type -> (PredType, Type)
\begin{code}
isFloatTy = is_tc floatTyConKey
isDoubleTy = is_tc doubleTyConKey
-isForeignPtrTy = is_tc foreignPtrTyConKey
isIntegerTy = is_tc integerTyConKey
isIntTy = is_tc intTyConKey
isAddrTy = is_tc addrTyConKey
deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys)
\end{code}
-Find the free names of a type, including the type constructors and classes it mentions
-This is used in the front end of the compiler
+Find the free tycons and classes of a type. This is used in the front
+end of the compiler.
\begin{code}
-namesOfType :: Type -> NameSet
-namesOfType (TyVarTy tv) = unitNameSet (getName tv)
-namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` namesOfTypes tys
-namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
-namesOfType (NoteTy other_note ty2) = namesOfType ty2
-namesOfType (SourceTy (IParam n ty)) = namesOfType ty
-namesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` namesOfTypes tys
-namesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` namesOfTypes tys
-namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
-namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
-namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
-
-namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
-
-namesOfDFunHead :: Type -> NameSet
+tyClsNamesOfType :: Type -> NameSet
+tyClsNamesOfType (TyVarTy tv) = emptyNameSet
+tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
+tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
+tyClsNamesOfType (SourceTy (IParam n ty)) = tyClsNamesOfType ty
+tyClsNamesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
+tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
+tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty
+
+tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
+
+tyClsNamesOfDFunHead :: 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 tcSplitSigmaTy dfun_ty of
- (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
- (map getName tvs)
+tyClsNamesOfDFunHead dfun_ty
+ = case tcSplitSigmaTy dfun_ty of
+ (tvs,_,head_ty) -> tyClsNamesOfType head_ty
+
+classNamesOfTheta :: ThetaType -> [Name]
+-- Looks just for ClassP things; maybe it should check
+classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ]
\end{code}
-- Non-recursive ones are transparent to splitTyConApp,
-- but recursive ones aren't; hence the splitNewType_maybe
checkRepTyCon check_tc ty
- | Just ty' <- splitNewType_maybe ty = checkRepTyCon check_tc ty'
- | Just (tc,_) <- splitTyConApp_maybe ty = check_tc tc
- | otherwise = False
+ | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
+ | otherwise = False
\end{code}
----------------------------------------------
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
legalFEArgTyCon tc
- | getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
- byteArrayTyConKey, mutableByteArrayTyConKey ]
+ | getUnique tc `elem` [ byteArrayTyConKey, mutableByteArrayTyConKey ]
= False
-- It's also illegal to make foreign exports that take unboxed
-- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
| getUnique tc `elem`
- [ foreignObjTyConKey, foreignPtrTyConKey,
- byteArrayTyConKey, mutableByteArrayTyConKey ] = False
+ [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
| getUnique tc `elem`
- [ foreignObjTyConKey, foreignPtrTyConKey,
- byteArrayTyConKey, mutableByteArrayTyConKey ] = False
+ [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
, addrTyConKey, ptrTyConKey, funPtrTyConKey
- , charTyConKey, foreignObjTyConKey
- , foreignPtrTyConKey
+ , charTyConKey
, stablePtrTyConKey
, byteArrayTyConKey, mutableByteArrayTyConKey
, boolTyConKey