Commit 808e6d4e authored by mnislaih's avatar mnislaih
Browse files

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

parent fa56e210
...@@ -27,6 +27,7 @@ import NameEnv ...@@ -27,6 +27,7 @@ import NameEnv
import RdrName import RdrName
import UniqSupply import UniqSupply
import Type import Type
import TcType
import TyCon import TyCon
import TcGadt import TcGadt
import GHC import GHC
...@@ -60,7 +61,7 @@ pprintClosureCommand bindThings force str = do ...@@ -60,7 +61,7 @@ pprintClosureCommand bindThings force str = do
(words str) (words str)
substs <- catMaybes `liftM` mapM (io . go cms) substs <- catMaybes `liftM` mapM (io . go cms)
[id | AnId id <- tythings] [id | AnId id <- tythings]
mapM (io . applySubstToEnv cms) substs mapM (io . applySubstToEnv cms . skolemSubst) substs
return () return ()
where where
...@@ -92,7 +93,7 @@ pprintClosureCommand bindThings force str = do ...@@ -92,7 +93,7 @@ pprintClosureCommand bindThings force str = do
let ictxt = hsc_IC hsc_env let ictxt = hsc_IC hsc_env
type_env = ic_type_env ictxt type_env = ic_type_env ictxt
ids = typeEnvIds type_env 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' type_env'= extendTypeEnvWithIds type_env ids'
ictxt' = ictxt { ic_type_env = type_env' } ictxt' = ictxt { ic_type_env = type_env' }
writeIORef ref (hsc_env {hsc_IC = ictxt'}) writeIORef ref (hsc_env {hsc_IC = ictxt'})
...@@ -112,7 +113,7 @@ bindSuspensions cms@(Session ref) t = do ...@@ -112,7 +113,7 @@ bindSuspensions cms@(Session ref) t = do
availNames_var <- newIORef availNames availNames_var <- newIORef availNames
(t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t (t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff 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] | (name,ty) <- zip names tys]
new_type_env = extendTypeEnvWithIds type_env ids new_type_env = extendTypeEnvWithIds type_env ids
new_rn_env = extendLocalRdrEnv rn_env names new_rn_env = extendLocalRdrEnv rn_env names
...@@ -190,3 +191,11 @@ newGrimName cms userName = do ...@@ -190,3 +191,11 @@ newGrimName cms userName = do
occname = mkOccName varName userName occname = mkOccName varName userName
name = mkInternalName unique occname noSrcLoc name = mkInternalName unique occname noSrcLoc
return name 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)
...@@ -422,7 +422,7 @@ zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars `thenM` \ tys -> ...@@ -422,7 +422,7 @@ zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars `thenM` \ tys ->
returnM (tyVarsOfTypes tys) returnM (tyVarsOfTypes tys)
zonkTcTyVar :: TcTyVar -> TcM TcType zonkTcTyVar :: TcTyVar -> TcM TcType
zonkTcTyVar tyvar = ASSERT( isTcTyVar tyvar ) zonkTcTyVar tyvar = ASSERT2( isTcTyVar tyvar, ppr tyvar)
zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar
\end{code} \end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment