X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=cb1c68b81fd86314c19737f25ff7cc3c1dc16aeb;hp=10300dbffe041d6aa7ae303bdaa54e531cb023b2;hb=49c98d143c382a1341e1046f5ca00819a25691ba;hpb=d16986ac581b30084b3ba44cd918270da65d4cef diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 10300db..cb1c68b 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -1,4 +1,4 @@ - +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcType]{Types used in the typechecker} @@ -10,7 +10,7 @@ compiler. These parts newtypes, and predicates are meaningful. * look through usage types -The "tc" prefix is for "typechechecker", because the type checker +The "tc" prefix is for "TypeChecker", because the type checker is the principal client. \begin{code} @@ -42,7 +42,7 @@ module TcType ( tcSplitForAllTys, tcSplitPhiTy, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar, tcSplitSigmaTy, tcMultiSplitSigmaTy, @@ -50,6 +50,7 @@ module TcType ( -- Predicates. -- Again, newtypes are opaque tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, + eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, isDoubleTy, isFloatTy, isIntTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, @@ -64,10 +65,10 @@ module TcType ( --------------------------------- -- Predicate types getClassPredTys_maybe, getClassPredTys, - isClassPred, isTyVarClassPred, + isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, + mkClassPred, isInheritablePred, isIPPred, mkPredName, dataConsStupidTheta, isRefineableTy, --------------------------------- @@ -88,10 +89,11 @@ module TcType ( -------------------------------- -- Rexported from Type Kind, -- Stuff to do with kinds is insensitive to pre/post Tc - unliftedTypeKind, liftedTypeKind, unboxedTypeKind, + unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isArgTypeKind, isSubKind, defaultKind, + isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, + isSubArgTypeKind, isSubKind, defaultKind, + kindVarRef, mkKindVar, Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, @@ -101,7 +103,7 @@ module TcType ( -- Type substitutions TvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTvSubst, + TvSubstEnv, emptyTvSubst, substEqSpec, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar, extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, @@ -127,69 +129,35 @@ module TcType ( #include "HsVersions.h" -- friends: -import TypeRep ( Type(..), funTyCon ) -- friend - -import Type ( -- Re-exports - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tyVarsOfTheta, Kind, PredType(..), - ThetaType, unliftedTypeKind, unboxedTypeKind, - liftedTypeKind, openTypeKind, mkArrowKind, - isLiftedTypeKind, isUnliftedTypeKind, - mkArrowKinds, mkForAllTy, mkForAllTys, - defaultKind, isArgTypeKind, isOpenTypeKind, - mkFunTy, mkFunTys, zipFunTys, - mkTyConApp, mkAppTy, - mkAppTys, applyTy, applyTys, - mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, - mkPredTys, isUnLiftedType, - isUnboxedTupleType, isPrimitiveType, - splitTyConApp_maybe, - tidyTopType, tidyType, tidyPred, tidyTypes, - tidyFreeTyVars, tidyOpenType, tidyOpenTypes, - tidyTyVarBndr, tidyOpenTyVar, - tidyOpenTyVars, tidyKind, - isSubKind, tcView, - - tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, - - TvSubst(..), - TvSubstEnv, emptyTvSubst, mkTvSubst, zipTyEnv, - mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, - getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, - extendTvSubst, extendTvSubstList, isInScope, notElemTvSubst, - substTy, substTys, substTyWith, substTheta, - substTyVar, substTyVarBndr, substPred, lookupTyVar, - - typeKind, repType, coreView, - pprKind, pprParendKind, - pprType, pprParendType, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred - ) -import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique ) +import TypeRep ( Type(..), funTyCon, Kind ) -- friend + +import Type +import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon, + synTyConDefn, tyConUnique ) import DataCon ( DataCon, dataConStupidTheta, dataConResTys ) import Class ( Class ) -import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails ) +import Var ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails ) import ForeignCall ( Safety, DNType(..) ) import Unify ( tcMatchTys ) import VarSet -- others: import DynFlags ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) -import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) +import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc, mkSystemName ) import NameSet import VarEnv ( TidyEnv ) -import OccName ( OccName, mkDictOcc ) +import OccName ( OccName, mkDictOcc, mkOccName, tvName ) import PrelNames -- Lots (e.g. in isFFIArgumentTy) import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) -import BasicTypes ( IPName(..), Arity, ipNameName ) +import BasicTypes ( Arity, ipNameName ) import SrcLoc ( SrcLoc, SrcSpan ) -import Util ( snocView, equalLength ) +import Util ( equalLength ) import Maybes ( maybeToBool, expectJust, mapCatMaybes ) import ListSetOps ( hasNoDups ) import List ( nubBy ) import Outputable -import DATA_IOREF + +import Data.IORef \end{code} @@ -340,6 +308,7 @@ data SkolemInfo -- The rest are for non-scoped skolems | ClsSkol Class -- Bound at a class decl | InstSkol Id -- Bound at an instance decl + | FamInstSkol TyCon -- Bound at a family instance decl | PatSkol DataCon -- An existential type variable bound by a pattern for SrcSpan -- a data constructor with an existential type. E.g. -- data T = forall a. Eq a => MkT a @@ -385,6 +354,32 @@ data UserTypeCtxt -- will become type T = forall a. a->a -- -- With gla-exts that's right, but for H98 we should complain. + +--------------------------------- +-- Kind variables: + +mkKindName :: Unique -> Name +mkKindName unique = mkSystemName unique kind_var_occ + +kindVarRef :: KindVar -> IORef MetaDetails +kindVarRef tc = + ASSERT ( isTcTyVar tc ) + case tcTyVarDetails tc of + MetaTv TauTv ref -> ref + other -> pprPanic "kindVarRef" (ppr tc) + +mkKindVar :: Unique -> IORef MetaDetails -> KindVar +mkKindVar u r + = mkTcTyVar (mkKindName u) + tySuperKind -- not sure this is right, + -- do we need kind vars for + -- coercions? + (MetaTv TauTv r) + +kind_var_occ :: OccName -- Just one for all KindVars + -- They may be jiggled by tidying +kind_var_occ = mkOccName tvName "k" +\end{code} \end{code} %************************************************************************ @@ -442,7 +437,8 @@ pprSkolTvBinding :: TcTyVar -> SDoc -- Print info about the binding of a skolem tyvar, -- or nothing if we don't have anything useful to say pprSkolTvBinding tv - = ppr_details (tcTyVarDetails tv) + = ASSERT ( isTcTyVar tv ) + ppr_details (tcTyVarDetails tv) where ppr_details (MetaTv TauTv _) = quotes (ppr tv) <+> ptext SLIT("is a meta type variable") ppr_details (MetaTv BoxTv _) = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable") @@ -457,8 +453,13 @@ pprSkolTvBinding tv pprSkolInfo :: SkolemInfo -> SDoc pprSkolInfo (SigSkol ctxt) = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt pprSkolInfo (ClsSkol cls) = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls) -pprSkolInfo (InstSkol df) = ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df) -pprSkolInfo (ArrowSkol loc) = ptext SLIT("is bound by the arrow form at") <+> ppr loc +pprSkolInfo (InstSkol df) = + ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df) +pprSkolInfo (FamInstSkol tc) = + ptext SLIT("is bound by the family instance declaration at") <+> + ppr (getSrcLoc tc) +pprSkolInfo (ArrowSkol loc) = + ptext SLIT("is bound by the arrow form at") <+> ppr loc pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc), nest 2 (ptext SLIT("at") <+> ppr loc)] pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), @@ -540,6 +541,7 @@ isIndirect other = False %************************************************************************ \begin{code} +mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) mkPhiTy :: [PredType] -> Type -> Type @@ -562,8 +564,9 @@ isTauTy other = False isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype -isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc)) - | otherwise = True +isTauTyCon tc + | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc)) + | otherwise = True --------------- isBoxyTy :: TcType -> Bool @@ -613,22 +616,28 @@ tcSplitForAllTys :: Type -> ([TyVar], Type) tcSplitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty (ForAllTy tv ty) tvs + | not (isCoVar tv) = split ty ty (tv:tvs) + split orig_ty t tvs = (reverse tvs, orig_ty) tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy tv ty) = True +tcIsForAllTy (ForAllTy tv ty) = not (isCoVar tv) tcIsForAllTy t = False -tcSplitPhiTy :: Type -> ([PredType], Type) +tcSplitPhiTy :: Type -> (ThetaType, Type) tcSplitPhiTy ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs - split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of - Just p -> split res res (p:ts) - Nothing -> (reverse ts, orig_ty) + + split orig_ty (ForAllTy tv ty) ts + | isCoVar tv = split ty ty (eq_pred:ts) + where + PredTy eq_pred = tyVarKind tv + split orig_ty (FunTy arg res) ts + | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) split orig_ty ty ts = (reverse ts, orig_ty) +tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) tcSplitSigmaTy ty = case tcSplitForAllTys ty of (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) @@ -653,10 +662,14 @@ tcMultiSplitSigmaTy sigma ----------------------- tcTyConAppTyCon :: Type -> TyCon -tcTyConAppTyCon ty = fst (tcSplitTyConApp ty) +tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> tc + Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) tcTyConAppArgs :: Type -> [Type] -tcTyConAppArgs ty = snd (tcSplitTyConApp ty) +tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of + Just (_, args) -> args + Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) tcSplitTyConApp :: Type -> (TyCon, [Type]) tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of @@ -707,13 +720,9 @@ tcFunResultTy ty = snd (tcSplitFunTy ty) ----------------------- tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' -tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) -tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of - Just (tys', ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing -tcSplitAppTy_maybe other = Nothing +tcSplitAppTy_maybe ty = repSplitAppTy_maybe ty +tcSplitAppTy :: Type -> (Type, Type) tcSplitAppTy ty = case tcSplitAppTy_maybe ty of Just stuff -> stuff Nothing -> pprPanic "tcSplitAppTy" (pprType ty) @@ -846,10 +855,13 @@ isInheritablePred :: PredType -> Bool -- which can be free in g's rhs, and shared by both calls to g isInheritablePred (ClassP _ _) = True isInheritablePred other = False +\end{code} -isLinearPred :: TcPredType -> Bool -isLinearPred (IParam (Linear n) _) = True -isLinearPred other = False +--------------------- Equality predicates --------------------------------- +\begin{code} +substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)] +substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty) + | (tv,ty) <- eq_spec] \end{code} --------------------- The stupid theta (sigh) --------------------------------- @@ -936,7 +948,8 @@ deNoteType ty = ty \begin{code} tcTyVarsOfType :: Type -> TcTyVarSet --- Just the tc type variables free in the type +-- Just the *TcTyVars* free in the type +-- (Types.tyVarsOfTypes finds all free TyVars) tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys @@ -944,15 +957,21 @@ tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg -tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar +tcTyVarsOfType (ForAllTy tyvar ty) = (tcTyVarsOfType ty `delVarSet` tyvar) + `unionVarSet` tcTyVarsOfTyVar tyvar -- We do sometimes quantify over skolem TcTyVars +tcTyVarsOfTyVar :: TcTyVar -> TyVarSet +tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv) + | otherwise = emptyVarSet + tcTyVarsOfTypes :: [Type] -> TyVarSet tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys tcTyVarsOfPred :: PredType -> TyVarSet -tcTyVarsOfPred (IParam _ ty) = tcTyVarsOfType ty -tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys +tcTyVarsOfPred (IParam _ ty) = tcTyVarsOfType ty +tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys +tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2 \end{code} Note [Silly type synonym] @@ -988,9 +1007,14 @@ exactTyVarsOfType ty go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + `unionVarSet` go_tv tyvar + + go_pred (IParam _ ty) = go ty + go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 - go_pred (IParam _ ty) = go ty - go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar) + | otherwise = emptyVarSet exactTyVarsOfTypes :: [TcType] -> TyVarSet exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys @@ -1006,6 +1030,7 @@ tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNa tyClsNamesOfType (NoteTy _ ty2) = tyClsNamesOfType ty2 tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2 tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty