Remove skolem tyvars from the InteractiveContext once they have been instantiated...

[ghc-hetmet.git] / compiler / ghci / Debugger.hs

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index bcc9b4e..4e61068 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -18,6 +18,7 @@ import RtClosureInspect
 import HscTypes
 import IdInfo
 --import Id
+import Name
 import Var hiding ( varName )
 import VarSet
 import VarEnv
@@ -59,12 +60,12 @@ pprintClosureCommand session bindThings force str = do
   return ()
  where 
 
-   -- Do the obtainTerm--bindSuspensions-refineIdType dance
-   -- Warning! This function got a good deal of side-effects
+   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
    go :: Session -> Id -> IO (Maybe TvSubst)
-   go cms id = do
-     mb_term <- obtainTerm cms force id
-     maybe (return Nothing) `flip` mb_term $ \term -> do
+   go cms id = do 
+     mb_term <- obtainTerm cms force id 
+     maybe (return Nothing) `flip` mb_term $ \term_ -> do
+       term      <- tidyTermTyVars cms term_
        term'     <- if not bindThings then return term 
                      else bindSuspensions cms term                         
        showterm  <- printTerm cms term'
@@ -76,10 +77,15 @@ pprintClosureCommand session bindThings force str = do
      --  Then, we extract a substitution, 
      --  mapping the old tyvars to the reconstructed types.
        let Just reconstructed_type = termType term
+
      -- tcUnifyTys doesn't look through forall's, so we drop them from 
      -- the original type, instead of sigma-typing the reconstructed type
-           mb_subst = tcUnifyTys (const BindMe) [dropForAlls$ idType id] 
-                       [reconstructed_type]  
+     -- In addition, we strip newtypes too, since the reconstructed type might
+     --   not have recovered them all
+           mb_subst = tcUnifyTys (const BindMe) 
+                                 [repType' $ dropForAlls$ idType id] 
+                                 [repType' $ reconstructed_type]  
+
        ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id)) 
         return mb_subst
 
@@ -93,9 +99,24 @@ pprintClosureCommand session bindThings force str = do
           ids      = typeEnvIds type_env
           ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
           type_env'= extendTypeEnvWithIds type_env ids'
-          ictxt'   = ictxt { ic_type_env = type_env' }
+          subst_dom= varEnvKeys$ getTvSubstEnv subst
+          ictxt'   = ictxt { ic_type_env = type_env'
+                           , ic_tyvars   = foldl' delVarSetByKey
+                                                  (ic_tyvars ictxt) 
+                                                  subst_dom }
       writeIORef ref (hsc_env {hsc_IC = ictxt'})
 
+   tidyTermTyVars :: Session -> Term -> IO Term
+   tidyTermTyVars (Session ref) t = do
+     hsc_env <- readIORef ref
+     let env_tvs      = ic_tyvars (hsc_IC hsc_env)
+         my_tvs       = termTyVars t
+         tvs          = env_tvs `minusVarSet` my_tvs
+         tyvarOccName = nameOccName . tyVarName 
+         tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
+                        , env_tvs `intersectVarSet` my_tvs)
+     return$ mapTermType (snd . tidyOpenType tidyEnv) t
+
 -- | Give names, and bind in the interactive environment, to all the suspensions
 --   included (inductively) in a term
 bindSuspensions :: Session -> Term -> IO Term
@@ -194,4 +215,4 @@ 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)
+                      (SkolemTv RuntimeUnkSkol)