import RdrName
import UniqSupply
import Type
+import TcType
import TyCon
import TcGadt
import GHC
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
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
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
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)