X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;fp=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=d4bc99577c42ec2ba185c4935fd1787cda792840;hb=7f05f1095e9a2c7b2b378859da00fde7ca907080;hp=f2f06c8ca74e0ac3680718ce7cd98800c4281159;hpb=29ca2190efa2284e767949b0fab4e00a68db59bd;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index f2f06c8..d4bc995 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -67,11 +67,11 @@ module Type (
 	TvSubstEnv, emptyTvSubst,
 	mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
 	getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
-	extendTvSubst, extendTvSubstList, isInScope,
+ 	extendTvSubst, extendTvSubstList, isInScope, composeTvSubst,
 
 	-- Performing substitution on types
 	substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
-	deShadowTy,
+	deShadowTy, 
 
 	-- Pretty-printing
 	pprType, pprParendType, pprTyThingCategory,
@@ -1026,6 +1026,18 @@ type TvSubstEnv = TyVarEnv Type
 	-- So you have to look at the context to know if it's idempotent or
 	-- apply-once or whatever
 
+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
+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, becuause the right arg wins
+  where
+    subst1 = TvSubst in_scope env1
+
 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
 isEmptyTvSubst :: TvSubst -> Bool
 isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env