From: Pepe Iborra <mnislaih@gmail.com>
Date: Tue, 24 Apr 2007 17:04:46 +0000 (+0000)
Subject: Some tyvars were being introduced in the environment via the thunk bindings '_ti... 
X-Git-Tag: 2007-05-06~110
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=808e6d4e915b12c29eaeada7b70318b829eafe82

Some tyvars were being introduced in the environment via the thunk bindings '_ti' in :print
---

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 28a45ae..52c6030 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -27,6 +27,7 @@ import NameEnv
 import RdrName
 import UniqSupply
 import Type
+import TcType
 import TyCon
 import TcGadt
 import GHC
@@ -60,7 +61,7 @@ pprintClosureCommand bindThings force str = do
                       (words str)
   substs <- catMaybes `liftM` mapM (io . go cms) 
                                    [id | AnId id <- tythings]
-  mapM (io . applySubstToEnv cms) substs
+  mapM (io . applySubstToEnv cms . skolemSubst) substs
   return ()
  where 
 
@@ -92,7 +93,7 @@ pprintClosureCommand bindThings force str = do
       let ictxt    = hsc_IC hsc_env
           type_env = ic_type_env ictxt
           ids      = typeEnvIds type_env
-          ids'     = map (\id -> setIdType id (substTy subst (idType id))) ids
+          ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
           type_env'= extendTypeEnvWithIds type_env ids'
           ictxt'   = ictxt { ic_type_env = type_env' }
       writeIORef ref (hsc_env {hsc_IC = ictxt'})
@@ -112,7 +113,7 @@ bindSuspensions cms@(Session ref) t = do
       availNames_var  <- newIORef availNames
       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
+      let ids = [ mkGlobalId VanillaGlobal name (mk_skol_ty ty) vanillaIdInfo
                   | (name,ty) <- zip names tys]
           new_type_env = extendTypeEnvWithIds type_env ids 
           new_rn_env   = extendLocalRdrEnv rn_env names
@@ -190,3 +191,11 @@ newGrimName cms userName  = do
         occname = mkOccName varName userName
         name    = mkInternalName unique occname noSrcLoc
     return name
+
+skolemSubst subst = subst `setTvSubstEnv` 
+                      mapVarEnv mk_skol_ty (getTvSubstEnv subst)
+mk_skol_ty ty | tyvars  <- varSetElems (tyVarsOfType ty)
+              , tyvars' <- map (mkTyVarTy . mk_skol_tv) tyvars
+              = substTyWith tyvars tyvars' ty
+mk_skol_tv tv = mkTcTyVar (tyVarName tv) (tyVarKind tv) 
+                      (SkolemTv UnkSkol)
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 1b7bb64..55b16d9 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -422,7 +422,7 @@ zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars	`thenM` \ tys ->
 			   returnM (tyVarsOfTypes tys)
 
 zonkTcTyVar :: TcTyVar -> TcM TcType
-zonkTcTyVar tyvar = ASSERT( isTcTyVar tyvar )
+zonkTcTyVar tyvar = ASSERT2( isTcTyVar tyvar, ppr tyvar)
 		    zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar
 \end{code}