remember the type of _result

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

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 28a45ae..03eeb65 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -15,7 +15,6 @@ module Debugger (pprintClosureCommand) where
 import Linker
 import RtClosureInspect
 
-import PrelNames
 import HscTypes
 import IdInfo
 --import Id
@@ -23,14 +22,11 @@ import Var hiding ( varName )
 import VarSet
 import VarEnv
 import Name 
-import NameEnv
-import RdrName
 import UniqSupply
 import Type
-import TyCon
+import TcType
 import TcGadt
 import GHC
-import GhciMonad
 
 import Outputable
 import Pretty                    ( Mode(..), showDocWith )
@@ -51,16 +47,15 @@ import GHC.Exts
 -------------------------------------
 -- | The :print & friends commands
 -------------------------------------
-pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
-pprintClosureCommand bindThings force str = do 
-  cms <- getSession
+pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
+pprintClosureCommand session bindThings force str = do 
   tythings <- (catMaybes . concat) `liftM`
-                 mapM (\w -> io(GHC.parseName cms w >>= 
-                                mapM (GHC.lookupName cms)))
+                 mapM (\w -> GHC.parseName session w >>= 
+                                mapM (GHC.lookupName session))
                       (words str)
-  substs <- catMaybes `liftM` mapM (io . go cms) 
+  substs <- catMaybes `liftM` mapM (go session) 
                                    [id | AnId id <- tythings]
-  mapM (io . applySubstToEnv cms) substs
+  mapM (applySubstToEnv session . skolemSubst) substs
   return ()
  where 
 
@@ -92,7 +87,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'})
@@ -104,7 +99,6 @@ bindSuspensions cms@(Session ref) t = do
       hsc_env <- readIORef ref
       inScope <- GHC.getBindings cms
       let ictxt        = hsc_IC hsc_env
-          rn_env       = ic_rn_local_env ictxt
           type_env     = ic_type_env ictxt
           prefix       = "_t"
           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
@@ -112,12 +106,14 @@ bindSuspensions cms@(Session ref) t = do
       availNames_var  <- newIORef availNames
       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
+      let tys' = map mk_skol_ty tys
       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
-                  | (name,ty) <- zip names tys]
+                | (name,ty) <- zip names tys']
+          new_tyvars   = tyVarsOfTypes tys'
           new_type_env = extendTypeEnvWithIds type_env ids 
-          new_rn_env   = extendLocalRdrEnv rn_env names
-          new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
-                                 ic_type_env     = new_type_env }
+          old_tyvars   = ic_tyvars ictxt
+          new_ic       = ictxt { ic_type_env = new_type_env,
+                                 ic_tyvars   = old_tyvars `unionVarSet` new_tyvars }
       extendLinkEnv (zip names hvals)
       writeIORef ref (hsc_env {hsc_IC = new_ic })
       return t'
@@ -173,13 +169,10 @@ printTerm cms@(Session ref) = cPprTerm cPpr
   bindToFreshName hsc_env ty userName = do
     name <- newGrimName cms userName 
     let ictxt    = hsc_IC hsc_env
-        rn_env   = ic_rn_local_env ictxt
         type_env = ic_type_env ictxt
         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
         new_type_env = extendTypeEnv type_env (AnId id)
-        new_rn_env   = extendLocalRdrEnv rn_env [name]
-        new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
-                               ic_type_env     = new_type_env }
+        new_ic       = ictxt { ic_type_env     = new_type_env }
     return (hsc_env {hsc_IC = new_ic }, name)
 
 --    Create new uniques and give them sequentially numbered names
@@ -190,3 +183,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)