X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=d80bd52c0ee6cb948ca508af51a93bb04aceebe4;hp=b0d647b67ae254b89ce0381cf7bce90f9236988d;hb=c4ec8f2a77894af1c6160c4e8ad5625ab62f0bea;hpb=25512ca39778bf6882a50db2ede21ffa74ea3ac9

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index b0d647b..d80bd52 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -39,7 +39,7 @@ module Type (
         splitNewTyConApp_maybe, splitNewTyConApp,
 
         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
-	applyTy, applyTys, isForAllTy, dropForAlls,
+	applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
 	
 	-- (Newtypes)
 	newTyConInstRhs,
@@ -128,7 +128,7 @@ module Type (
         isEmptyTvSubst,
 
 	-- ** Performing substitution on types
-	substTy, substTys, substTyWith, substTheta, 
+	substTy, substTys, substTyWith, substTysWith, substTheta, 
 	substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
 
 	-- * Pretty-printing
@@ -742,15 +742,18 @@ applyTys :: Type -> [Type] -> Type
 -- > foo = case undefined :: R of
 -- >            R f -> f ()
 
-applyTys orig_fun_ty []      = orig_fun_ty
-applyTys orig_fun_ty arg_tys 
+applyTys ty args = applyTysD empty ty args
+
+applyTysD :: SDoc -> Type -> [Type] -> Type	-- Debug version
+applyTysD _   orig_fun_ty []      = orig_fun_ty
+applyTysD doc orig_fun_ty arg_tys 
   | n_tvs == n_args 	-- The vastly common case
   = substTyWith tvs arg_tys rho_ty
   | n_tvs > n_args 	-- Too many for-alls
   = substTyWith (take n_args tvs) arg_tys 
 		(mkForAllTys (drop n_args tvs) rho_ty)
   | otherwise		-- Too many type args
-  = ASSERT2( n_tvs > 0, ppr orig_fun_ty )	-- Zero case gives infnite loop!
+  = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty )	-- Zero case gives infnite loop!
     applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
 	     (drop n_tvs arg_tys)
   where
@@ -1511,6 +1514,12 @@ substTyWith :: [TyVar] -> [Type] -> Type -> Type
 substTyWith tvs tys = ASSERT( length tvs == length tys )
 		      substTy (zipOpenTvSubst tvs tys)
 
+-- | Type substitution making use of an 'TvSubst' that
+-- is assumed to be open, see 'zipOpenTvSubst'
+substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
+substTysWith tvs tys = ASSERT( length tvs == length tys )
+		       substTys (zipOpenTvSubst tvs tys)
+
 -- | Substitute within a 'Type'
 substTy :: TvSubst -> Type  -> Type
 substTy subst ty | isEmptyTvSubst subst = ty
@@ -1625,7 +1634,7 @@ Kinds
 --            ??   (\#)
 --           \/  \
 --          \*    \#
---
+-- .
 -- Where:        \*    [LiftedTypeKind]   means boxed type
 --              \#    [UnliftedTypeKind] means unboxed type
 --              (\#)  [UbxTupleKind]     means unboxed tuple