termTyVars,
-- unsafeDeepSeq,
cvReconstructType,
- unifyRTTI,
+ improveRTTIType,
sigmaType,
Closure(..),
getClosureData,
import TcMType
import TcUnify
import TcEnv
-import Unify
import DriverPhases
import TyCon
import Name
import Foreign
import System.IO.Unsafe
+import System.IO
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
Just x -> return x
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
-runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
+runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
traceTR :: SDoc -> TR ()
traceTR = liftTcM . traceTc
liftTcM = id
newVar :: Kind -> TR TcType
-newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
+newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
-- | Returns the instantiated type scheme ty', and the substitution sigma
-- such that sigma(ty') = ty
-- Before unification, congruenceNewtypes needs to
-- do its magic.
addConstraint :: TcType -> TcType -> TR ()
-addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
+addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry boxyUnify
>> return () -- TOMDO: what about the coercion?
-- we should consider family instances
zip [0..] (filter isPointed subTtypes)]
_ -> return []
-{-
- This helper computes the difference between a base type t and the
- improved rtti_t computed by RTTI
- The main difference between RTTI types and their normal counterparts
- is that the former are _not_ polymorphic, thus polymorphism must
- be stripped. Syntactically, forall's must be stripped.
- We also remove predicates.
--}
-unifyRTTI :: Type -> Type -> TvSubst
-unifyRTTI ty rtti_ty =
- case mb_subst of
- Just subst -> subst
- Nothing -> pprPanic "Failed to compute a RTTI substitution"
- (ppr (ty, rtti_ty))
- -- In addition, we strip newtypes too, since the reconstructed type might
- -- not have recovered them all
- -- TODO stripping newtypes shouldn't be necessary, test
- where mb_subst = tcUnifyTys (const BindMe)
- [rttiView ty]
- [rttiView rtti_ty]
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType <base_type> <rtti_type>
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst)
+improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
+ let (_,ty0) = splitForAllTys ty
+ ty_tvs = varSetElems $ tyVarsOfType ty0
+ let (_,rtti_ty0)= splitForAllTys rtti_ty
+ rtti_tvs = varSetElems $ tyVarsOfType rtti_ty0
+ (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs [] ty0)
+ (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
+ boxyUnify rtti_ty' ty'
+ tvs1_contents <- zonkTcTyVars ty_tvs'
+ let subst = uncurry zipTopTvSubst
+ (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
+ , getTyVar_maybe ty /= Just tv
+ , not(isTyVarTy ty)])
+-- liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
+ return subst
-- Dealing with newtypes
{-
tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
-- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
- let substs = [unifyRTTI ty ty'
+ improvs <- sequence [improveRTTIType hsc_env ty ty'
| (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
- ic' = foldr (flip substInteractiveContext) ic
- (map skolemiseSubst substs)
+ let ic' = foldr (\mb_subst ic' ->
+ maybe (WARN(True, text ("RTTI failed to calculate the "
+ ++ "improvement for a type")) ic')
+ (substInteractiveContext ic' . skolemiseSubst)
+ mb_subst)
+ ic
+ improvs
return hsc_env{hsc_IC=ic'}
skolemiseSubst :: TvSubst -> TvSubst
splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp,
- repType, typePrimRep, coreView, tcView, kindView, rttiView,
+ repType, typePrimRep, coreView, tcView, kindView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls,
tcView _ = Nothing
-----------------------------------------------
-rttiView :: Type -> Type
--- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism
-rttiView (ForAllTy _ ty) = rttiView ty
-rttiView (FunTy PredTy{} ty) = rttiView ty
-rttiView ty@TyConApp{} | Just ty' <- coreView ty
- = rttiView ty'
-rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys)
-rttiView ty = ty
-
------------------------------------------------
{-# INLINE kindView #-}
kindView :: Kind -> Maybe Kind
-- C.f. coreView, tcView