X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FVarEnv.lhs;h=fca625692f47ef9365d5503524b6d4f70fc537a1;hp=bf3f96dd2647e100d5d29877c3f5300037f548ea;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516

diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index bf3f96d..fca6256 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module VarEnv (
         -- * Var, Id and TyVar environments (maps)
-	VarEnv, IdEnv, TyVarEnv,
+	VarEnv, IdEnv, TyVarEnv, CoVarEnv,
 	
 	-- ** Manipulating these environments
 	emptyVarEnv, unitVarEnv, mkVarEnv,
@@ -14,6 +14,7 @@ module VarEnv (
 	extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList,
 	plusVarEnv, plusVarEnv_C,
 	delVarEnvList, delVarEnv,
+        minusVarEnv, intersectsVarEnv,
 	lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
 	mapVarEnv, zipVarEnv,
 	modifyVarEnv, modifyVarEnv_Directly,
@@ -28,14 +29,16 @@ module VarEnv (
 	emptyInScopeSet, mkInScopeSet, delInScopeSet,
 	extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
 	getInScopeVars, lookupInScope, lookupInScope_Directly, 
-        elemInScopeSet, uniqAway, 
+        unionInScope, elemInScopeSet, uniqAway,
 
 	-- * The RnEnv2 type
 	RnEnv2, 
 	
 	-- ** Operations on RnEnv2s
 	mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
-	rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, extendRnInScopeList,
+        rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR,
+        addRnInScopeSet,
+        rnEtaL, rnEtaR,
 	rnInScope, rnInScopeSet, lookupRnInScope,
 
 	-- * TidyEnv and its operation
@@ -119,6 +122,10 @@ lookupInScope (InScope in_scope _) v  = lookupVarEnv in_scope v
 lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
 lookupInScope_Directly (InScope in_scope _) uniq
   = lookupVarEnv_Directly in_scope uniq
+
+unionInScope :: InScopeSet -> InScopeSet -> InScopeSet
+unionInScope (InScope s1 _) (InScope s2 n2)
+  = InScope (s1 `plusVarEnv` s2) n2
 \end{code}
 
 \begin{code}
@@ -198,9 +205,10 @@ mkRnEnv2 vars = RV2	{ envL 	   = emptyVarEnv
 			, envR 	   = emptyVarEnv
 			, in_scope = vars }
 
-extendRnInScopeList :: RnEnv2 -> [Var] -> RnEnv2
-extendRnInScopeList env vs
-  = env { in_scope = extendInScopeSetList (in_scope env) vs }
+addRnInScopeSet :: RnEnv2 -> VarEnv Var -> RnEnv2
+addRnInScopeSet env vs
+  | isEmptyVarEnv vs = env
+  | otherwise        = env { in_scope = extendInScopeSetSet (in_scope env) vs }
 
 rnInScope :: Var -> RnEnv2 -> Bool
 rnInScope x env = x `elemInScopeSet` in_scope env
@@ -237,36 +245,43 @@ rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR
 
 rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var)
 -- ^ Similar to 'rnBndr2' but used when there's a binder on the left
--- side only. Useful when eta-expanding
+-- side only.
 rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
   = (RV2 { envL     = extendVarEnv envL bL new_b
-	 , envR     = extendVarEnv envR new_b new_b 	-- Note [rnBndrLR]
+         , envR     = envR
 	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
   where
     new_b = uniqAway in_scope bL
 
 rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
 -- ^ Similar to 'rnBndr2' but used when there's a binder on the right
--- side only. Useful when eta-expanding
+-- side only.
 rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
-  = (RV2 { envL     = extendVarEnv envL new_b new_b	-- Note [rnBndrLR]
-	 , envR     = extendVarEnv envR bR new_b
+  = (RV2 { envR     = extendVarEnv envR bR new_b
+         , envL     = envL
 	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
   where
     new_b = uniqAway in_scope bR
 
--- Note [rnBndrLR] 
--- ~~~~~~~~~~~~~~~
--- Notice that in rnBndrL, rnBndrR, we extend envR, envL respectively
--- with a binding [new_b -> new_b], where new_b is the new binder.
--- This is important when doing eta expansion; e.g. matching (\x.M) ~ N
--- In effect we switch to (\x'.M) ~ (\x'.N x'), where x' is new_b
--- So we must add x' to the env of both L and R.  (x' is fresh, so it
--- can't capture anything in N.)  
---
--- If we don't do this, we can get silly matches like
---	forall a.  \y.a  ~   v
--- succeeding with [x -> v y], which is bogus of course 
+rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var)
+-- ^ Similar to 'rnBndrL' but used for eta expansion
+-- See Note [Eta expansion]
+rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
+  = (RV2 { envL     = extendVarEnv envL bL new_b
+	 , envR     = extendVarEnv envR new_b new_b 	-- Note [Eta expansion]
+	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
+  where
+    new_b = uniqAway in_scope bL
+
+rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var)
+-- ^ Similar to 'rnBndr2' but used for eta expansion
+-- See Note [Eta expansion]
+rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
+  = (RV2 { envL     = extendVarEnv envL new_b new_b	-- Note [Eta expansion]
+	 , envR     = extendVarEnv envR bR new_b
+	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
+  where
+    new_b = uniqAway in_scope bR
 
 rnOccL, rnOccR :: RnEnv2 -> Var -> Var
 -- ^ Look up the renaming of an occurrence in the left or right term
@@ -287,6 +302,20 @@ nukeRnEnvL env = env { envL = emptyVarEnv }
 nukeRnEnvR env = env { envR = emptyVarEnv }
 \end{code}
 
+Note [Eta expansion]
+~~~~~~~~~~~~~~~~~~~~
+When matching
+     (\x.M) ~ N
+we rename x to x' with, where x' is not in scope in 
+either term.  Then we want to behave as if we'd seen
+     (\x'.M) ~ (\x'.N x')
+Since x' isn't in scope in N, the form (\x'. N x') doesn't
+capture any variables in N.  But we must nevertheless extend
+the envR with a binding [x' -> x'], to support the occurs check.
+For example, if we don't do this, we can get silly matches like
+	forall a.  (\y.a)  ~   v
+succeeding with [a -> v y], which is bogus of course.
+
 
 %************************************************************************
 %*									*
@@ -314,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
 type VarEnv elt   = UniqFM elt
 type IdEnv elt    = VarEnv elt
 type TyVarEnv elt = VarEnv elt
+type CoVarEnv elt = VarEnv elt
 
 emptyVarEnv	  :: VarEnv a
 mkVarEnv	  :: [(Var, a)] -> VarEnv a
@@ -330,6 +360,8 @@ filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
 restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a
 delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a
 delVarEnv	  :: VarEnv a -> Var -> VarEnv a
+minusVarEnv       :: VarEnv a -> VarEnv a -> VarEnv a
+intersectsVarEnv  :: VarEnv a -> VarEnv a -> Bool
 plusVarEnv_C	  :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
 mapVarEnv	  :: (a -> b) -> VarEnv a -> VarEnv b
 modifyVarEnv	  :: (a -> a) -> VarEnv a -> Var -> VarEnv a
@@ -355,6 +387,8 @@ extendVarEnvList = addListToUFM
 plusVarEnv_C	 = plusUFM_C
 delVarEnvList	 = delListFromUFM
 delVarEnv	 = delFromUFM
+minusVarEnv      = minusUFM
+intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))
 plusVarEnv	 = plusUFM
 lookupVarEnv	 = lookupUFM
 lookupWithDefaultVarEnv = lookupWithDefaultUFM