X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=cd4c4c71bc0feba06d15280771bd954bde0567fe;hp=06eb0dcc08652328f37e19899a8d4919c0446a38;hb=bf40e268d916947786c56ec38db86190854a2d2c;hpb=3e83dfb21b2f2220dce97427fff5c19459ae68d1 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 06eb0dc..cd4c4c7 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} @@ -68,7 +68,7 @@ module TcType ( isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, + mkClassPred, isInheritablePred, isIPPred, mkPredName, dataConsStupidTheta, isRefineableTy, --------------------------------- @@ -89,7 +89,7 @@ module TcType ( -------------------------------- -- Rexported from Type Kind, -- Stuff to do with kinds is insensitive to pre/post Tc - unliftedTypeKind, liftedTypeKind, unboxedTypeKind, argTypeKind, + unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, isSubArgTypeKind, isSubKind, defaultKind, @@ -135,7 +135,6 @@ import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, Kind, PredType(..), KindVar, ThetaType, isUnliftedTypeKind, unliftedTypeKind, --- ??? unboxedTypeKind, argTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, tySuperKind, isLiftedTypeKind, @@ -170,10 +169,11 @@ import Type ( -- Re-exports pprType, pprParendType, pprTyThingCategory, pprPred, pprTheta, pprThetaArrow, pprClassPred ) -import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique ) +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 @@ -186,9 +186,9 @@ import VarEnv ( TidyEnv ) 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 ) @@ -344,6 +344,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 @@ -398,6 +399,7 @@ 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) @@ -471,7 +473,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") @@ -486,8 +489,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"), @@ -592,8 +600,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 @@ -643,17 +652,23 @@ 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 -> (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 (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) @@ -683,10 +698,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 @@ -876,10 +895,6 @@ isInheritablePred :: PredType -> Bool -- which can be free in g's rhs, and shared by both calls to g isInheritablePred (ClassP _ _) = True isInheritablePred other = False - -isLinearPred :: TcPredType -> Bool -isLinearPred (IParam (Linear n) _) = True -isLinearPred other = False \end{code} --------------------- Equality predicates --------------------------------- @@ -982,15 +997,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] @@ -1026,9 +1047,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 @@ -1044,6 +1070,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