give the statements under evaluation in the ":show context" output

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

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 28a45ae..7459589 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,21 +47,19 @@ 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 
 
-   -- 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
@@ -81,8 +75,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 ()
@@ -92,7 +95,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 +107,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 +114,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 +177,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 +191,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 RuntimeUnkSkol)