seqType, seqTypes,
-- Type substitutions
- TvSubst(..), -- Representation visible to a few friends
- TvSubstEnv, emptyTvSubst,
- mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
+ TvSubstEnv, emptyTvSubstEnv, -- Representation widely visible
+ TvSubst(..), emptyTvSubst, -- Representation visible to a few friends
+ mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
- extendTvSubst, extendTvSubstList, isInScope,
+ extendTvSubst, extendTvSubstList, isInScope, composeTvSubst,
-- Performing substitution on types
- substTy, substTys, substTyWith, substTheta, substTyVar,
- deShadowTy,
+ substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
+ deShadowTy,
-- Pretty-printing
pprType, pprParendType, pprTyThingCategory,
\begin{code}
data TvSubst
= TvSubst InScopeSet -- The in-scope type variables
- TvSubstEnv -- The substitution itself; guaranteed idempotent
+ TvSubstEnv -- The substitution itself
-- See Note [Apply Once]
{- ----------------------------------------------------------
-- in the middle of matching, and unification (see Types.Unify)
-- So you have to look at the context to know if it's idempotent or
-- apply-once or whatever
+emptyTvSubstEnv :: TvSubstEnv
+emptyTvSubstEnv = emptyVarEnv
+
+composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv
+-- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1
+-- It assumes that both are idempotent
+-- Typically, env1 is the refinement to a base substitution env2
+composeTvSubst in_scope env1 env2
+ = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2
+ -- First apply env1 to the range of env2
+ -- Then combine the two, making sure that env1 loses if
+ -- both bind the same variable; that's why env1 is the
+ -- *left* argument to plusVarEnv, because the right arg wins
+ where
+ subst1 = TvSubst in_scope env1
emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
isEmptyTvSubst :: TvSubst -> Bool
isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
+mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
+mkTvSubst = TvSubst
+
getTvSubstEnv :: TvSubst -> TvSubstEnv
getTvSubstEnv (TvSubst _ env) = env
isInScope :: Var -> TvSubst -> Bool
isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope
+notElemTvSubst :: TyVar -> TvSubst -> Bool
+notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env)
+
setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
extendTvSubstList (TvSubst in_scope env) tvs tys
= TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
--- mkTvSubst and zipTvSubst generate the in-scope set from
+-- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
-mkTvSubst :: TvSubstEnv -> TvSubst
-mkTvSubst env
- = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
+mkOpenTvSubst :: TvSubstEnv -> TvSubst
+mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
-zipTvSubst :: [TyVar] -> [Type] -> TvSubst
-zipTvSubst tyvars tys
+zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst
+zipOpenTvSubst tyvars tys
= TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys)
-- mkTopTvSubst is called when doing top-level substitutions.
\begin{code}
substTyWith :: [TyVar] -> [Type] -> Type -> Type
-substTyWith tvs tys = substTy (zipTvSubst tvs tys)
+substTyWith tvs tys = substTy (zipOpenTvSubst tvs tys)
substTy :: TvSubst -> Type -> Type
substTy subst ty | isEmptyTvSubst subst = ty
-- Note that the in_scope set is poked only if we hit a forall
-- so it may often never be fully computed
-subst_ty subst@(TvSubst in_scope env) ty
+subst_ty subst ty
= go ty
where
- go ty@(TyVarTy tv) = case (lookupVarEnv env tv) of
- Nothing -> ty
- Just ty' -> ty' -- See Note [Apply Once]
-
+ go (TyVarTy tv) = substTyVar subst tv
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
-- The mkAppTy smart constructor is important
-- we might be replacing (a Int), represented with App
-- by [Int], represented with TyConApp
- go (ForAllTy tv ty) = case substTyVar subst tv of
+ go (ForAllTy tv ty) = case substTyVarBndr subst tv of
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
-substTyVar :: TvSubst -> TyVar -> (TvSubst, TyVar)
-substTyVar subst@(TvSubst in_scope env) old_var
+substTyVar :: TvSubst -> TyVar -> Type
+substTyVar (TvSubst in_scope env) tv
+ = case (lookupVarEnv env tv) of
+ Nothing -> TyVarTy tv
+ Just ty' -> ty' -- See Note [Apply Once]
+
+substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
+substTyVarBndr subst@(TvSubst in_scope env) old_var
| old_var == new_var -- No need to clone
-- But we *must* zap any current substitution for the variable.
-- For example:
--
-- The new_id isn't cloned, but it may have a different type
-- etc, so we must return it, not the old id
- = (TvSubst (in_scope `extendInScopeSet` new_var) (delVarEnv env old_var),
+ = (TvSubst (in_scope `extendInScopeSet` new_var)
+ (delVarEnv env old_var),
new_var)
| otherwise -- The new binder is in scope so
-- Extending the substitution to do this renaming also
-- has the (correct) effect of discarding any existing
-- substitution for that variable
- = (TvSubst (in_scope `extendInScopeSet` new_var) (extendVarEnv env old_var (TyVarTy new_var)),
+ = (TvSubst (in_scope `extendInScopeSet` new_var)
+ (extendVarEnv env old_var (TyVarTy new_var)),
new_var)
where
new_var = uniqAway in_scope old_var
-- The uniqAway part makes sure the new variable is not already in scope
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff