X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=242e6035694fcef8e1f287a26b499809f2c5fdc1;hb=064812423073e89805c16311728cfded5d50e306;hp=630340a4bf865d57b8cb41867a052edb4e23a90d;hpb=cd0e2c0cc3005c3f5e74eeda57dc9cebbe1bac7e;p=ghc-hetmet.git

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 630340a..242e603 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -98,7 +98,8 @@ module Type (
 	tidyKind,
 
 	-- * Type comparison
-	coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
+	coreEqType, coreEqType2,
+        tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
 	tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
 
 	-- * Forcing evaluation of types
@@ -122,7 +123,8 @@ module Type (
 	emptyTvSubstEnv, emptyTvSubst,
 	
 	mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
-	getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList,
+	getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, 
+        extendTvInScope, extendTvInScopeList,
  	extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
         isEmptyTvSubst,
 
@@ -427,8 +429,8 @@ splitAppTys ty = split ty ty []
     split _       (AppTy ty arg)        args = split ty ty (arg:args)
     split _       (TyConApp tc tc_args) args
       = let -- keep type families saturated
-            n | isDecomposableTyCon tc = tyConArity tc
-              | otherwise              = 0
+            n | isDecomposableTyCon tc = 0
+              | otherwise              = tyConArity tc
             (tc_args1, tc_args2) = splitAt n tc_args
         in
         (TyConApp tc tc_args1, tc_args2 ++ args)
@@ -1140,11 +1142,14 @@ See Note [Newtype eta] in TyCon.lhs
 \begin{code}
 -- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.)
 coreEqType :: Type -> Type -> Bool
-coreEqType t1 t2
-  = eq rn_env t1 t2
+coreEqType t1 t2 = coreEqType2 rn_env t1 t2
   where
     rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
 
+coreEqType2 :: RnEnv2 -> Type -> Type -> Bool
+coreEqType2 rn_env t1 t2
+  = eq rn_env t1 t2
+  where
     eq env (TyVarTy tv1)       (TyVarTy tv2)     = rnOccL env tv1 == rnOccR env tv2
     eq env (ForAllTy tv1 t1)   (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2
     eq env (AppTy s1 t1)       (AppTy s2 t2)     = eq env s1 s2 && eq env t1 t2
@@ -1433,6 +1438,9 @@ notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env)
 setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
 setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
 
+zapTvSubstEnv :: TvSubst -> TvSubst
+zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv
+
 extendTvInScope :: TvSubst -> Var -> TvSubst
 extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env