Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / basicTypes / VarEnv.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 \begin{code}
7 {-# OPTIONS -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
12 -- for details
13
14 module VarEnv (
15         -- * Var, Id and TyVar environments (maps)
16         VarEnv, IdEnv, TyVarEnv, CoVarEnv,
17         
18         -- ** Manipulating these environments
19         emptyVarEnv, unitVarEnv, mkVarEnv,
20         elemVarEnv, varEnvElts, varEnvKeys,
21         extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList,
22         plusVarEnv, plusVarEnv_C, alterVarEnv,
23         delVarEnvList, delVarEnv,
24         minusVarEnv, intersectsVarEnv,
25         lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
26         mapVarEnv, zipVarEnv,
27         modifyVarEnv, modifyVarEnv_Directly,
28         isEmptyVarEnv, foldVarEnv, 
29         elemVarEnvByKey, lookupVarEnv_Directly,
30         filterVarEnv_Directly, restrictVarEnv,
31
32         -- * The InScopeSet type
33         InScopeSet, 
34         
35         -- ** Operations on InScopeSets
36         emptyInScopeSet, mkInScopeSet, delInScopeSet,
37         extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
38         getInScopeVars, lookupInScope, lookupInScope_Directly, 
39         unionInScope, elemInScopeSet, uniqAway,
40
41         -- * The RnEnv2 type
42         RnEnv2, 
43         
44         -- ** Operations on RnEnv2s
45         mkRnEnv2, rnBndr2, rnBndrs2,
46         rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe,
47         rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR,
48         delBndrL, delBndrR, delBndrsL, delBndrsR,
49         addRnInScopeSet,
50         rnEtaL, rnEtaR,
51         rnInScope, rnInScopeSet, lookupRnInScope,
52
53         -- * TidyEnv and its operation
54         TidyEnv, 
55         emptyTidyEnv
56     ) where
57
58 import OccName
59 import Var
60 import VarSet
61 import UniqFM
62 import Unique
63 import Util
64 import Maybes
65 import Outputable
66 import FastTypes
67 import StaticFlags
68 import FastString
69 \end{code}
70
71
72 %************************************************************************
73 %*                                                                      *
74                 In-scope sets
75 %*                                                                      *
76 %************************************************************************
77
78 \begin{code}
79 -- | A set of variables that are in scope at some point
80 data InScopeSet = InScope (VarEnv Var) FastInt
81         -- The (VarEnv Var) is just a VarSet.  But we write it like
82         -- this to remind ourselves that you can look up a Var in 
83         -- the InScopeSet. Typically the InScopeSet contains the
84         -- canonical version of the variable (e.g. with an informative
85         -- unfolding), so this lookup is useful.
86         --
87         -- INVARIANT: the VarEnv maps (the Unique of) a variable to 
88         --            a variable with the same Uniqua.  (This was not
89         --            the case in the past, when we had a grevious hack
90         --            mapping var1 to var2.     
91         -- 
92         -- The FastInt is a kind of hash-value used by uniqAway
93         -- For example, it might be the size of the set
94         -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
95
96 instance Outputable InScopeSet where
97   ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s
98
99 emptyInScopeSet :: InScopeSet
100 emptyInScopeSet = InScope emptyVarSet (_ILIT(1))
101
102 getInScopeVars ::  InScopeSet -> VarEnv Var
103 getInScopeVars (InScope vs _) = vs
104
105 mkInScopeSet :: VarEnv Var -> InScopeSet
106 mkInScopeSet in_scope = InScope in_scope (_ILIT(1))
107
108 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
109 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1))
110
111 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
112 extendInScopeSetList (InScope in_scope n) vs
113    = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
114                     (n +# iUnbox (length vs))
115
116 extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
117 extendInScopeSetSet (InScope in_scope n) vs
118    = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs))
119
120 delInScopeSet :: InScopeSet -> Var -> InScopeSet
121 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
122
123 elemInScopeSet :: Var -> InScopeSet -> Bool
124 elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope
125
126 -- | Look up a variable the 'InScopeSet'.  This lets you map from 
127 -- the variable's identity (unique) to its full value.
128 lookupInScope :: InScopeSet -> Var -> Maybe Var
129 lookupInScope (InScope in_scope _) v  = lookupVarEnv in_scope v
130
131 lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
132 lookupInScope_Directly (InScope in_scope _) uniq
133   = lookupVarEnv_Directly in_scope uniq
134
135 unionInScope :: InScopeSet -> InScopeSet -> InScopeSet
136 unionInScope (InScope s1 _) (InScope s2 n2)
137   = InScope (s1 `plusVarEnv` s2) n2
138 \end{code}
139
140 \begin{code}
141 -- | @uniqAway in_scope v@ finds a unique that is not used in the
142 -- in-scope set, and gives that to v. 
143 uniqAway :: InScopeSet -> Var -> Var
144 -- It starts with v's current unique, of course, in the hope that it won't
145 -- have to change, and thereafter uses a combination of that and the hash-code
146 -- found in the in-scope set
147 uniqAway in_scope var
148   | var `elemInScopeSet` in_scope = uniqAway' in_scope var      -- Make a new one
149   | otherwise                     = var                         -- Nothing to do
150
151 uniqAway' :: InScopeSet -> Var -> Var
152 -- This one *always* makes up a new variable
153 uniqAway' (InScope set n) var
154   = try (_ILIT(1))
155   where
156     orig_unique = getUnique var
157     try k 
158           | debugIsOn && (k ># _ILIT(1000))
159           = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
160           | uniq `elemVarSetByKey` set = try (k +# _ILIT(1))
161           | debugIsOn && opt_PprStyle_Debug && (k ># _ILIT(3))
162           = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
163             setVarUnique var uniq
164           | otherwise = setVarUnique var uniq
165           where
166             uniq = deriveUnique orig_unique (iBox (n *# k))
167 \end{code}
168
169 %************************************************************************
170 %*                                                                      *
171                 Dual renaming
172 %*                                                                      *
173 %************************************************************************
174
175 \begin{code}
176 -- | When we are comparing (or matching) types or terms, we are faced with 
177 -- \"going under\" corresponding binders.  E.g. when comparing:
178 --
179 -- > \x. e1     ~   \y. e2
180 --
181 -- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of 
182 -- things we must be careful of.  In particular, @x@ might be free in @e2@, or
183 -- y in @e1@.  So the idea is that we come up with a fresh binder that is free
184 -- in neither, and rename @x@ and @y@ respectively.  That means we must maintain:
185 --
186 -- 1. A renaming for the left-hand expression
187 --
188 -- 2. A renaming for the right-hand expressions
189 --
190 -- 3. An in-scope set
191 -- 
192 -- Furthermore, when matching, we want to be able to have an 'occurs check',
193 -- to prevent:
194 --
195 -- > \x. f   ~   \y. y
196 --
197 -- matching with [@f@ -> @y@].  So for each expression we want to know that set of
198 -- locally-bound variables. That is precisely the domain of the mappings 1.
199 -- and 2., but we must ensure that we always extend the mappings as we go in.
200 --
201 -- All of this information is bundled up in the 'RnEnv2'
202 data RnEnv2
203   = RV2 { envL     :: VarEnv Var        -- Renaming for Left term
204         , envR     :: VarEnv Var        -- Renaming for Right term
205         , in_scope :: InScopeSet }      -- In scope in left or right terms
206
207 -- The renamings envL and envR are *guaranteed* to contain a binding
208 -- for every variable bound as we go into the term, even if it is not
209 -- renamed.  That way we can ask what variables are locally bound
210 -- (inRnEnvL, inRnEnvR)
211
212 mkRnEnv2 :: InScopeSet -> RnEnv2
213 mkRnEnv2 vars = RV2     { envL     = emptyVarEnv 
214                         , envR     = emptyVarEnv
215                         , in_scope = vars }
216
217 addRnInScopeSet :: RnEnv2 -> VarEnv Var -> RnEnv2
218 addRnInScopeSet env vs
219   | isEmptyVarEnv vs = env
220   | otherwise        = env { in_scope = extendInScopeSetSet (in_scope env) vs }
221
222 rnInScope :: Var -> RnEnv2 -> Bool
223 rnInScope x env = x `elemInScopeSet` in_scope env
224
225 rnInScopeSet :: RnEnv2 -> InScopeSet
226 rnInScopeSet = in_scope
227
228 rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2
229 -- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length
230 rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR 
231
232 rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2
233 -- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term,
234 --                       and binder @bR@ in the Right term.
235 -- It finds a new binder, @new_b@,
236 -- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@
237 rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR
238   = RV2 { envL     = extendVarEnv envL bL new_b   -- See Note
239         , envR     = extendVarEnv envR bR new_b   -- [Rebinding]
240         , in_scope = extendInScopeSet in_scope new_b }
241   where
242         -- Find a new binder not in scope in either term
243     new_b | not (bL `elemInScopeSet` in_scope) = bL
244           | not (bR `elemInScopeSet` in_scope) = bR
245           | otherwise                          = uniqAway' in_scope bL
246
247         -- Note [Rebinding]
248         -- If the new var is the same as the old one, note that
249         -- the extendVarEnv *deletes* any current renaming
250         -- E.g.   (\x. \x. ...)  ~  (\y. \z. ...)
251         --
252         --   Inside \x  \y      { [x->y], [y->y],       {y} }
253         --       \x  \z         { [x->x], [y->y, z->x], {y,x} }
254
255 rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var)
256 -- ^ Similar to 'rnBndr2' but used when there's a binder on the left
257 -- side only.
258 rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
259   = (RV2 { envL     = extendVarEnv envL bL new_b
260          , envR     = envR
261          , in_scope = extendInScopeSet in_scope new_b }, new_b)
262   where
263     new_b = uniqAway in_scope bL
264
265 rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
266 -- ^ Similar to 'rnBndr2' but used when there's a binder on the right
267 -- side only.
268 rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
269   = (RV2 { envR     = extendVarEnv envR bR new_b
270          , envL     = envL
271          , in_scope = extendInScopeSet in_scope new_b }, new_b)
272   where
273     new_b = uniqAway in_scope bR
274
275 rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var)
276 -- ^ Similar to 'rnBndrL' but used for eta expansion
277 -- See Note [Eta expansion]
278 rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
279   = (RV2 { envL     = extendVarEnv envL bL new_b
280          , envR     = extendVarEnv envR new_b new_b     -- Note [Eta expansion]
281          , in_scope = extendInScopeSet in_scope new_b }, new_b)
282   where
283     new_b = uniqAway in_scope bL
284
285 rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var)
286 -- ^ Similar to 'rnBndr2' but used for eta expansion
287 -- See Note [Eta expansion]
288 rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
289   = (RV2 { envL     = extendVarEnv envL new_b new_b     -- Note [Eta expansion]
290          , envR     = extendVarEnv envR bR new_b
291          , in_scope = extendInScopeSet in_scope new_b }, new_b)
292   where
293     new_b = uniqAway in_scope bR
294
295 delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2
296 delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v 
297   = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }
298 delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v 
299   = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }
300
301 delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2
302 delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v 
303   = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }
304 delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v 
305   = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }
306
307 rnOccL, rnOccR :: RnEnv2 -> Var -> Var
308 -- ^ Look up the renaming of an occurrence in the left or right term
309 rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v
310 rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v
311
312 rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var
313 -- ^ Look up the renaming of an occurrence in the left or right term
314 rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v
315 rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v
316
317 inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
318 -- ^ Tells whether a variable is locally bound
319 inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env
320 inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env
321
322 lookupRnInScope :: RnEnv2 -> Var -> Var
323 lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v
324
325 nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2
326 -- ^ Wipe the left or right side renaming
327 nukeRnEnvL env = env { envL = emptyVarEnv }
328 nukeRnEnvR env = env { envR = emptyVarEnv }
329 \end{code}
330
331 Note [Eta expansion]
332 ~~~~~~~~~~~~~~~~~~~~
333 When matching
334      (\x.M) ~ N
335 we rename x to x' with, where x' is not in scope in 
336 either term.  Then we want to behave as if we'd seen
337      (\x'.M) ~ (\x'.N x')
338 Since x' isn't in scope in N, the form (\x'. N x') doesn't
339 capture any variables in N.  But we must nevertheless extend
340 the envR with a binding [x' -> x'], to support the occurs check.
341 For example, if we don't do this, we can get silly matches like
342         forall a.  (\y.a)  ~   v
343 succeeding with [a -> v y], which is bogus of course.
344
345
346 %************************************************************************
347 %*                                                                      *
348                 Tidying
349 %*                                                                      *
350 %************************************************************************
351
352 \begin{code}
353 -- | When tidying up print names, we keep a mapping of in-scope occ-names
354 -- (the 'TidyOccEnv') and a Var-to-Var of the current renamings
355 type TidyEnv = (TidyOccEnv, VarEnv Var)
356
357 emptyTidyEnv :: TidyEnv
358 emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
359 \end{code}
360
361
362 %************************************************************************
363 %*                                                                      *
364 \subsection{@VarEnv@s}
365 %*                                                                      *
366 %************************************************************************
367
368 \begin{code}
369 type VarEnv elt   = UniqFM elt
370 type IdEnv elt    = VarEnv elt
371 type TyVarEnv elt = VarEnv elt
372 type CoVarEnv elt = VarEnv elt
373
374 emptyVarEnv       :: VarEnv a
375 mkVarEnv          :: [(Var, a)] -> VarEnv a
376 zipVarEnv         :: [Var] -> [a] -> VarEnv a
377 unitVarEnv        :: Var -> a -> VarEnv a
378 alterVarEnv       :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a
379 extendVarEnv      :: VarEnv a -> Var -> a -> VarEnv a
380 extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
381 extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b
382 plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a
383 extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
384                   
385 lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
386 filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
387 restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a
388 delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a
389 delVarEnv         :: VarEnv a -> Var -> VarEnv a
390 minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a
391 intersectsVarEnv  :: VarEnv a -> VarEnv a -> Bool
392 plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
393 mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b
394 modifyVarEnv      :: (a -> a) -> VarEnv a -> Var -> VarEnv a
395 varEnvElts        :: VarEnv a -> [a]
396 varEnvKeys        :: VarEnv a -> [Unique]
397                   
398 isEmptyVarEnv     :: VarEnv a -> Bool
399 lookupVarEnv      :: VarEnv a -> Var -> Maybe a
400 lookupVarEnv_NF   :: VarEnv a -> Var -> a
401 lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
402 elemVarEnv        :: Var -> VarEnv a -> Bool
403 elemVarEnvByKey   :: Unique -> VarEnv a -> Bool
404 foldVarEnv        :: (a -> b -> b) -> b -> VarEnv a -> b
405 \end{code}
406
407 \begin{code}
408 elemVarEnv       = elemUFM
409 elemVarEnvByKey  = elemUFM_Directly
410 alterVarEnv      = alterUFM
411 extendVarEnv     = addToUFM
412 extendVarEnv_C   = addToUFM_C
413 extendVarEnv_Acc = addToUFM_Acc
414 extendVarEnvList = addListToUFM
415 plusVarEnv_C     = plusUFM_C
416 delVarEnvList    = delListFromUFM
417 delVarEnv        = delFromUFM
418 minusVarEnv      = minusUFM
419 intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))
420 plusVarEnv       = plusUFM
421 lookupVarEnv     = lookupUFM
422 lookupWithDefaultVarEnv = lookupWithDefaultUFM
423 mapVarEnv        = mapUFM
424 mkVarEnv         = listToUFM
425 emptyVarEnv      = emptyUFM
426 varEnvElts       = eltsUFM
427 varEnvKeys       = keysUFM
428 unitVarEnv       = unitUFM
429 isEmptyVarEnv    = isNullUFM
430 foldVarEnv       = foldUFM
431 lookupVarEnv_Directly = lookupUFM_Directly
432 filterVarEnv_Directly = filterUFM_Directly
433
434 restrictVarEnv env vs = filterVarEnv_Directly keep env
435   where
436     keep u _ = u `elemVarSetByKey` vs
437     
438 zipVarEnv tyvars tys   = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
439 lookupVarEnv_NF env id = case lookupVarEnv env id of
440                          Just xx -> xx
441                          Nothing -> panic "lookupVarEnv_NF: Nothing"
442 \end{code}
443
444 @modifyVarEnv@: Look up a thing in the VarEnv, 
445 then mash it with the modify function, and put it back.
446
447 \begin{code}
448 modifyVarEnv mangle_fn env key
449   = case (lookupVarEnv env key) of
450       Nothing -> env
451       Just xx -> extendVarEnv env key (mangle_fn xx)
452
453 modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a
454 modifyVarEnv_Directly mangle_fn env key
455   = case (lookupUFM_Directly env key) of
456       Nothing -> env
457       Just xx -> addToUFM_Directly env key (mangle_fn xx)
458 \end{code}