Add uniqSetAny and uniqSetAll and use them
[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, anyUFM, allUFM,
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, ufmToIntMap,
70 joinUFM, pprUniqFM, pprUFM, pluralUFM
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
279
280 foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
281 mapUFM f (UFM m) = UFM (M.map f m)
282 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
283 filterUFM p (UFM m) = UFM (M.filter p m)
284 filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
285 partitionUFM p (UFM m) = case M.partition p m of
286 (left, right) -> (UFM left, UFM right)
287
288 sizeUFM (UFM m) = M.size m
289 elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
290 elemUFM_Directly u (UFM m) = M.member (getKey u) m
291
292 splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of
293 (less, equal, greater) -> (UFM less, equal, UFM greater)
294 lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
295 lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
296 lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
297 lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
298 keysUFM (UFM m) = map getUnique $ M.keys m
299 eltsUFM (UFM m) = M.elems m
300 ufmToSet_Directly (UFM m) = M.keysSet m
301 ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
302
303 anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool
304 anyUFM p (UFM m) = M.fold ((||) . p) False m
305
306 allUFM :: (elt -> Bool) -> UniqFM elt -> Bool
307 allUFM p (UFM m) = M.fold ((&&) . p) True m
308
309 ufmToIntMap :: UniqFM elt -> M.IntMap elt
310 ufmToIntMap (UFM m) = m
311
312 -- Hoopl
313 joinUFM :: JoinFun v -> JoinFun (UniqFM v)
314 joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
315 where add k new_v (ch, joinmap) =
316 case lookupUFM_Directly joinmap k of
317 Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
318 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
319 (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
320 (NoChange, _) -> (ch, joinmap)
321
322 {-
323 ************************************************************************
324 * *
325 \subsection{Output-ery}
326 * *
327 ************************************************************************
328 -}
329
330 instance Outputable a => Outputable (UniqFM a) where
331 ppr ufm = pprUniqFM ppr ufm
332
333 pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
334 pprUniqFM ppr_elt ufm
335 = brackets $ fsep $ punctuate comma $
336 [ ppr uq <+> text ":->" <+> ppr_elt elt
337 | (uq, elt) <- ufmToList ufm ]
338
339 -- | Pretty-print a non-deterministic set.
340 -- The order of variables is non-deterministic and for pretty-printing that
341 -- shouldn't be a problem.
342 -- Having this function helps contain the non-determinism created with
343 -- eltsUFM.
344 pprUFM :: ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
345 -> UniqFM a -- ^ The things to be pretty printed
346 -> SDoc -- ^ 'SDoc' where the things have been pretty
347 -- printed
348 pprUFM pp ufm = pp (eltsUFM ufm)
349
350 -- | Determines the pluralisation suffix appropriate for the length of a set
351 -- in the same way that plural from Outputable does for lists.
352 pluralUFM :: UniqFM a -> SDoc
353 pluralUFM ufm
354 | sizeUFM ufm == 1 = empty
355 | otherwise = char 's'