X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=52c60306c8d7e980b3d991285280cff3db1db254;hb=808e6d4e915b12c29eaeada7b70318b829eafe82;hp=31f21a7da1296a2c96348976b563b2c10e8fdecd;hpb=fd9c8b7edda8512c147b2ff982129659ef39979d;p=ghc-hetmet.git

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 31f21a7..52c6030 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -27,6 +27,7 @@ import NameEnv
 import RdrName
 import UniqSupply
 import Type
+import TcType
 import TyCon
 import TcGadt
 import GHC
@@ -54,22 +55,19 @@ import GHC.Exts
 pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
 pprintClosureCommand bindThings force str = do 
   cms <- getSession
-  newvarsNames <- io$ do 
-           uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
-           return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
-  mb_ids  <- io$ mapM (cleanUp cms newvarsNames) (words str)
-  mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
-  io$ updateIds cms (catMaybes mb_new_ids)
+  tythings <- (catMaybes . concat) `liftM`
+                 mapM (\w -> io(GHC.parseName cms w >>= 
+                                mapM (GHC.lookupName cms)))
+                      (words str)
+  substs <- catMaybes `liftM` mapM (io . go cms) 
+                                   [id | AnId id <- tythings]
+  mapM (io . applySubstToEnv cms . skolemSubst) substs
+  return ()
  where 
-   -- Find the Id
-   cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
-   cleanUp cms newNames str = do
-     tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
-     return$ listToMaybe [ i | Just (AnId i) <- tythings]
 
    -- Do the obtainTerm--bindSuspensions-refineIdType dance
    -- Warning! This function got a good deal of side-effects
-   go :: Session -> Id -> IO (Maybe Id)
+   go :: Session -> Id -> IO (Maybe TvSubst)
    go cms id = do
      mb_term <- obtainTerm cms force id
      maybe (return Nothing) `flip` mb_term $ \term -> do
@@ -81,34 +79,24 @@ pprintClosureCommand bindThings force str = do
                showDocWith LeftMode (doc (mkErrStyle unqual))
        (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
      -- Before leaving, we compare the type obtained to see if it's more specific
-       let Just reconstructedType = termType term  
-           new_type = mostSpecificType (idType id) reconstructedType
-       return . Just $ setIdType id new_type
-
-   updateIds :: Session -> [Id] -> IO ()
-   updateIds (Session ref) new_ids = do
-     hsc_env <- readIORef ref
-     let ictxt = hsc_IC hsc_env
-         type_env = ic_type_env ictxt
-         filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
-         new_type_env =  extendTypeEnvWithIds filtered_type_env new_ids
-         new_ic = ictxt {ic_type_env = new_type_env }
-     writeIORef ref (hsc_env {hsc_IC = new_ic })
-
-isMoreSpecificThan :: Type -> Type -> Bool
-ty `isMoreSpecificThan` ty1 
-      | Just subst    <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1] 
-      , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
-      , not . null $ substFiltered
-      , all (flip notElemTvSubst subst) ty_vars
-      = True
-      | otherwise = False
-      where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
-                            | otherwise = BindMe
-            ty_vars = varSetElems$ tyVarsOfType ty
-
-mostSpecificType ty1 ty2 | ty1 `isMoreSpecificThan` ty2 = ty1
-                         | otherwise = ty2
+     --  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
+
+   applySubstToEnv :: Session -> TvSubst -> IO ()
+   applySubstToEnv cms subst | isEmptyTvSubst subst = return ()
+   applySubstToEnv cms@(Session ref) subst = 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'     = 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'})
 
 -- | Give names, and bind in the interactive environment, to all the suspensions
 --   included (inductively) in a term
@@ -125,7 +113,7 @@ bindSuspensions cms@(Session ref) t = do
       availNames_var  <- newIORef availNames
       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
+      let ids = [ mkGlobalId VanillaGlobal name (mk_skol_ty ty) vanillaIdInfo
                   | (name,ty) <- zip names tys]
           new_type_env = extendTypeEnvWithIds type_env ids 
           new_rn_env   = extendLocalRdrEnv rn_env names
@@ -203,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 UnkSkol)