Check InScopeSet in substTy and provide substTyUnchecked
[ghc.git] / compiler / utils / UniqFM.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1994-1998
4
5
6 UniqFM: Specialised finite maps, for things with @Uniques@.
7
8 Basically, the things need to be in class @Uniquable@, and we use the
9 @getUnique@ method to grab their @Uniques@.
10
11 (A similar thing to @UniqSet@, as opposed to @Set@.)
12
13 The interface is based on @FiniteMap@s, but the implementation uses
14 @Data.IntMap@, which is both maintained and faster than the past
15 implementation (see commit log).
16
17 The @UniqFM@ interface maps directly to Data.IntMap, only
18 ``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased
19 and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
20 of arguments of combining function.
21 -}
22
23 {-# LANGUAGE CPP #-}
24 {-# LANGUAGE DeriveDataTypeable #-}
25 {-# LANGUAGE DeriveTraversable #-}
26 {-# LANGUAGE FlexibleContexts #-}
27 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
28 {-# LANGUAGE StandaloneDeriving #-}
29 {-# OPTIONS_GHC -Wall #-}
30
31 module UniqFM (
32 -- * Unique-keyed mappings
33 UniqFM, -- abstract type
34
35 -- ** Manipulating those mappings
36 emptyUFM,
37 unitUFM,
38 unitDirectlyUFM,
39 listToUFM,
40 listToUFM_Directly,
41 listToUFM_C,
42 addToUFM,addToUFM_C,addToUFM_Acc,
43 addListToUFM,addListToUFM_C,
44 addToUFM_Directly,
45 addListToUFM_Directly,
46 adjustUFM, alterUFM,
47 adjustUFM_Directly,
48 delFromUFM,
49 delFromUFM_Directly,
50 delListFromUFM,
51 delListFromUFM_Directly,
52 plusUFM,
53 plusUFM_C,
54 plusUFM_CD,
55 minusUFM,
56 intersectUFM,
57 intersectUFM_C,
58 disjointUFM,
59 foldUFM, foldUFM_Directly,
60 mapUFM, mapUFM_Directly,
61 elemUFM, elemUFM_Directly,
62 filterUFM, filterUFM_Directly, partitionUFM,
63 sizeUFM,
64 isNullUFM,
65 lookupUFM, lookupUFM_Directly,
66 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
67 eltsUFM, keysUFM, splitUFM,
68 ufmToSet_Directly,
69 ufmToList,
70 joinUFM, pprUniqFM
71 ) where
72
73 import Unique ( Uniquable(..), Unique, getKey )
74 import Outputable
75
76 import Compiler.Hoopl hiding (Unique)
77
78 import qualified Data.IntMap as M
79 import qualified Data.IntSet as S
80 import qualified Data.Foldable as Foldable
81 import qualified Data.Traversable as Traversable
82 import Data.Typeable
83 import Data.Data
84 #if __GLASGOW_HASKELL__ > 710
85 import Data.Semigroup ( Semigroup )
86 import qualified Data.Semigroup as Semigroup
87 #endif
88
89 {-
90 ************************************************************************
91 * *
92 \subsection{The signature of the module}
93 * *
94 ************************************************************************
95 -}
96
97 emptyUFM :: UniqFM elt
98 isNullUFM :: UniqFM elt -> Bool
99 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
100 unitDirectlyUFM -- got the Unique already
101 :: Unique -> elt -> UniqFM elt
102 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
103 listToUFM_Directly
104 :: [(Unique, elt)] -> UniqFM elt
105 listToUFM_C :: Uniquable key => (elt -> elt -> elt)
106 -> [(key, elt)]
107 -> UniqFM elt
108
109 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
110 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
111 addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
112 addToUFM_Directly
113 :: UniqFM elt -> Unique -> elt -> UniqFM elt
114
115 addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
116 -> UniqFM elt -- old
117 -> key -> elt -- new
118 -> UniqFM elt -- result
119
120 addToUFM_Acc :: Uniquable key =>
121 (elt -> elts -> elts) -- Add to existing
122 -> (elt -> elts) -- New element
123 -> UniqFM elts -- old
124 -> key -> elt -- new
125 -> UniqFM elts -- result
126
127 alterUFM :: Uniquable key =>
128 (Maybe elt -> Maybe elt) -- How to adjust
129 -> UniqFM elt -- old
130 -> key -- new
131 -> UniqFM elt -- result
132
133 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
134 -> UniqFM elt -> [(key,elt)]
135 -> UniqFM elt
136
137 adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
138 adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
139
140 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
141 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
142 delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt
143 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
144
145 -- Bindings in right argument shadow those in the left
146 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
147
148 plusUFM_C :: (elt -> elt -> elt)
149 -> UniqFM elt -> UniqFM elt -> UniqFM elt
150
151 -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
152 -- combinding function and `d1` resp. `d2` as the default value if
153 -- there is no entry in `m1` reps. `m2`. The domain is the union of
154 -- the domains of `m1` and `m2`.
155 --
156 -- Representative example:
157 --
158 -- @
159 -- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42
160 -- == {A: f 1 42, B: f 2 3, C: f 23 4 }
161 -- @
162 plusUFM_CD :: (elt -> elt -> elt)
163 -> UniqFM elt -> elt -> UniqFM elt -> elt -> UniqFM elt
164
165 minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
166
167 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
168 intersectUFM_C :: (elt1 -> elt2 -> elt3)
169 -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
170 disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
171
172 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
173 foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
174 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
175 mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
176 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
177 filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
178 partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)
179
180 sizeUFM :: UniqFM elt -> Int
181 --hashUFM :: UniqFM elt -> Int
182 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
183 elemUFM_Directly:: Unique -> UniqFM elt -> Bool
184
185 splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
186 -- Splits a UFM into things less than, equal to, and greater than the key
187 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
188 lookupUFM_Directly -- when you've got the Unique already
189 :: UniqFM elt -> Unique -> Maybe elt
190 lookupWithDefaultUFM
191 :: Uniquable key => UniqFM elt -> elt -> key -> elt
192 lookupWithDefaultUFM_Directly
193 :: UniqFM elt -> elt -> Unique -> elt
194 keysUFM :: UniqFM elt -> [Unique] -- Get the keys
195 eltsUFM :: UniqFM elt -> [elt]
196 ufmToSet_Directly :: UniqFM elt -> S.IntSet
197 ufmToList :: UniqFM elt -> [(Unique, elt)]
198
199 {-
200 ************************************************************************
201 * *
202 \subsection{Monoid interface}
203 * *
204 ************************************************************************
205 -}
206
207 #if __GLASGOW_HASKELL__ > 710
208 instance Semigroup (UniqFM a) where
209 (<>) = plusUFM
210 #endif
211
212 instance Monoid (UniqFM a) where
213 mempty = emptyUFM
214 mappend = plusUFM
215
216 {-
217 ************************************************************************
218 * *
219 \subsection{Implementation using ``Data.IntMap''}
220 * *
221 ************************************************************************
222 -}
223
224 newtype UniqFM ele = UFM (M.IntMap ele)
225 deriving (Data, Eq, Functor, Traversable.Traversable,
226 Typeable)
227
228 deriving instance Foldable.Foldable UniqFM
229
230 emptyUFM = UFM M.empty
231 isNullUFM (UFM m) = M.null m
232 unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
233 unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
234 listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM
235 listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
236 listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM
237
238 alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)
239 addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
240 addListToUFM = foldl (\m (k, v) -> addToUFM m k v)
241 addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)
242 addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
243
244 -- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
245 addToUFM_C f (UFM m) k v =
246 UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
247 addToUFM_Acc exi new (UFM m) k v =
248 UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
249 addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
250
251 adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
252 adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
253
254 delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
255 delListFromUFM = foldl delFromUFM
256 delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
257 delListFromUFM_Directly = foldl delFromUFM_Directly
258
259 -- M.union is left-biased, plusUFM should be right-biased.
260 plusUFM (UFM x) (UFM y) = UFM (M.union y x)
261 -- Note (M.union y x), with arguments flipped
262 -- M.union is left-biased, plusUFM should be right-biased.
263
264 plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
265
266 plusUFM_CD f (UFM xm) dx (UFM ym) dy
267 = UFM $ M.mergeWithKey
268 (\_ x y -> Just (x `f` y))
269 (M.map (\x -> x `f` dy))
270 (M.map (\y -> dx `f` y))
271 xm ym
272 minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
273 intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
274 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
275 disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)
276
277 foldUFM k z (UFM m) = M.fold k z m
278 foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
279 mapUFM f (UFM m) = UFM (M.map f m)
280 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
281 filterUFM p (UFM m) = UFM (M.filter p m)
282 filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
283 partitionUFM p (UFM m) = case M.partition p m of
284 (left, right) -> (UFM left, UFM right)
285
286 sizeUFM (UFM m) = M.size m
287 elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
288 elemUFM_Directly u (UFM m) = M.member (getKey u) m
289
290 splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of
291 (less, equal, greater) -> (UFM less, equal, UFM greater)
292 lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
293 lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
294 lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
295 lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
296 keysUFM (UFM m) = map getUnique $ M.keys m
297 eltsUFM (UFM m) = M.elems m
298 ufmToSet_Directly (UFM m) = M.keysSet m
299 ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
300
301 -- Hoopl
302 joinUFM :: JoinFun v -> JoinFun (UniqFM v)
303 joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
304 where add k new_v (ch, joinmap) =
305 case lookupUFM_Directly joinmap k of
306 Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
307 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
308 (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
309 (NoChange, _) -> (ch, joinmap)
310
311 {-
312 ************************************************************************
313 * *
314 \subsection{Output-ery}
315 * *
316 ************************************************************************
317 -}
318
319 instance Outputable a => Outputable (UniqFM a) where
320 ppr ufm = pprUniqFM ppr ufm
321
322 pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
323 pprUniqFM ppr_elt ufm
324 = brackets $ fsep $ punctuate comma $
325 [ ppr uq <+> text ":->" <+> ppr_elt elt
326 | (uq, elt) <- ufmToList ufm ]