X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=9db0a189ca43ef991b3885e88ccd3b4c920cbfd7;hb=f3e5a3add2e8b5f878be96d7b04ef52e3c39a211;hp=45c5b0fa27d995c07ba37722b86bf97c2d3be74a;hpb=b5986072833796acb374e22f18cef8ab839a3419;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 45c5b0f..9db0a18 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -66,7 +66,7 @@ import GHC.Word         ( Word32(..), Word64(..) )
 import Control.Monad
 import Data.Maybe
 import Data.Array.Base
-import Data.List        ( partition )
+import Data.List        ( partition, nub )
 import Foreign.Storable
 
 import IO
@@ -475,18 +475,25 @@ cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 cvObtainTerm hsc_env force mb_ty a = do
    -- Obtain the term and tidy the type before returning it
    term <- cvObtainTerm1 hsc_env force mb_ty a
-   return $ tidyTypes term
-   where 
-         tidyTypes = foldTerm idTermFold {
-            fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
-            fSuspension = \ct mb_ty hval n -> 
-                          Suspension ct (fmap tidy mb_ty) hval n
-            }
-         tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty  
-         tidyVarEnv ty = mkVarEnv$ 
-                         [ (v, setTyVarName v (tyVarName tv))
-                           | (tv,v) <- zip alphaTyVars vars]
-             where vars = varSetElems$ tyVarsOfType ty
+   let term' =  tidyTypes term
+   return term'
+   where allvars = nub . foldTerm TermFold {
+            fTerm       = \ty _ _ tt   -> 
+                          varEnvElts(tyVarsOfType ty) ++ concat tt,
+            fSuspension = \_ mb_ty _ _ -> 
+                          maybe [] (varEnvElts . tyVarsOfType) mb_ty,
+            fPrim       = \ _ _ -> [] }
+         tidyTypes term = let 
+           go = foldTerm idTermFold {
+                  fTerm       = \ty dc hval tt -> 
+                          Term (tidy ty) dc hval tt,
+                  fSuspension = \ct mb_ty hval n -> 
+                          Suspension ct (fmap tidy mb_ty) hval n }
+           tidy ty      = tidyType (emptyTidyOccEnv, tidyVarEnv) ty  
+           tidyVarEnv   = mkVarEnv$ 
+                         [ (v, alpha_tv `setTyVarUnique` varUnique v)
+                           | (alpha_tv,v) <- zip alphaTyVars (allvars term)]
+           in go term
 
 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
@@ -565,7 +572,8 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 
-isMonomorphic = isEmptyVarSet . tyVarsOfType
+isMonomorphic ty | isForAllTy ty = False
+isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
 
 zonkTerm :: Term -> TcM Term
 zonkTerm = foldTerm idTermFoldM {