Fix a bug in the closure viewer

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

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index ef8d367..e0a1250 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -19,12 +19,12 @@ module RtClosureInspect(
      lookupAddressEnv, 
 
      ClosureType(..), 
-     getClosureData, 
+     getClosureData,     -- :: a -> IO Closure
      Closure ( tipe, infoTable, ptrs, nonPtrs ), 
-     getClosureType, 
-     isConstr, 
-     isIndirection,
-     getInfoTablePtr, 
+     getClosureType,     -- :: a -> IO ClosureType
+     isConstr,           -- :: ClosureType -> Bool
+     isIndirection,      -- :: ClosureType -> Bool
+     getInfoTablePtr,    -- :: a -> Ptr StgInfoTable
 
      Term(..), 
      printTerm, 
@@ -39,6 +39,8 @@ module RtClosureInspect(
      isPointed,
      isFullyEvaluatedTerm,
 --     unsafeDeepSeq, 
+     
+     sigmaType
  ) where 
 
 #include "HsVersions.h"
@@ -61,7 +63,6 @@ import Name
 import VarEnv
 import OccName
 import VarSet
-import Unique
 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
 
 import TysPrim         
@@ -125,6 +126,11 @@ isPrim   _    = False
 termType t@(Suspension {}) = mb_ty t
 termType t = Just$ ty t
 
+isFullyEvaluatedTerm :: Term -> Bool
+isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
+isFullyEvaluatedTerm Suspension {}      = False
+isFullyEvaluatedTerm Prim {}            = True
+
 instance Outputable (Term) where
  ppr = head . customPrintTerm customPrintTermBase
 
@@ -358,7 +364,7 @@ customPrintTermBase showP =
                                     , largeIntegerDataConName] 
            isTupleDC Term{dc=dc}   = dc `elem` snd (unzip (elems boxedTupleArr))
            isDC a_dc Term{dc=dc}   = a_dc == dc
-           coerceShow f Term{val=val} = return . text . show . f . unsafeCoerce# $ val
+           coerceShow f = return . text . show . f . unsafeCoerce# . val
            --TODO pprinting of list terms is not lazy
            doList h t = do
                let elems = h : getListTerms t
@@ -379,12 +385,6 @@ customPrintTermBase showP =
                       getListTerms t@Suspension{}       = [t]
                       getListTerms t = pprPanic "getListTerms" (ppr t)
 
-isFullyEvaluatedTerm :: Term -> Bool
-isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
-isFullyEvaluatedTerm Suspension {}      = False
-isFullyEvaluatedTerm Prim {}            = True
-
-
 -----------------------------------
 -- Type Reconstruction
 -----------------------------------
@@ -474,7 +474,7 @@ cvObtainTerm1 hsc_env force mb_ty hval
   | Nothing <- mb_ty = runTR hsc_env . go argTypeKind $ hval
   | Just ty <- mb_ty = runTR hsc_env $ do
                  term <- go argTypeKind hval
-                 ty'  <- instScheme ty
+                 ty'  <- instScheme (sigmaType ty)
                  addConstraint ty' (fromMaybe (error "by definition") 
                                               (termType term)) 
                  return term
@@ -541,6 +541,11 @@ zonkTerm = foldTerm idTermFoldM {
              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
                                           return (Suspension ct ty v b)}  
 
+
+-- Is this defined elsewhere?
+-- Find all free tyvars and insert the appropiate ForAll.
+sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
+
 {-
 Example of Type Reconstruction
 --------------------------------