X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=5fcba6d667d68b3b2c65ad6a2306c20b402c67e2;hb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;hp=d16aa04b800c260a93550f5f471cbfd751d4b6f8;hpb=5cd3527da623a25b9ace2995f9d2e7f6c90c611f;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index d16aa04..5fcba6d 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -62,10 +62,11 @@ module Type (
 	usageAnnOfType, typeKind, addFreeTyVars,
 
 	-- Tidying up for printing
-	tidyType,     tidyTypes,
-	tidyOpenType, tidyOpenTypes,
-	tidyTyVar,    tidyTyVars, tidyFreeTyVars,
-	tidyTopType,  tidyPred,
+	tidyType,      tidyTypes,
+	tidyOpenType,  tidyOpenTypes,
+	tidyTyVarBndr, tidyFreeTyVars,
+	tidyOpenTyVar, tidyOpenTyVars,
+	tidyTopType,   tidyPred,
 
 	-- Comparison
 	eqType, eqKind, eqUsage, 
@@ -756,36 +757,34 @@ an interface file.
 It doesn't change the uniques at all, just the print names.
 
 \begin{code}
-tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVar env@(tidy_env, subst) tyvar
-  = case lookupVarEnv subst tyvar of
-
-	Just tyvar' -> 	-- Already substituted
-		(env, tyvar')
-
-	Nothing -> 	-- Make a new nice name for it
-
-		case tidyOccName tidy_env (getOccName name) of
-		    (tidy', occ') -> 	-- New occname reqd
-				((tidy', subst'), tyvar')
-			      where
-				subst' = extendVarEnv subst tyvar tyvar'
-				tyvar' = setTyVarName tyvar name'
-				name'  = mkLocalName (getUnique name) occ' noSrcLoc
-					-- Note: make a *user* tyvar, so it printes nicely
-					-- Could extract src loc, but no need.
+tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+tidyTyVarBndr (tidy_env, subst) tyvar
+  = case tidyOccName tidy_env (getOccName name) of
+      (tidy', occ') -> 	-- New occname reqd
+			((tidy', subst'), tyvar')
+		    where
+			subst' = extendVarEnv subst tyvar tyvar'
+			tyvar' = setTyVarName tyvar name'
+			name'  = mkLocalName (getUnique name) occ' noSrcLoc
+				-- Note: make a *user* tyvar, so it printes nicely
+				-- Could extract src loc, but no need.
   where
     name = tyVarName tyvar
 
-tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
-tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
-
 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 -- Add the free tyvars to the env in tidy form,
 -- so that we can tidy the type they are free in
-tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
-			  where
-			    add env tv = fst (tidyTyVar env tv)
+tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
+
+tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
+tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
+
+tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+-- Treat a new tyvar as a binder, and give it a fresh tidy name
+tidyOpenTyVar env@(tidy_env, subst) tyvar
+  = case lookupVarEnv subst tyvar of
+	Just tyvar' -> (env, tyvar')		-- Already substituted
+	Nothing	    -> tidyTyVarBndr env tyvar	-- Treat it as a binder
 
 tidyType :: TidyEnv -> Type -> Type
 tidyType env@(tidy_env, subst) ty
@@ -802,7 +801,7 @@ tidyType env@(tidy_env, subst) ty
     go (FunTy fun arg)	    = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
     go (ForAllTy tv ty)	    = ForAllTy tvp SAPPLY (tidyType envp ty)
 			      where
-			        (envp, tvp) = tidyTyVar env tv
+			        (envp, tvp) = tidyTyVarBndr env tv
     go (UsageTy u ty)	    = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
 
     go_note (SynNote ty)        = SynNote SAPPLY (go ty)
@@ -964,7 +963,7 @@ eq_ty env (TyVarTy tv1)       (TyVarTy tv2)       = case lookupVarEnv env tv1 of
 							  Just tv1a -> tv1a == tv2
 							  Nothing   -> tv1  == tv2
 eq_ty env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   
-	| tv1 == tv2				  = eq_ty env t1 t2
+	| tv1 == tv2				  = eq_ty (delVarEnv env tv1)        t1 t2
 	| otherwise				  = eq_ty (extendVarEnv env tv1 tv2) t1 t2
 eq_ty env (AppTy s1 t1)       (AppTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
 eq_ty env (FunTy s1 t1)       (FunTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)