Dont tidy up tyvars after :print type reconstruction

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

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b98d61a..7c144c0 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -10,13 +10,7 @@ module RtClosureInspect(
   
      cvObtainTerm,       -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 
-     ClosureType(..), 
-     getClosureData,     -- :: a -> IO Closure
-     Closure ( tipe, infoPtr, ptrs, nonPtrs ), 
-     isConstr,           -- :: ClosureType -> Bool
-     isIndirection,      -- :: ClosureType -> Bool
-
-     Term(..), 
+     Term(..),
      pprTerm, 
      cPprTerm, 
      cPprTermBase,
@@ -72,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
@@ -174,6 +168,7 @@ readCType i
  | i == BLACKHOLE                          = Blackhole
  | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)
  | fromIntegral i == aP_CODE               = AP
+ | i == AP_STACK                           = AP
  | fromIntegral i == pAP_CODE              = PAP
  | otherwise                               = Other (fromIntegral i)
 
@@ -185,6 +180,11 @@ isIndirection (Indirection _) = True
 --isIndirection ThunkSelector = True
 isIndirection _ = False
 
+isThunk (Thunk _)     = True
+isThunk ThunkSelector = True
+isThunk AP            = True
+isThunk _             = False
+
 isFullyEvaluated :: a -> IO Bool
 isFullyEvaluated a = do 
   closure <- getClosureData a 
@@ -464,38 +464,28 @@ newVar = liftTcM . newFlexiTyVar
 
 liftTcM = id
 
-instScheme :: Type -> TR TcType
-instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
-    where fst3 (x,y,z) = x
-          trd  (x,y,z) = z
+-- | Returns the instantiated type scheme ty', and the substitution sigma 
+--   such that sigma(ty') = ty 
+instScheme :: Type -> TR (TcType, TvSubst)
+instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
+   (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
+   return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 
 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
-
-cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
-   tv <- case (isMonomorphic `fmap` mb_ty) of
-          Just True -> return (fromJust mb_ty)
-          _         -> do
-            tv_ <- liftM mkTyVarTy (newVar argTypeKind)
-            when (isJust mb_ty) $ 
-                 instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv_
-            return tv_
-   go tv (fromMaybe tv mb_ty) hval
+cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
+   tv <- liftM mkTyVarTy (newVar argTypeKind)
+   case mb_ty of
+     Nothing -> go tv tv hval
+     Just ty | isMonomorphic ty -> go ty ty hval
+     Just ty -> do 
+              (ty',rev_subst) <- instScheme (sigmaType ty)
+              addConstraint tv ty'
+              term <- go tv tv hval
+              --restore original Tyvars
+              return$ flip foldTerm term idTermFold {
+                fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
+                fSuspension = \ct mb_ty hval n -> 
+                          Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
     where 
   go tv ty a = do 
     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
@@ -503,7 +493,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
     clos <- trIO $ getClosureData a
     case tipe clos of
 -- Thunks we may want to force
-      Thunk _ | force -> seq a $ go tv ty a
+      t | isThunk t && force -> seq a $ go tv ty a
 -- We always follow indirections 
       Indirection _ -> go tv ty $! (ptrs clos ! 0)
  -- The interesting case
@@ -522,7 +512,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
             --     right here, _before_ the subterms are RTTI reconstructed.
             when (not monomorphic) $ do
                   let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
-                  instScheme(dataConRepType dc) >>= addConstraint myType 
+                  instScheme(dataConRepType dc) >>= addConstraint myType . fst
             subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
                   [ appArr (go tv t) (ptrs clos) i
                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
@@ -558,7 +548,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 {