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

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 7a686f3..a56b27b 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -15,23 +15,19 @@ module Debugger (pprintClosureCommand) where
 import Linker
 import RtClosureInspect
 
-import PrelNames
 import HscTypes
 import IdInfo
 --import Id
+import Name
 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,25 +48,24 @@ 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 
 
-   -- 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'
@@ -82,8 +77,17 @@ 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
+     -- 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
 
    applySubstToEnv :: Session -> TvSubst -> IO ()
    applySubstToEnv cms subst | isEmptyTvSubst subst = return ()
@@ -98,6 +102,17 @@ pprintClosureCommand bindThings force str = do
           ictxt'   = ictxt { ic_type_env = type_env' }
       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
@@ -196,4 +211,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)