Role problems pervent GND from happening
[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 plusUFM,
52 plusUFM_C,
53 plusUFM_CD,
54 minusUFM,
55 intersectUFM,
56 intersectUFM_C,
57 foldUFM, foldUFM_Directly,
58 mapUFM, mapUFM_Directly,
59 elemUFM, elemUFM_Directly,
60 filterUFM, filterUFM_Directly, partitionUFM,
61 sizeUFM,
62 isNullUFM,
63 lookupUFM, lookupUFM_Directly,
64 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
65 eltsUFM, keysUFM, splitUFM,
66 ufmToSet_Directly,
67 ufmToList,
68 joinUFM, pprUniqFM
69 ) where
70
71 import FastString
72 import Unique ( Uniquable(..), Unique, getKey )
73 import Outputable
74
75 import Compiler.Hoopl hiding (Unique)
76
77 import qualified Data.IntMap as M
78 import qualified Data.IntSet as S
79 import qualified Data.Foldable as Foldable
80 import qualified Data.Traversable as Traversable
81 import Data.Typeable
82 import Data.Data
83 #if __GLASGOW_HASKELL__ < 709
84 import Data.Monoid
85 #endif
86
87 {-
88 ************************************************************************
89 * *
90 \subsection{The signature of the module}
91 * *
92 ************************************************************************
93 -}
94
95 emptyUFM :: UniqFM elt
96 isNullUFM :: UniqFM elt -> Bool
97 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
98 unitDirectlyUFM -- got the Unique already
99 :: Unique -> elt -> UniqFM elt
100 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
101 listToUFM_Directly
102 :: [(Unique, elt)] -> UniqFM elt
103 listToUFM_C :: Uniquable key => (elt -> elt -> elt)
104 -> [(key, elt)]
105 -> UniqFM elt
106
107 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
108 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
109 addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
110 addToUFM_Directly
111 :: UniqFM elt -> Unique -> elt -> UniqFM elt
112
113 addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
114 -> UniqFM elt -- old
115 -> key -> elt -- new
116 -> UniqFM elt -- result
117
118 addToUFM_Acc :: Uniquable key =>
119 (elt -> elts -> elts) -- Add to existing
120 -> (elt -> elts) -- New element
121 -> UniqFM elts -- old
122 -> key -> elt -- new
123 -> UniqFM elts -- result
124
125 alterUFM :: Uniquable key =>
126 (Maybe elt -> Maybe elt) -- How to adjust
127 -> UniqFM elt -- old
128 -> key -- new
129 -> UniqFM elt -- result
130
131 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
132 -> UniqFM elt -> [(key,elt)]
133 -> UniqFM elt
134
135 adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
136 adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
137
138 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
139 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
140 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
141
142 -- Bindings in right argument shadow those in the left
143 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
144
145 plusUFM_C :: (elt -> elt -> elt)
146 -> UniqFM elt -> UniqFM elt -> UniqFM elt
147
148 -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
149 -- combinding function and `d1` resp. `d2` as the default value if
150 -- there is no entry in `m1` reps. `m2`. The domain is the union of
151 -- the domains of `m1` and `m2`.
152 --
153 -- Representative example:
154 --
155 -- @
156 -- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42
157 -- == {A: f 1 42, B: f 2 3, C: f 23 4 }
158 -- @
159 plusUFM_CD :: (elt -> elt -> elt)
160 -> UniqFM elt -> elt -> UniqFM elt -> elt -> UniqFM elt
161
162 minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
163
164 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
165 intersectUFM_C :: (elt1 -> elt2 -> elt3)
166 -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
167
168 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
169 foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
170 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
171 mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
172 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
173 filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
174 partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)
175
176 sizeUFM :: UniqFM elt -> Int
177 --hashUFM :: UniqFM elt -> Int
178 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
179 elemUFM_Directly:: Unique -> UniqFM elt -> Bool
180
181 splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
182 -- Splits a UFM into things less than, equal to, and greater than the key
183 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
184 lookupUFM_Directly -- when you've got the Unique already
185 :: UniqFM elt -> Unique -> Maybe elt
186 lookupWithDefaultUFM
187 :: Uniquable key => UniqFM elt -> elt -> key -> elt
188 lookupWithDefaultUFM_Directly
189 :: UniqFM elt -> elt -> Unique -> elt
190 keysUFM :: UniqFM elt -> [Unique] -- Get the keys
191 eltsUFM :: UniqFM elt -> [elt]
192 ufmToSet_Directly :: UniqFM elt -> S.IntSet
193 ufmToList :: UniqFM elt -> [(Unique, elt)]
194
195 {-
196 ************************************************************************
197 * *
198 \subsection{Monoid interface}
199 * *
200 ************************************************************************
201 -}
202
203 instance Monoid (UniqFM a) where
204 mempty = emptyUFM
205 mappend = plusUFM
206
207 {-
208 ************************************************************************
209 * *
210 \subsection{Implementation using ``Data.IntMap''}
211 * *
212 ************************************************************************
213 -}
214
215 newtype UniqFM ele = UFM (M.IntMap ele)
216 deriving (Data, Eq, Functor, Traversable.Traversable,
217 Typeable)
218
219 deriving instance Foldable.Foldable UniqFM
220
221 emptyUFM = UFM M.empty
222 isNullUFM (UFM m) = M.null m
223 unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
224 unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
225 listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM
226 listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
227 listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM
228
229 alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)
230 addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
231 addListToUFM = foldl (\m (k, v) -> addToUFM m k v)
232 addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)
233 addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
234
235 -- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
236 addToUFM_C f (UFM m) k v =
237 UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
238 addToUFM_Acc exi new (UFM m) k v =
239 UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
240 addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
241
242 adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
243 adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
244
245 delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
246 delListFromUFM = foldl delFromUFM
247 delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
248
249 -- M.union is left-biased, plusUFM should be right-biased.
250 plusUFM (UFM x) (UFM y) = UFM (M.union y x)
251 -- Note (M.union y x), with arguments flipped
252 -- M.union is left-biased, plusUFM should be right-biased.
253
254 plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
255
256 plusUFM_CD f (UFM xm) dx (UFM ym) dy
257 = UFM $ M.mergeWithKey
258 (\_ x y -> Just (x `f` y))
259 (M.map (\x -> x `f` dy))
260 (M.map (\y -> dx `f` y))
261 xm ym
262 minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
263 intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
264 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
265
266 foldUFM k z (UFM m) = M.fold k z m
267 foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
268 mapUFM f (UFM m) = UFM (M.map f m)
269 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
270 filterUFM p (UFM m) = UFM (M.filter p m)
271 filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
272 partitionUFM p (UFM m) = case M.partition p m of
273 (left, right) -> (UFM left, UFM right)
274
275 sizeUFM (UFM m) = M.size m
276 elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
277 elemUFM_Directly u (UFM m) = M.member (getKey u) m
278
279 splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of
280 (less, equal, greater) -> (UFM less, equal, UFM greater)
281 lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
282 lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
283 lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
284 lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
285 keysUFM (UFM m) = map getUnique $ M.keys m
286 eltsUFM (UFM m) = M.elems m
287 ufmToSet_Directly (UFM m) = M.keysSet m
288 ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
289
290 -- Hoopl
291 joinUFM :: JoinFun v -> JoinFun (UniqFM v)
292 joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
293 where add k new_v (ch, joinmap) =
294 case lookupUFM_Directly joinmap k of
295 Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
296 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
297 (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
298 (NoChange, _) -> (ch, joinmap)
299
300 {-
301 ************************************************************************
302 * *
303 \subsection{Output-ery}
304 * *
305 ************************************************************************
306 -}
307
308 instance Outputable a => Outputable (UniqFM a) where
309 ppr ufm = pprUniqFM ppr ufm
310
311 pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
312 pprUniqFM ppr_elt ufm
313 = brackets $ fsep $ punctuate comma $
314 [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt
315 | (uq, elt) <- ufmToList ufm ]