X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=a3828082e387d9bbdb048c678dfd0d792101d37d;hb=0b86bc9b022a5965d2b35f143ff4b919f784e676;hp=06eb0dcc08652328f37e19899a8d4919c0446a38;hpb=3e83dfb21b2f2220dce97427fff5c19459ae68d1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 06eb0dc..a382808 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -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,
@@ -173,7 +172,7 @@ import Type		(	-- Re-exports
 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
@@ -188,7 +187,7 @@ import PrelNames	-- Lots (e.g. in isFFIArgumentTy)
 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 )
@@ -643,17 +642,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)
@@ -982,15 +987,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 +1037,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 +1060,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