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