-
+%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section{@VarEnvs@: Variable environments}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module VarEnv (
VarEnv, IdEnv, TyVarEnv,
emptyVarEnv, unitVarEnv, mkVarEnv,
-- InScopeSet
InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
- extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
+ extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
+ modifyInScopeSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
mapInScopeSet,
-- RnEnv2 and its operations
RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, extendRnInScopeList,
- rnInScope, lookupRnInScope,
+ rnInScope, rnInScopeSet, lookupRnInScope,
-- TidyEnvs
TidyEnv, emptyTidyEnv
#include "HsVersions.h"
-import OccName ( TidyOccEnv, emptyTidyOccEnv )
-import Var ( Var, setVarUnique )
+import OccName
+import Var
import VarSet
import UniqFM
-import Unique ( Unique, deriveUnique, getUnique )
-import Util ( zipEqual, foldl2 )
-import Maybes ( orElse )
-import StaticFlags( opt_PprStyle_Debug )
+import Unique
+import Util
+import Maybes
+import StaticFlags
import Outputable
import FastTypes
\end{code}
ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s
emptyInScopeSet :: InScopeSet
-emptyInScopeSet = InScope emptyVarSet 1#
+emptyInScopeSet = InScope emptyVarSet (_ILIT(1))
getInScopeVars :: InScopeSet -> VarEnv Var
getInScopeVars (InScope vs _) = vs
mkInScopeSet :: VarEnv Var -> InScopeSet
-mkInScopeSet in_scope = InScope in_scope 1#
+mkInScopeSet in_scope = InScope in_scope (_ILIT(1))
extendInScopeSet :: InScopeSet -> Var -> InScopeSet
-extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
+extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1))
extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
extendInScopeSetList (InScope in_scope n) vs
= InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
(n +# iUnbox (length vs))
+extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
+extendInScopeSetSet (InScope in_scope n) vs
+ = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs))
+
modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
-- Exploit the fact that the in-scope "set" is really a map
-- Make old_v map to new_v
-modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
+modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# _ILIT(1))
delInScopeSet :: InScopeSet -> Var -> InScopeSet
delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
uniqAway' :: InScopeSet -> Var -> Var
-- This one *always* makes up a new variable
uniqAway' (InScope set n) var
- = try 1#
+ = try (_ILIT(1))
where
orig_unique = getUnique var
try k
#ifdef DEBUG
- | k ># 1000#
+ | k ># _ILIT(1000)
= pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
#endif
- | uniq `elemVarSetByKey` set = try (k +# 1#)
+ | uniq `elemVarSetByKey` set = try (k +# _ILIT(1))
#ifdef DEBUG
- | opt_PprStyle_Debug && k ># 3#
+ | opt_PprStyle_Debug && k ># _ILIT(3)
= pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
setVarUnique var uniq
#endif
rnInScope :: Var -> RnEnv2 -> Bool
rnInScope x env = x `elemInScopeSet` in_scope env
+rnInScopeSet :: RnEnv2 -> InScopeSet
+rnInScopeSet = in_scope
+
rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2
-- Arg lists must be of equal length
rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR
rnBndrL, rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
-- Used when there's a binder on one side or the other only
-- Useful when eta-expanding
+--
rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
= (RV2 { envL = extendVarEnv envL bL new_b
- , envR = envR
+ , envR = extendVarEnv envR new_b new_b -- Note [rnBndrLR]
, in_scope = extendInScopeSet in_scope new_b }, new_b)
where
- new_b | not (bL `elemInScopeSet` in_scope) = bL
- | otherwise = uniqAway' in_scope bL
+ new_b = uniqAway in_scope bL
rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
- = (RV2 { envL = envL
+ = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [rnBndrLR]
, envR = extendVarEnv envR bR new_b
, in_scope = extendInScopeSet in_scope new_b }, new_b)
where
- new_b | not (bR `elemInScopeSet` in_scope) = bR
- | otherwise = uniqAway' in_scope bR
+ 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
rnOccL, rnOccR :: RnEnv2 -> Var -> Var
-- Look up the renaming of an occurrence in the left or right term
projects / ghc-hetmet.git / blobdiff