X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FVarEnv.lhs;h=393a3849dae3a3514776679e53fe1ed41212d0c9;hb=e4fd736410f1f62c7a176e35a78751112390cd63;hp=ed0986345ae6b7486aae25ddd19343a0a1b1b8df;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs
index ed09863..393a384 100644
--- a/ghc/compiler/basicTypes/VarEnv.lhs
+++ b/ghc/compiler/basicTypes/VarEnv.lhs
@@ -8,20 +8,109 @@ module VarEnv (
 	VarEnv, IdEnv, TyVarEnv,
 	emptyVarEnv, unitVarEnv, mkVarEnv,
 	elemVarEnv, rngVarEnv,
-	extendVarEnv, extendVarEnvList,
+	extendVarEnv, extendVarEnv_C, extendVarEnvList,
 	plusVarEnv, plusVarEnv_C,
 	delVarEnvList, delVarEnv,
-	lookupVarEnv, lookupVarEnv_NF,
+	lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
 	mapVarEnv, zipVarEnv,
 	modifyVarEnv, modifyVarEnv_Directly,
-	isEmptyVarEnv, foldVarEnv
+	isEmptyVarEnv, foldVarEnv,
+
+	-- TidyEnvs
+	TidyEnv, emptyTidyEnv,
+
+	-- SubstEnvs
+	SubstEnv, TyVarSubstEnv, SubstResult(..),
+	emptySubstEnv, substEnvEnv, elemSubstEnv,
+	mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList,
+	delSubstEnv, delSubstEnvList, noTypeSubst, isEmptySubstEnv
     ) where
 
 #include "HsVersions.h"
 
-import Var	( Var, Id )
-import UniqFM
-import Util	( zipEqual )
+import {-# SOURCE #-}	CoreSyn( CoreExpr )
+import {-# SOURCE #-}	TypeRep( Type )
+
+import BasicTypes ( OccInfo )
+import OccName	  ( TidyOccEnv, emptyTidyOccEnv )
+import Var	  ( Var, Id )
+import UniqFM  
+import Util	  ( zipEqual )
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Tidying}
+%*									*
+%************************************************************************
+
+When tidying up print names, we keep a mapping of in-scope occ-names
+(the TidyOccEnv) and a Var-to-Var of the current renamings.
+
+\begin{code}
+type TidyEnv = (TidyOccEnv, VarEnv Var)
+emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Substitution environments}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+noTys :: SubstResult -> Bool -> Bool
+noTys (DoneTy ty) no_tys = False
+noTys other	  no_tys = no_tys
+
+data SubstEnv      = SE (VarEnv SubstResult)
+			Bool		-- True => definitely no type substitutions in the env
+
+noTypeSubst :: SubstEnv -> Bool
+noTypeSubst (SE _ nt) = nt
+
+substEnvEnv :: SubstEnv -> VarEnv SubstResult
+substEnvEnv (SE env _) = env
+
+type TyVarSubstEnv = SubstEnv	-- of the form (DoneTy ty) *only*
+
+data SubstResult
+  = DoneEx CoreExpr		-- Completed term
+  | DoneId Id OccInfo		-- Completed term variable, with occurrence info; only 
+				-- used by the simplifier
+  | DoneTy Type			-- Completed type
+  | ContEx SubstEnv CoreExpr  	-- A suspended substitution
+
+emptySubstEnv :: SubstEnv
+emptySubstEnv = SE emptyVarEnv True
+
+isEmptySubstEnv :: SubstEnv -> Bool
+isEmptySubstEnv (SE s _) = isEmptyVarEnv s
+
+lookupSubstEnv :: SubstEnv -> Var -> Maybe SubstResult
+lookupSubstEnv (SE s _) v = lookupVarEnv s v
+
+elemSubstEnv :: Var -> SubstEnv -> Bool
+elemSubstEnv v (SE s _) = elemVarEnv v s
+
+extendSubstEnv :: SubstEnv -> Var -> SubstResult -> SubstEnv
+extendSubstEnv (SE s nt) v r = SE (extendVarEnv s v r) (noTys r nt)
+
+mkSubstEnv :: [Var] -> [SubstResult] -> SubstEnv
+mkSubstEnv bs vs = extendSubstEnvList emptySubstEnv bs vs
+
+extendSubstEnvList :: SubstEnv -> [Var] -> [SubstResult] -> SubstEnv
+extendSubstEnvList env	       []     []     = env
+extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVarEnv env b r) (noTys r nt)) bs rs
+
+delSubstEnv :: SubstEnv -> Var -> SubstEnv
+delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt
+
+delSubstEnvList :: SubstEnv -> [Var] -> SubstEnv
+delSubstEnvList (SE s nt) vs = SE (delVarEnvList s vs) nt
 \end{code}
 
 
@@ -37,35 +126,40 @@ type IdEnv elt    = VarEnv elt
 type TyVarEnv elt = VarEnv elt
 
 emptyVarEnv	  :: VarEnv a
-mkVarEnv	  :: [(Var fs ft, a)] -> VarEnv a
-zipVarEnv	  :: [Var fs ft] -> [a] -> VarEnv a
-unitVarEnv	  :: Var fs ft -> a -> VarEnv a
-extendVarEnv	  :: VarEnv a -> Var fs ft -> a -> VarEnv a
+mkVarEnv	  :: [(Var, a)] -> VarEnv a
+zipVarEnv	  :: [Var] -> [a] -> VarEnv a
+unitVarEnv	  :: Var -> a -> VarEnv a
+extendVarEnv	  :: VarEnv a -> Var -> a -> VarEnv a
+extendVarEnv_C	  :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
 plusVarEnv	  :: VarEnv a -> VarEnv a -> VarEnv a
-extendVarEnvList  :: VarEnv a -> [(Var fs ft, a)] -> VarEnv a
+extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
 		  
-delVarEnvList     :: VarEnv a -> [Var fs ft] -> VarEnv a
-delVarEnv	  :: VarEnv a -> Var fs ft -> VarEnv a
+delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a
+delVarEnv	  :: VarEnv a -> Var -> VarEnv a
 plusVarEnv_C	  :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
 mapVarEnv	  :: (a -> b) -> VarEnv a -> VarEnv b
-modifyVarEnv	  :: (a -> a) -> VarEnv a -> Var fs ft -> VarEnv a
+modifyVarEnv	  :: (a -> a) -> VarEnv a -> Var -> VarEnv a
 rngVarEnv	  :: VarEnv a -> [a]
 		  
 isEmptyVarEnv	  :: VarEnv a -> Bool
-lookupVarEnv	  :: VarEnv a -> Var fs ft -> Maybe a
-lookupVarEnv_NF   :: VarEnv a -> Var fs ft -> a
-elemVarEnv	  :: Var fs ft -> VarEnv a -> Bool
+lookupVarEnv	  :: VarEnv a -> Var -> Maybe a
+lookupVarEnv_NF   :: VarEnv a -> Var -> a
+lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
+elemVarEnv	  :: Var -> VarEnv a -> Bool
 foldVarEnv	  :: (a -> b -> b) -> b -> VarEnv a -> b
 \end{code}
 
 \begin{code}
 elemVarEnv       = elemUFM
 extendVarEnv	 = addToUFM
+extendVarEnv_C	 = addToUFM_C
+extendVarEnvList = addListToUFM
 plusVarEnv_C	 = plusUFM_C
 delVarEnvList	 = delListFromUFM
 delVarEnv	 = delFromUFM
 plusVarEnv	 = plusUFM
 lookupVarEnv	 = lookupUFM
+lookupWithDefaultVarEnv = lookupWithDefaultUFM
 mapVarEnv	 = mapUFM
 mkVarEnv	 = listToUFM
 emptyVarEnv	 = emptyUFM
@@ -74,8 +168,7 @@ unitVarEnv	 = unitUFM
 isEmptyVarEnv	 = isNullUFM
 foldVarEnv	 = foldUFM
 
-zipVarEnv tyvars tys       = listToUFM (zipEqual "zipVarEnv" tyvars tys)
-extendVarEnvList env pairs = plusUFM env (listToUFM pairs)
+zipVarEnv tyvars tys       = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
 lookupVarEnv_NF env id     = case (lookupVarEnv env id) of { Just xx -> xx }
 \end{code}