[project @ 2003-09-08 11:52:24 by simonmar]

[ghc-hetmet.git] / ghc / compiler / basicTypes / VarEnv.lhs

diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs
index db389ef..d219fe5 100644 (file)
--- a/ghc/compiler/basicTypes/VarEnv.lhs
+++ b/ghc/compiler/basicTypes/VarEnv.lhs
@@ -8,7 +8,7 @@ module VarEnv (
        VarEnv, IdEnv, TyVarEnv,
        emptyVarEnv, unitVarEnv, mkVarEnv,
        elemVarEnv, rngVarEnv,
-       extendVarEnv, extendVarEnvList,
+       extendVarEnv, extendVarEnv_C, extendVarEnvList,
        plusVarEnv, plusVarEnv_C,
        delVarEnvList, delVarEnv,
        lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
@@ -16,15 +16,26 @@ module VarEnv (
        modifyVarEnv, modifyVarEnv_Directly,
        isEmptyVarEnv, foldVarEnv,
 
-       TidyEnv, emptyTidyEnv
+       -- TidyEnvs
+       TidyEnv, emptyTidyEnv,
+
+       -- SubstEnvs
+       SubstEnv, TyVarSubstEnv, SubstResult(..),
+       emptySubstEnv, substEnvEnv, elemSubstEnv,
+       mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList,
+       delSubstEnv, delSubstEnvList, noTypeSubst, isEmptySubstEnv
     ) where
 
 #include "HsVersions.h"
 
-import OccName ( TidyOccEnv, emptyTidyOccEnv )
-import Var     ( Var, Id, IdOrTyVar )
-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}
 
 
@@ -38,13 +49,75 @@ 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 IdOrTyVar)
+type TidyEnv = (TidyOccEnv, VarEnv Var)
+
+emptyTidyEnv :: TidyEnv
 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}
+
+
+%************************************************************************
+%*                                                                     *
 \subsection{@VarEnv@s}
 %*                                                                     *
 %************************************************************************
@@ -59,6 +132,7 @@ 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, a)] -> VarEnv a
                  
@@ -80,6 +154,8 @@ foldVarEnv     :: (a -> b -> b) -> b -> VarEnv a -> b
 \begin{code}
 elemVarEnv       = elemUFM
 extendVarEnv    = addToUFM
+extendVarEnv_C  = addToUFM_C
+extendVarEnvList = addListToUFM
 plusVarEnv_C    = plusUFM_C
 delVarEnvList   = delListFromUFM
 delVarEnv       = delFromUFM
@@ -94,8 +170,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}