X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=f662217a69f4926c8a49447835d9f590c21e70ff;hb=ece94e430901c3480e842dcdbbcbef2f1bc070f7;hp=74595893013242b732365fa446d2a5940f9826e7;hpb=97351f5d70e2d5797a092059cb205089d55dacc6;p=ghc-hetmet.git

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 7459589..f662217 100644
--- 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
@@ -61,16 +62,17 @@ pprintClosureCommand session bindThings force str = do
 
    -- 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 
+       term_ <- obtainTerm cms force id 
+       term      <- tidyTermTyVars cms term_
        term'     <- if not bindThings then return term 
                      else bindSuspensions cms term                         
        showterm  <- printTerm cms term'
        unqual    <- GHC.getPrintUnqual cms
        let showSDocForUserOneLine unqual doc = 
                showDocWith LeftMode (doc (mkErrStyle unqual))
-       (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
+       (putStrLn . showSDocForUserOneLine unqual) 
+                                   (ppr id <+> char '=' <+> showterm)
      -- Before leaving, we compare the type obtained to see if it's more specific
      --  Then, we extract a substitution, 
      --  mapping the old tyvars to the reconstructed types.
@@ -93,13 +95,31 @@ pprintClosureCommand session bindThings force str = do
       hsc_env <- readIORef ref
       inScope <- GHC.getBindings cms
       let ictxt    = hsc_IC hsc_env
-          type_env = ic_type_env ictxt
-          ids      = typeEnvIds type_env
+          ids      = ic_tmp_ids ictxt
           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
+          subst_ran= varEnvElts$ getTvSubstEnv subst
+          new_tvs  = [ tv | Just tv <- map getTyVar_maybe subst_ran]  
+          ic_tyvars'= (`delVarSetListByKey` subst_dom) 
+                    . (`extendVarSetList`   new_tvs)
+                        $ ic_tyvars ictxt
+          ictxt'   = ictxt { ic_tmp_ids = ids'
+                           , ic_tyvars   = ic_tyvars' }
       writeIORef ref (hsc_env {hsc_IC = ictxt'})
 
+          where delVarSetListByKey = foldl' delVarSetByKey
+
+   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
@@ -107,7 +127,6 @@ bindSuspensions cms@(Session ref) t = do
       hsc_env <- readIORef ref
       inScope <- GHC.getBindings cms
       let ictxt        = hsc_IC hsc_env
-          type_env     = ic_type_env ictxt
           prefix       = "_t"
           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
           availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames 
@@ -118,17 +137,15 @@ bindSuspensions cms@(Session ref) t = do
       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                 | (name,ty) <- zip names tys']
           new_tyvars   = tyVarsOfTypes tys'
-          new_type_env = extendTypeEnvWithIds type_env ids 
-          old_tyvars   = ic_tyvars ictxt
-          new_ic       = ictxt { ic_type_env = new_type_env,
-                                 ic_tyvars   = old_tyvars `unionVarSet` new_tyvars }
+          new_ic       = extendInteractiveContext ictxt ids new_tyvars
       extendLinkEnv (zip names hvals)
       writeIORef ref (hsc_env {hsc_IC = new_ic })
       return t'
-     where    
+     where
 
 --    Processing suspensions. Give names and recopilate info
-        nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
+        nameSuspensionsAndGetInfos :: IORef [String] -> 
+                                       TermFold (IO (Term, [(Name,Type,HValue)]))
         nameSuspensionsAndGetInfos freeNames = TermFold 
                       {
                         fSuspension = doSuspension freeNames
@@ -177,10 +194,9 @@ printTerm cms@(Session ref) = cPprTerm cPpr
   bindToFreshName hsc_env ty userName = do
     name <- newGrimName cms userName 
     let ictxt    = hsc_IC hsc_env
-        type_env = ic_type_env ictxt
+        tmp_ids  = ic_tmp_ids ictxt
         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
-        new_type_env = extendTypeEnv type_env (AnId id)
-        new_ic       = ictxt { ic_type_env     = new_type_env }
+        new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
     return (hsc_env {hsc_IC = new_ic }, name)
 
 --    Create new uniques and give them sequentially numbered names
@@ -189,7 +205,7 @@ newGrimName cms userName  = do
     us <- mkSplitUniqSupply 'b'
     let unique  = uniqFromSupply us
         occname = mkOccName varName userName
-        name    = mkInternalName unique occname noSrcLoc
+        name    = mkInternalName unique occname noSrcSpan
     return name
 
 skolemSubst subst = subst `setTvSubstEnv`