fix some coercion kind representation things, extend exprIsConApp_maybe to non-vanilla

[ghc-hetmet.git] / compiler / typecheck / TcType.lhs

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 06eb0dc..727d0ab 100644 (file)
--- 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,
@@ -171,9 +170,10 @@ import Type                (       -- Re-exports
                          pprPred, pprTheta, pprThetaArrow, pprClassPred
                        )
 import TyCon           ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
+import Coercion         ( splitForAllCo_maybe )
 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 +188,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,7 +643,8 @@ 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 (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'
@@ -656,6 +657,8 @@ tcSplitPhiTy ty = split ty ty []
   split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
   split orig_ty (FunTy arg res) ts 
        | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
+  split orig_ty ty ts
+        | Just (p, ty') <- splitForAllCo_maybe ty = split ty' ty' (p:ts) 
   split orig_ty ty             ts = (reverse ts, orig_ty)
 
 tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
@@ -989,8 +992,9 @@ 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]
@@ -1027,8 +1031,9 @@ exactTyVarsOfType ty
     go (AppTy fun arg)           = go fun `unionVarSet` go arg
     go (ForAllTy tyvar ty)       = delVarSet (go ty) tyvar
 
-    go_pred (IParam _ ty)  = go ty
-    go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+    go_pred (IParam _ ty)    = go ty
+    go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
+    go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
 
 exactTyVarsOfTypes :: [TcType] -> TyVarSet
 exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
@@ -1044,6 +1049,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