+rttiEnvironment :: HscEnv -> IO HscEnv
+rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
+ let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+ incompletelyTypedIds =
+ [id | id <- tmp_ids
+ , not $ noSkolems id
+ , (occNameFS.nameOccName.idName) id /= result_fs]
+ hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+ return hsc_env'
+ where
+ noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
+ improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
+ let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+ Just id = find (\i -> idName i == name) tmp_ids
+ if noSkolems id
+ then return hsc_env
+ else do
+ mb_new_ty <- reconstructType hsc_env 10 id
+ let old_ty = idType id
+ case mb_new_ty of
+ Nothing -> return hsc_env
+ Just new_ty -> do
+ mb_subst <- improveRTTIType hsc_env old_ty new_ty
+ case mb_subst of
+ Nothing -> return $
+ WARN(True, text (":print failed to calculate the "
+ ++ "improvement for a type")) hsc_env
+ Just subst -> do
+ when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
+ printForUser stderr alwaysQualify $
+ fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
+
+ let (subst', skols) = skolemiseSubst subst
+ ic' = extendInteractiveContext
+ (substInteractiveContext ic subst') [] skols
+ return hsc_env{hsc_IC=ic'}
+
+skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
+skolemiseSubst subst = let
+ varenv = getTvSubstEnv subst
+ all_together = mapVarEnv skolemiseTy varenv
+ (varenv', skol_vars) = ( mapVarEnv fst all_together
+ , map snd (varEnvElts all_together))
+ in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
+
+