X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=bcc9b4e2546276244f1f619e604e7c178b887cd3;hb=f3e5a3add2e8b5f878be96d7b04ef52e3c39a211;hp=7a686f3812ab60446e1d540227fa6a95c71cf531;hpb=671b39c5b40e5a3105e4ffb49b673b20ce96ba15;p=ghc-hetmet.git

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 7a686f3..bcc9b4e 100644
--- 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,15 +22,11 @@ import Var hiding ( varName )
 import VarSet
 import VarEnv
 import Name 
-import NameEnv
-import RdrName
 import UniqSupply
 import Type
 import TcType
-import TyCon
 import TcGadt
 import GHC
-import GhciMonad
 
 import Outputable
 import Pretty                    ( Mode(..), showDocWith )
@@ -52,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 . skolemSubst) substs
+  mapM (applySubstToEnv session . skolemSubst) substs
   return ()
  where 
 
@@ -82,8 +76,12 @@ pprintClosureCommand bindThings force str = do
      --  Then, we extract a substitution, 
      --  mapping the old tyvars to the reconstructed types.
        let Just reconstructed_type = termType term
-           mb_subst = tcUnifyTys (const BindMe) [idType id] [reconstructed_type]
-       ASSERT (isJust mb_subst) return mb_subst
+     -- 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]  
+       ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id)) 
+        return mb_subst
 
    applySubstToEnv :: Session -> TvSubst -> IO ()
    applySubstToEnv cms subst | isEmptyTvSubst subst = return ()