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