- tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds
- -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
-
- let substs = [computeRTTIsubst ty ty'
- | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
- ic' = foldr (flip substInteractiveContext) ic
- (map skolemiseSubst $ catMaybes substs)
- return hsc_env{hsc_IC=ic'}
-
-skolemiseSubst subst = subst `setTvSubstEnv`
- mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
+ 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)
+