--------------------------------
-- 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,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tyVarsOfTheta, Kind, PredType(..), KindVar,
ThetaType, isUnliftedTypeKind, unliftedTypeKind,
--- ??? unboxedTypeKind,
argTypeKind,
liftedTypeKind, openTypeKind, mkArrowKind,
tySuperKind, isLiftedTypeKind,
import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, 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
import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
import BasicTypes ( IPName(..), Arity, ipNameName )
import SrcLoc ( SrcLoc, SrcSpan )
-import Util ( snocView, equalLength )
+import Util ( equalLength )
import Maybes ( maybeToBool, expectJust, mapCatMaybes )
import ListSetOps ( hasNoDups )
import List ( nubBy )
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)
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]
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
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