X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=af03b7aa56ec9c0e41325139ce735036a0e26be5;hb=a80264a591226e4ba7037ab30cb2812ccdf8f686;hp=eaa323864e6fc95cc112f0e866c540e861d0bef7;hpb=57573e7e61032482d6be16ed4ac86c2b4115fbfa;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index eaa3238..af03b7a 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -22,7 +22,7 @@ module TcType ( -------------------------------- -- TyVarDetails - TyVarDetails(..), isUserTyVar, isSkolemTyVar, + TyVarDetails(..), isUserTyVar, isSkolemTyVar, isExistentialTyVar, tyVarBindingInfo, -------------------------------- @@ -73,6 +73,7 @@ module TcType ( isFFILabelTy, -- :: Type -> Bool isFFIDotnetTy, -- :: DynFlags -> Type -> Bool isFFIDotnetObjTy, -- :: Type -> Bool + isFFITy, -- :: Type -> Bool toDNType, -- :: Type -> DNType @@ -85,8 +86,8 @@ 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, typeCon, + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isArgTypeKind, isSubKind, defaultKind, Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, @@ -100,7 +101,7 @@ module TcType ( tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, - typeKind, eqKind, + typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, @@ -118,11 +119,13 @@ import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, Kind, Type, PredType(..), - ThetaType, unliftedTypeKind, typeCon, + 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, @@ -132,19 +135,17 @@ import Type ( -- Re-exports 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 TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) import Class ( Class ) -import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) -import ForeignCall ( Safety, playSafe - , DNType(..) - ) +import Var ( TyVar, tyVarKind, tcTyVarDetails ) +import ForeignCall ( Safety, playSafe, DNType(..) ) import VarEnv import VarSet @@ -200,9 +201,6 @@ tau ::= tyvar -- provided it expands to the required form. \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 @@ -214,7 +212,8 @@ type TcThetaType = ThetaType type TcSigmaType = TcType type TcRhoType = TcType type TcTauType = TcType -type TcKind = TcType + +type TcKind = Kind \end{code} @@ -230,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 @@ -246,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} %************************************************************************ %* * @@ -494,7 +508,7 @@ allDistinctTyVars (ty:tys) acc tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty -tcSplitPredTy_maybe (PredTy p) = Just p +tcSplitPredTy_maybe (PredTy p) = Just p tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique @@ -772,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 @@ -863,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 @@ -911,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 @@ -1043,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)) @@ -1113,7 +1138,7 @@ 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 @@ -1148,12 +1173,14 @@ match (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) tmpls k senv 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 --- Newtypes are opaque; predicate types should not happen + -- 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 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv