X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=af03b7aa56ec9c0e41325139ce735036a0e26be5;hb=250be0a30ad58f81b727061d0a390a8168b29bdf;hp=f3e864cfb844209b191e5fca3cab5a8f41214d4f;hpb=1f861358a07a4bf2586964a65aebb4433f16ac70;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index f3e864c..af03b7a 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -16,17 +16,13 @@ is the principal client. \begin{code} module TcType ( -------------------------------- - -- TyThing - TyThing(..), -- instance NamedThing - - -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcKind, -------------------------------- -- TyVarDetails - TyVarDetails(..), isUserTyVar, isSkolemTyVar, + TyVarDetails(..), isUserTyVar, isSkolemTyVar, isExistentialTyVar, tyVarBindingInfo, -------------------------------- @@ -54,16 +50,16 @@ module TcType ( --------------------------------- -- Misc type manipulators - deNoteType, classNamesOfTheta, + deNoteType, classesOfTheta, tyClsNamesOfType, tyClsNamesOfDFunHead, getDFunTyKey, --------------------------------- -- Predicate types getClassPredTys_maybe, getClassPredTys, - isPredTy, isClassPred, isTyVarClassPred, + isClassPred, isTyVarClassPred, mkDictTy, tcSplitPredTy_maybe, - isDictTy, tcSplitDFunTy, predTyUnique, + isPredTy, isDictTy, tcSplitDFunTy, predTyUnique, mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, --------------------------------- @@ -77,6 +73,7 @@ module TcType ( isFFILabelTy, -- :: Type -> Bool isFFIDotnetTy, -- :: DynFlags -> Type -> Bool isFFIDotnetObjTy, -- :: Type -> Bool + isFFITy, -- :: Type -> Bool toDNType, -- :: Type -> DNType @@ -89,10 +86,10 @@ module TcType ( -- Rexported from Type Kind, -- Stuff to do with kinds is insensitive to pre/post Tc unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, - superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, - isTypeKind, isAnyTypeKind, + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isArgTypeKind, isSubKind, defaultKind, - Type, SourceType(..), PredType, ThetaType, + Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, @@ -100,60 +97,63 @@ module TcType ( isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto - isPrimitiveType, isTyVarTy, + isPrimitiveType, tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, - typeKind, eqKind, + typeKind, - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta - ) where + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, -#include "HsVersions.h" + pprKind, pprParendKind, + pprType, pprParendType, + pprPred, pprTheta, pprThetaArrow, pprClassPred + ) where -import {-# SOURCE #-} PprType( pprType ) --- PprType imports TcType so that it can print intelligently +#include "HsVersions.h" -- friends: import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tyVarsOfTheta, Kind, Type, SourceType(..), - PredType, ThetaType, unliftedTypeKind, + tyVarsOfTheta, Kind, Type, PredType(..), + ThetaType, unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, + isLiftedTypeKind, isUnliftedTypeKind, + isOpenTypeKind, mkArrowKinds, mkForAllTy, mkForAllTys, - defaultKind, isTypeKind, isAnyTypeKind, - mkFunTy, mkFunTys, zipFunTys, isTyVarTy, + defaultKind, isArgTypeKind, isOpenTypeKind, + mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, - mkPredTys, isUnLiftedType, + mkPredTys, isUnLiftedType, isUnboxedTupleType, isPrimitiveType, splitTyConApp_maybe, tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, - tidyOpenTyVars, eqKind, - hasMoreBoxityInfo, liftedBoxity, - superBoxity, typeKind, superKind, repType + tidyOpenTyVars, + isSubKind, + typeKind, repType, + pprKind, pprParendKind, + pprType, pprParendType, + pprPred, pprTheta, pprThetaArrow, pprClassPred ) -import DataCon ( DataCon ) import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) -import Class ( classHasFDs, Class ) -import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails ) -import ForeignCall ( Safety, playSafe - , DNType(..) - ) +import Class ( Class ) +import Var ( TyVar, tyVarKind, tcTyVarDetails ) +import ForeignCall ( Safety, playSafe, DNType(..) ) import VarEnv import VarSet -- others: import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) -import OccName ( OccName, mkDictOcc ) import NameSet +import OccName ( OccName, mkDictOcc ) import PrelNames -- Lots (e.g. in isFFIArgumentTy) import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) import BasicTypes ( IPName(..), ipNameName ) @@ -167,26 +167,6 @@ import Outputable %************************************************************************ %* * - 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} %* * %************************************************************************ @@ -220,17 +200,7 @@ tau ::= tyvar -- In all cases, a (saturated) type synonym application is legal, -- provided it expands to the required form. - \begin{code} -type SigmaType = Type -type RhoType = Type -type TauType = Type -\end{code} - -\begin{code} -type TcTyVar = TyVar -- Might be a mutable tyvar -type TcTyVarSet = TyVarSet - type TcType = Type -- A TcType can have mutable type variables -- Invariant on ForAllTy in TcTypes: -- forall a. T @@ -242,7 +212,8 @@ type TcThetaType = ThetaType type TcSigmaType = TcType type TcRhoType = TcType type TcTauType = TcType -type TcKind = TcType + +type TcKind = Kind \end{code} @@ -258,11 +229,12 @@ It's knot-tied back to Var.lhs. There is no reason in principle why Var.lhs shouldn't actually have the definition, but it "belongs" here. \begin{code} +type TcTyVar = TyVar -- Used only during type inference + data TyVarDetails = SigTv -- Introduced when instantiating a type signature, -- prior to checking that the defn of a fn does -- have the expected type. Should not be instantiated. - -- -- f :: forall a. a -> a -- f = e -- When checking e, with expected type (a->a), we @@ -274,38 +246,52 @@ data TyVarDetails | InstTv -- Ditto, but instance decl | PatSigTv -- Scoped type variable, introduced by a pattern - -- type signature - -- \ x::a -> e + -- type signature \ x::a -> e + + | ExistTv -- An existential type variable bound by a pattern for + -- a data constructor with an existential type. E.g. + -- data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. We distinguish these from all others + -- on one place, namely InstEnv.lookupInstEnv. | VanillaTv -- Everything else isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible -isUserTyVar tv = case mutTyVarDetails tv of +isUserTyVar tv = case tcTyVarDetails tv of VanillaTv -> False other -> True isSkolemTyVar :: TcTyVar -> Bool -isSkolemTyVar tv = case mutTyVarDetails tv of - SigTv -> True - ClsTv -> True - InstTv -> True - oteher -> False - -tyVarBindingInfo :: TyVar -> SDoc -- Used in checkSigTyVars +isSkolemTyVar tv = case tcTyVarDetails tv of + SigTv -> True + ClsTv -> True + InstTv -> True + ExistTv -> True + other -> False + +isExistentialTyVar :: TcTyVar -> Bool +isExistentialTyVar tv = case tcTyVarDetails tv of + ExistTv -> True + other -> False + +tyVarBindingInfo :: TcTyVar -> SDoc -- Used in checkSigTyVars tyVarBindingInfo tv - | isMutTyVar tv - = sep [ptext SLIT("is bound by the") <+> details (mutTyVarDetails tv), + = sep [ptext SLIT("is bound by the") <+> details (tcTyVarDetails tv), ptext SLIT("at") <+> ppr (getSrcLoc tv)] - | otherwise - = empty where details SigTv = ptext SLIT("type signature") details ClsTv = ptext SLIT("class declaration") details InstTv = ptext SLIT("instance declaration") details PatSigTv = ptext SLIT("pattern type signature") + details ExistTv = ptext SLIT("existential constructor") details VanillaTv = ptext SLIT("//vanilla//") -- Ditto \end{code} +\begin{code} +type TcTyVarSet = TyVarSet +\end{code} %************************************************************************ %* * @@ -316,20 +302,20 @@ tyVarBindingInfo tv \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) -mkPhiTy :: [SourceType] -> Type -> Type +mkPhiTy :: [PredType] -> Type -> Type mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta \end{code} - @isTauTy@ tests for nested for-alls. \begin{code} isTauTy :: Type -> Bool isTauTy (TyVarTy v) = True isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (NewTcApp _ tys) = all isTauTy tys isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (SourceTy p) = True -- Don't look through source types +isTauTy (PredTy p) = True -- Don't look through source types isTauTy (NoteTy _ ty) = isTauTy ty isTauTy other = False \end{code} @@ -337,15 +323,15 @@ isTauTy other = False \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 (SourceTy (NType tc _)) = getOccName tc -- Newtypes are quite reasonable -getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) --- SourceTy shouldn't happen +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (NewTcApp tc _) = getOccName tc +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (NoteTy _ t) = getDFunTyKey t +getDFunTyKey (FunTy arg _) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) +-- PredTy shouldn't happen \end{code} @@ -400,10 +386,10 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -tcSplitTyConApp_maybe (SourceTy (NType tc tys)) = Just (tc,tys) +tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (NewTcApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -- Newtypes are opaque, so they may be split -- However, predicates are not treated -- as tycon applications by the type checker @@ -426,16 +412,16 @@ tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res } tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -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 (TyConApp tc tys) = tc_split_app tc tys -tcSplitAppTy_maybe other = Nothing - -tc_split_app tc tys = case snocView tys of - Just (tys',ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing +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 (TyConApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (TyConApp tc tys', ty') + Nothing -> Nothing +tcSplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (NewTcApp tc tys', ty') + Nothing -> Nothing +tcSplitAppTy_maybe other = Nothing tcSplitAppTy ty = case tcSplitAppTy_maybe ty of Just stuff -> stuff @@ -478,7 +464,7 @@ tcSplitMethodTy ty = split ty split (NoteTy n ty) = split ty split _ = panic "splitMethodTy" -tcSplitDFunTy :: Type -> ([TyVar], [SourceType], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) -- Split the type of a dictionary function tcSplitDFunTy ty = case tcSplitSigmaTy ty of { (tvs, theta, tau) -> @@ -518,30 +504,18 @@ allDistinctTyVars (ty:tys) acc %* * %************************************************************************ -"Predicates" are particular source types, namelyClassP or IParams - \begin{code} -isPred :: SourceType -> Bool -isPred (ClassP _ _) = True -isPred (IParam _ _) = True -isPred (NType _ _) = False - -isPredTy :: Type -> Bool -isPredTy (NoteTy _ ty) = isPredTy ty -isPredTy (SourceTy sty) = isPred sty -isPredTy _ = False - tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only -tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty -tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p -tcSplitPredTy_maybe other = Nothing +tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty +tcSplitPredTy_maybe (PredTy p) = Just p +tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (ClassP clas tys) = getUnique clas -mkPredName :: Unique -> SrcLoc -> SourceType -> Name +mkPredName :: Unique -> SrcLoc -> PredType -> Name mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc \end{code} @@ -552,14 +526,14 @@ mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameNa \begin{code} mkClassPred clas tys = ClassP clas tys -isClassPred :: SourceType -> Bool +isClassPred :: PredType -> Bool isClassPred (ClassP clas tys) = True isClassPred other = False isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys isTyVarClassPred other = False -getClassPredTys_maybe :: SourceType -> Maybe (Class, [Type]) +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) getClassPredTys_maybe _ = Nothing @@ -570,7 +544,7 @@ mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) isDictTy :: Type -> Bool -isDictTy (SourceTy p) = isClassPred p +isDictTy (PredTy p) = isClassPred p isDictTy (NoteTy _ ty) = isDictTy ty isDictTy other = False \end{code} @@ -578,7 +552,7 @@ isDictTy other = False --------------------- Implicit parameters --------------------------------- \begin{code} -isIPPred :: SourceType -> Bool +isIPPred :: PredType -> Bool isIPPred (IParam _ _) = True isIPPred other = False @@ -607,7 +581,6 @@ isLinearPred other = False %************************************************************************ Comparison, taking note of newtypes, predicates, etc, -But ignoring usage types \begin{code} tcEqType :: Type -> Type -> Bool @@ -625,7 +598,7 @@ tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2 tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2 -tcCmpPred p1 p2 = cmpSourceTy emptyVarEnv p1 p2 +tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2 ------------- cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2 @@ -644,13 +617,14 @@ cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of Just tv1a -> tv1a `compare` tv2 Nothing -> tv1 `compare` tv2 -cmpTy env (SourceTy p1) (SourceTy p2) = cmpSourceTy env p1 p2 +cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2 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 (NewTcApp tc1 tys1) (NewTcApp 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 < SourceTy + -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < NewTcApp < ForAllTy < PredTy cmpTy env (AppTy _ _) (TyVarTy _) = GT cmpTy env (FunTy _ _) (TyVarTy _) = GT @@ -660,38 +634,39 @@ cmpTy env (TyConApp _ _) (TyVarTy _) = GT cmpTy env (TyConApp _ _) (AppTy _ _) = GT cmpTy env (TyConApp _ _) (FunTy _ _) = GT +cmpTy env (NewTcApp _ _) (TyVarTy _) = GT +cmpTy env (NewTcApp _ _) (AppTy _ _) = GT +cmpTy env (NewTcApp _ _) (FunTy _ _) = GT +cmpTy env (NewTcApp _ _) (TyConApp _ _) = GT + cmpTy env (ForAllTy _ _) (TyVarTy _) = GT cmpTy env (ForAllTy _ _) (AppTy _ _) = GT cmpTy env (ForAllTy _ _) (FunTy _ _) = GT cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT +cmpTy env (ForAllTy _ _) (NewTcApp _ _) = GT -cmpTy env (SourceTy _) t2 = GT +cmpTy env (PredTy _) t2 = GT cmpTy env _ _ = LT \end{code} \begin{code} -cmpSourceTy :: TyVarEnv TyVar -> SourceType -> SourceType -> Ordering -cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) +cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering +cmpPredTy 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 -cmpSourceTy env (IParam _ _) sty = LT - -cmpSourceTy env (ClassP _ _) (IParam _ _) = GT -cmpSourceTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) -cmpSourceTy env (ClassP _ _) (NType _ _) = LT - -cmpSourceTy env (NType tc1 tys1) (NType tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) -cmpSourceTy env (NType _ _) sty = GT +cmpPredTy env (IParam _ _) (ClassP _ _) = LT +cmpPredTy env (ClassP _ _) (IParam _ _) = GT +cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) \end{code} PredTypes are used as a FM key in TcSimplify, so we take the easy path and make them an instance of Ord \begin{code} -instance Eq SourceType where { (==) = tcEqPred } -instance Ord SourceType where { compare = tcCmpPred } +instance Eq PredType where { (==) = tcEqPred } +instance Ord PredType where { compare = tcCmpPred } \end{code} @@ -717,6 +692,12 @@ isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty isOverloadedTy (FunTy a b) = isPredTy a isOverloadedTy (NoteTy n ty) = isOverloadedTy ty isOverloadedTy _ = False + +isPredTy :: Type -> Bool -- Belongs in TcType because it does + -- not look through newtypes, or predtypes (of course) +isPredTy (NoteTy _ ty) = isPredTy ty +isPredTy (PredTy sty) = True +isPredTy _ = False \end{code} \begin{code} @@ -744,19 +725,19 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of \begin{code} deNoteType :: Type -> Type - -- Remove synonyms, but not source types + -- Remove synonyms, but not predicate types deNoteType ty@(TyVarTy tyvar) = ty deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) -deNoteType (SourceTy p) = SourceTy (deNoteSourceType p) +deNoteType (NewTcApp tycon tys) = NewTcApp tycon (map deNoteType tys) +deNoteType (PredTy p) = PredTy (deNotePredType 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) -deNoteSourceType :: SourceType -> SourceType -deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys) -deNoteSourceType (IParam n ty) = IParam n (deNoteType ty) -deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys) +deNotePredType :: PredType -> PredType +deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys) +deNotePredType (IParam n ty) = IParam n (deNoteType ty) \end{code} Find the free tycons and classes of a type. This is used in the front @@ -766,11 +747,11 @@ end of the compiler. tyClsNamesOfType :: Type -> NameSet tyClsNamesOfType (TyVarTy tv) = emptyNameSet tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (NewTcApp 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 (PredTy (IParam n ty)) = tyClsNamesOfType ty +tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `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 @@ -788,9 +769,9 @@ tyClsNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of (tvs,_,head_ty) -> tyClsNamesOfType head_ty -classNamesOfTheta :: ThetaType -> [Name] +classesOfTheta :: ThetaType -> [Class] -- Looks just for ClassP things; maybe it should check -classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ] +classesOfTheta preds = [ c | ClassP c _ <- preds ] \end{code} @@ -805,6 +786,10 @@ restricted set of types as arguments and results (the restricting factor being the ) \begin{code} +isFFITy :: Type -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +isFFITy ty = checkRepTyCon legalFFITyCon ty + isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty @@ -896,7 +881,9 @@ toDNType ty checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- Look through newtypes -- Non-recursive ones are transparent to splitTyConApp, - -- but recursive ones aren't + -- but recursive ones aren't. Manuel had: + -- newtype T = MkT (Ptr T) + -- and wanted it to work... checkRepTyCon check_tc ty | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc | otherwise = False @@ -944,6 +931,11 @@ legalOutgoingTyCon dflags safety tc | otherwise = marshalableTyCon dflags tc +legalFFITyCon :: TyCon -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +legalFFITyCon tc + = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon + marshalableTyCon dflags tc = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc) || boxedMarshalableTyCon tc @@ -1023,18 +1015,18 @@ uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_) = uVarX tyvar2 ty1 k subst -- Predicates -uTysX (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) k subst +uTysX (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) k subst | n1 == n2 = uTysX t1 t2 k subst -uTysX (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) k subst +uTysX (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) k subst | c1 == c2 = uTyListsX tys1 tys2 k subst -uTysX (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) k subst - | tc1 == tc2 = uTyListsX tys1 tys2 k subst -- Functions; just check the two parts uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst -- Type constructors must match +uTysX (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) k subst + | tc1 == tc2 = uTyListsX tys1 tys2 k subst uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst | (con1 == con2 && equalLength tys1 tys2) = uTyListsX tys1 tys2 k subst @@ -1076,7 +1068,7 @@ uVarX tv1 ty2 k subst@(tmpls, env) uTysX ty1 ty2 k subst Nothing -- Not already bound - | typeKind ty2 `eqKind` tyVarKind tv1 + | typeKind ty2 == tyVarKind tv1 && occur_check_ok ty2 -> -- No kind mismatch nor occur check k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) @@ -1146,10 +1138,10 @@ match (TyVarTy v) ty tmpls k senv | v `elemVarSet` tmpls = -- v is a template variable case lookupSubstEnv senv v of - Nothing | typeKind ty `eqKind` tyVarKind v + Nothing | typeKind ty `isSubKind` tyVarKind v -- We do a kind check, just as in the uVarX above -- The kind check is needed to avoid bogus matches - -- of (a b) with (c d), where the kinds don't match + -- of (a b) with (c d), where the kinds don't match -- An occur check isn't needed when matching. -> k (extendSubstEnv senv v (DoneTy ty)) @@ -1172,27 +1164,26 @@ match (TyVarTy v) ty tmpls k senv -- expect, due to an intervening Note. KSW 2000-06. -- Predicates -match (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) tmpls k senv +match (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) tmpls k senv | n1 == n2 = match t1 t2 tmpls k senv -match (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) tmpls k senv +match (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) tmpls k senv | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv -match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv - | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- Functions; just check the two parts match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv + -- If the template is an application, try to make the + -- thing we are matching look like an application match (AppTy fun1 arg1) ty2 tmpls k senv = case tcSplitAppTy_maybe ty2 of Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv Nothing -> Nothing -- Fail -match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv + -- Newtypes are opaque; predicate types should not happen +match (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) tmpls k senv | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv - --- Newtypes are opaque; other source types should not happen -match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv +match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- With type synonyms, we have to be careful for the exact