025fcef9e06fbd30f2581b8862f11697a399ed1a
[packages/base.git] / Data / FiniteMap.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Module : Data.FiniteMap
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : provisional
9 -- Portability : portable
10 --
11 -- $Id: FiniteMap.hs,v 1.1 2001/08/17 12:44:54 simonmar Exp $
12 --
13 -- A finite map implementation, derived from the paper:
14 -- S Adams, "Efficient sets: a balancing act"
15 -- Journal of functional programming 3(4) Oct 1993, pp553-562
16 --
17 -- ToDo: clean up, remove the COMPILING_GHC stuff.
18 --
19 -----------------------------------------------------------------------------
20
21 -- The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
22 -- near the end (only \tr{#ifdef COMPILING_GHC}).
23
24 #ifdef COMPILING_GHC
25 #include "HsVersions.h"
26 #define IF_NOT_GHC(a) {--}
27 #else
28 #define ASSERT(e) {--}
29 #define IF_NOT_GHC(a) a
30 #define COMMA ,
31 #define _tagCmp compare
32 #define _LT LT
33 #define _GT GT
34 #define _EQ EQ
35 #endif
36
37 #if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */
38 #define OUTPUTABLE_key , Outputable key
39 #else
40 #define OUTPUTABLE_key {--}
41 #endif
42
43 module Data.FiniteMap (
44 FiniteMap, -- abstract type
45
46 emptyFM, unitFM, listToFM,
47
48 addToFM,
49 addToFM_C,
50 addListToFM,
51 addListToFM_C,
52 IF_NOT_GHC(delFromFM COMMA)
53 delListFromFM,
54
55 plusFM,
56 plusFM_C,
57 minusFM,
58 foldFM,
59
60 IF_NOT_GHC(intersectFM COMMA)
61 IF_NOT_GHC(intersectFM_C COMMA)
62 IF_NOT_GHC(mapFM COMMA filterFM COMMA)
63
64 sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
65
66 fmToList, keysFM, eltsFM
67
68 #ifdef COMPILING_GHC
69 , bagToFM
70 #endif
71 ) where
72
73 import Prelude
74
75 import Data.Maybe ( isJust )
76 #ifdef __GLASGOW_HASKELL__
77 import GHC.Base
78 #endif
79
80 #ifdef COMPILING_GHC
81 IMP_Ubiq(){-uitous-}
82 # ifdef DEBUG
83 import Pretty
84 # endif
85 import Bag ( foldBag )
86
87 # if ! OMIT_NATIVE_CODEGEN
88 # define IF_NCG(a) a
89 # else
90 # define IF_NCG(a) {--}
91 # endif
92 #endif
93
94 -- SIGH: but we use unboxed "sizes"...
95 #if __GLASGOW_HASKELL__
96 #define IF_GHC(a,b) a
97 #else /* not GHC */
98 #define IF_GHC(a,b) b
99 #endif /* not GHC */
100
101
102 -- ---------------------------------------------------------------------------
103 -- The signature of the module
104
105 -- BUILDING
106 emptyFM :: FiniteMap key elt
107 unitFM :: key -> elt -> FiniteMap key elt
108 listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
109 -- In the case of duplicates, the last is taken
110 #ifdef COMPILING_GHC
111 bagToFM :: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt
112 -- In the case of duplicates, who knows which is taken
113 #endif
114
115 -- ADDING AND DELETING
116 -- Throws away any previous binding
117 -- In the list case, the items are added starting with the
118 -- first one in the list
119 addToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt
120 addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
121
122 -- Combines with previous binding
123 -- In the combining function, the first argument is the "old" element,
124 -- while the second is the "new" one.
125 addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
126 -> FiniteMap key elt -> key -> elt
127 -> FiniteMap key elt
128 addListToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
129 -> FiniteMap key elt -> [(key,elt)]
130 -> FiniteMap key elt
131
132 -- Deletion doesn't complain if you try to delete something
133 -- which isn't there
134 delFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
135 delListFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt
136
137 -- COMBINING
138 -- Bindings in right argument shadow those in the left
139 plusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
140 -> FiniteMap key elt
141
142 -- Combines bindings for the same thing with the given function
143 plusFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
144 -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
145
146 minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
147 -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
148
149 intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
150 intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt1 -> elt2 -> elt3)
151 -> FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt3
152
153 -- MAPPING, FOLDING, FILTERING
154 foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
155 mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
156 filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
157 -> FiniteMap key elt -> FiniteMap key elt
158
159 -- INTERROGATING
160 sizeFM :: FiniteMap key elt -> Int
161 isEmptyFM :: FiniteMap key elt -> Bool
162
163 elemFM :: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool
164 lookupFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt
165 lookupWithDefaultFM
166 :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt
167 -- lookupWithDefaultFM supplies a "default" elt
168 -- to return for an unmapped key
169
170 -- LISTIFYING
171 fmToList :: FiniteMap key elt -> [(key,elt)]
172 keysFM :: FiniteMap key elt -> [key]
173 eltsFM :: FiniteMap key elt -> [elt]
174
175 -- ---------------------------------------------------------------------------
176 -- The @FiniteMap@ data type, and building of same
177
178 -- Invariants about @FiniteMap@:
179 --
180 -- * all keys in a FiniteMap are distinct
181 --
182 -- * all keys in left subtree are $<$ key in Branch and
183 -- all keys in right subtree are $>$ key in Branch
184 --
185 -- * size field of a Branch gives number of Branch nodes in the tree
186 --
187 -- * size of left subtree is differs from size of right subtree by a
188 -- factor of at most \tr{sIZE_RATIO}
189
190 data FiniteMap key elt
191 = EmptyFM
192 | Branch key elt -- Key and elt stored here
193 IF_GHC(Int#,Int{-STRICT-}) -- Size >= 1
194 (FiniteMap key elt) -- Children
195 (FiniteMap key elt)
196
197
198 emptyFM = EmptyFM
199 {-
200 emptyFM
201 = Branch bottom bottom IF_GHC(0#,0) bottom bottom
202 where
203 bottom = panic "emptyFM"
204 -}
205
206 -- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
207
208 unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
209
210 listToFM = addListToFM emptyFM
211
212 #ifdef COMPILING_GHC
213 bagToFM = foldBag plusFM (\ (k,v) -> unitFM k v) emptyFM
214 #endif
215
216
217 -- ---------------------------------------------------------------------------
218 -- Adding to and deleting from @FiniteMaps@
219
220 addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt
221
222 addToFM_C combiner EmptyFM key elt = unitFM key elt
223 addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
224 #ifdef __GLASGOW_HASKELL__
225 = case _tagCmp new_key key of
226 _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
227 _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
228 _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
229 #else
230 | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
231 | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
232 | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r
233 #endif
234
235 addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs
236
237 addListToFM_C combiner fm key_elt_pairs
238 = foldl add fm key_elt_pairs -- foldl adds from the left
239 where
240 add fmap (key,elt) = addToFM_C combiner fmap key elt
241
242
243 delFromFM EmptyFM del_key = emptyFM
244 delFromFM (Branch key elt size fm_l fm_r) del_key
245 #if __GLASGOW_HASKELL__
246 = case _tagCmp del_key key of
247 _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
248 _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
249 _EQ -> glueBal fm_l fm_r
250 #else
251 | del_key > key
252 = mkBalBranch key elt fm_l (delFromFM fm_r del_key)
253
254 | del_key < key
255 = mkBalBranch key elt (delFromFM fm_l del_key) fm_r
256
257 | key == del_key
258 = glueBal fm_l fm_r
259 #endif
260
261 delListFromFM fm keys = foldl delFromFM fm keys
262
263 -- ---------------------------------------------------------------------------
264 -- Combining @FiniteMaps@
265
266 plusFM_C combiner EmptyFM fm2 = fm2
267 plusFM_C combiner fm1 EmptyFM = fm1
268 plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
269 = mkVBalBranch split_key new_elt
270 (plusFM_C combiner lts left)
271 (plusFM_C combiner gts right)
272 where
273 lts = splitLT fm1 split_key
274 gts = splitGT fm1 split_key
275 new_elt = case lookupFM fm1 split_key of
276 Nothing -> elt2
277 Just elt1 -> combiner elt1 elt2
278
279 -- It's worth doing plusFM specially, because we don't need
280 -- to do the lookup in fm1.
281
282 plusFM EmptyFM fm2 = fm2
283 plusFM fm1 EmptyFM = fm1
284 plusFM fm1 (Branch split_key elt1 _ left right)
285 = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
286 where
287 lts = splitLT fm1 split_key
288 gts = splitGT fm1 split_key
289
290 minusFM EmptyFM fm2 = emptyFM
291 minusFM fm1 EmptyFM = fm1
292 minusFM fm1 (Branch split_key elt _ left right)
293 = glueVBal (minusFM lts left) (minusFM gts right)
294 -- The two can be way different, so we need glueVBal
295 where
296 lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
297 gts = splitGT fm1 split_key -- are not in either.
298
299 intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2
300
301 intersectFM_C combiner fm1 EmptyFM = emptyFM
302 intersectFM_C combiner EmptyFM fm2 = emptyFM
303 intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
304
305 | isJust maybe_elt1 -- split_elt *is* in intersection
306 = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
307 (intersectFM_C combiner gts right)
308
309 | otherwise -- split_elt is *not* in intersection
310 = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
311
312 where
313 lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
314 gts = splitGT fm1 split_key -- are not in either.
315
316 maybe_elt1 = lookupFM fm1 split_key
317 Just elt1 = maybe_elt1
318
319
320 -- ---------------------------------------------------------------------------
321 -- Mapping, folding, and filtering with @FiniteMaps@
322
323 foldFM k z EmptyFM = z
324 foldFM k z (Branch key elt _ fm_l fm_r)
325 = foldFM k (k key elt (foldFM k z fm_r)) fm_l
326
327 mapFM f EmptyFM = emptyFM
328 mapFM f (Branch key elt size fm_l fm_r)
329 = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
330
331 filterFM p EmptyFM = emptyFM
332 filterFM p (Branch key elt _ fm_l fm_r)
333 | p key elt -- Keep the item
334 = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)
335
336 | otherwise -- Drop the item
337 = glueVBal (filterFM p fm_l) (filterFM p fm_r)
338
339
340 -- ---------------------------------------------------------------------------
341 -- Interrogating @FiniteMaps@
342
343 --{-# INLINE sizeFM #-}
344 sizeFM EmptyFM = 0
345 sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size)
346
347 isEmptyFM fm = sizeFM fm == 0
348
349 lookupFM EmptyFM key = Nothing
350 lookupFM (Branch key elt _ fm_l fm_r) key_to_find
351 #if __GLASGOW_HASKELL__
352 = case _tagCmp key_to_find key of
353 _LT -> lookupFM fm_l key_to_find
354 _GT -> lookupFM fm_r key_to_find
355 _EQ -> Just elt
356 #else
357 | key_to_find < key = lookupFM fm_l key_to_find
358 | key_to_find > key = lookupFM fm_r key_to_find
359 | otherwise = Just elt
360 #endif
361
362 key `elemFM` fm
363 = case (lookupFM fm key) of { Nothing -> False; Just elt -> True }
364
365 lookupWithDefaultFM fm deflt key
366 = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
367
368
369 -- ---------------------------------------------------------------------------
370 -- Listifying @FiniteMaps@
371
372 fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
373 keysFM fm = foldFM (\ key elt rest -> key : rest) [] fm
374 eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm
375
376
377 -- ---------------------------------------------------------------------------
378 -- The implementation of balancing
379
380 -- Basic construction of a @FiniteMap@:
381
382 -- @mkBranch@ simply gets the size component right. This is the ONLY
383 -- (non-trivial) place the Branch object is built, so the ASSERTion
384 -- recursively checks consistency. (The trivial use of Branch is in
385 -- @unitFM@.)
386
387 sIZE_RATIO :: Int
388 sIZE_RATIO = 5
389
390 mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only
391 => Int
392 -> key -> elt
393 -> FiniteMap key elt -> FiniteMap key elt
394 -> FiniteMap key elt
395
396 mkBranch which key elt fm_l fm_r
397 = --ASSERT( left_ok && right_ok && balance_ok )
398 #if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
399 if not ( left_ok && right_ok && balance_ok ) then
400 pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok],
401 ppr PprDebug key,
402 ppr PprDebug fm_l,
403 ppr PprDebug fm_r])
404 else
405 #endif
406 let
407 result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r
408 in
409 -- if sizeFM result <= 8 then
410 result
411 -- else
412 -- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
413 -- result
414 -- )
415 where
416 left_ok = case fm_l of
417 EmptyFM -> True
418 Branch left_key _ _ _ _ -> let
419 biggest_left_key = fst (findMax fm_l)
420 in
421 biggest_left_key < key
422 right_ok = case fm_r of
423 EmptyFM -> True
424 Branch right_key _ _ _ _ -> let
425 smallest_right_key = fst (findMin fm_r)
426 in
427 key < smallest_right_key
428 balance_ok = True -- sigh
429 {- LATER:
430 balance_ok
431 = -- Both subtrees have one or no elements...
432 (left_size + right_size <= 1)
433 -- NO || left_size == 0 -- ???
434 -- NO || right_size == 0 -- ???
435 -- ... or the number of elements in a subtree does not exceed
436 -- sIZE_RATIO times the number of elements in the other subtree
437 || (left_size * sIZE_RATIO >= right_size &&
438 right_size * sIZE_RATIO >= left_size)
439 -}
440
441 left_size = sizeFM fm_l
442 right_size = sizeFM fm_r
443
444 #if __GLASGOW_HASKELL__
445 unbox :: Int -> Int#
446 unbox (I# size) = size
447 #else
448 unbox :: Int -> Int
449 unbox x = x
450 #endif
451
452
453 -- ---------------------------------------------------------------------------
454 -- {\em Balanced} construction of a @FiniteMap@
455
456 -- @mkBalBranch@ rebalances, assuming that the subtrees aren't too far
457 -- out of whack.
458
459 mkBalBranch :: (Ord key OUTPUTABLE_key)
460 => key -> elt
461 -> FiniteMap key elt -> FiniteMap key elt
462 -> FiniteMap key elt
463
464 mkBalBranch key elt fm_L fm_R
465
466 | size_l + size_r < 2
467 = mkBranch 1{-which-} key elt fm_L fm_R
468
469 | size_r > sIZE_RATIO * size_l -- Right tree too big
470 = case fm_R of
471 Branch _ _ _ fm_rl fm_rr
472 | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
473 | otherwise -> double_L fm_L fm_R
474 -- Other case impossible
475
476 | size_l > sIZE_RATIO * size_r -- Left tree too big
477 = case fm_L of
478 Branch _ _ _ fm_ll fm_lr
479 | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
480 | otherwise -> double_R fm_L fm_R
481 -- Other case impossible
482
483 | otherwise -- No imbalance
484 = mkBranch 2{-which-} key elt fm_L fm_R
485
486 where
487 size_l = sizeFM fm_L
488 size_r = sizeFM fm_R
489
490 single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
491 = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
492
493 double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
494 = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll)
495 (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
496
497 single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
498 = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)
499
500 double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
501 = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl)
502 (mkBranch 12{-which-} key elt fm_lrr fm_r)
503
504
505 mkVBalBranch :: (Ord key OUTPUTABLE_key)
506 => key -> elt
507 -> FiniteMap key elt -> FiniteMap key elt
508 -> FiniteMap key elt
509
510 -- Assert: in any call to (mkVBalBranch_C comb key elt l r),
511 -- (a) all keys in l are < all keys in r
512 -- (b) all keys in l are < key
513 -- (c) all keys in r are > key
514
515 mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
516 mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
517
518 mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
519 fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
520 | sIZE_RATIO * size_l < size_r
521 = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
522
523 | sIZE_RATIO * size_r < size_l
524 = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
525
526 | otherwise
527 = mkBranch 13{-which-} key elt fm_l fm_r
528
529 where
530 size_l = sizeFM fm_l
531 size_r = sizeFM fm_r
532
533 -- ---------------------------------------------------------------------------
534 -- Gluing two trees together
535
536 -- @glueBal@ assumes its two arguments aren't too far out of whack, just
537 -- like @mkBalBranch@. But: all keys in first arg are $<$ all keys in
538 -- second.
539
540 glueBal :: (Ord key OUTPUTABLE_key)
541 => FiniteMap key elt -> FiniteMap key elt
542 -> FiniteMap key elt
543
544 glueBal EmptyFM fm2 = fm2
545 glueBal fm1 EmptyFM = fm1
546 glueBal fm1 fm2
547 -- The case analysis here (absent in Adams' program) is really to deal
548 -- with the case where fm2 is a singleton. Then deleting the minimum means
549 -- we pass an empty tree to mkBalBranch, which breaks its invariant.
550 | sizeFM fm2 > sizeFM fm1
551 = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
552
553 | otherwise
554 = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
555 where
556 (mid_key1, mid_elt1) = findMax fm1
557 (mid_key2, mid_elt2) = findMin fm2
558
559 -- @glueVBal@ copes with arguments which can be of any size.
560 -- But: all keys in first arg are $<$ all keys in second.
561
562 glueVBal :: (Ord key OUTPUTABLE_key)
563 => FiniteMap key elt -> FiniteMap key elt
564 -> FiniteMap key elt
565
566 glueVBal EmptyFM fm2 = fm2
567 glueVBal fm1 EmptyFM = fm1
568 glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
569 fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
570 | sIZE_RATIO * size_l < size_r
571 = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
572
573 | sIZE_RATIO * size_r < size_l
574 = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
575
576 | otherwise -- We now need the same two cases as in glueBal above.
577 = glueBal fm_l fm_r
578 where
579 size_l = sizeFM fm_l
580 size_r = sizeFM fm_r
581
582
583 -- ---------------------------------------------------------------------------
584 -- Local utilities
585
586 splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
587
588 -- splitLT fm split_key = fm restricted to keys < split_key
589 -- splitGT fm split_key = fm restricted to keys > split_key
590
591 splitLT EmptyFM split_key = emptyFM
592 splitLT (Branch key elt _ fm_l fm_r) split_key
593 #if __GLASGOW_HASKELL__
594 = case _tagCmp split_key key of
595 _LT -> splitLT fm_l split_key
596 _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
597 _EQ -> fm_l
598 #else
599 | split_key < key = splitLT fm_l split_key
600 | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key)
601 | otherwise = fm_l
602 #endif
603
604 splitGT EmptyFM split_key = emptyFM
605 splitGT (Branch key elt _ fm_l fm_r) split_key
606 #if __GLASGOW_HASKELL__
607 = case _tagCmp split_key key of
608 _GT -> splitGT fm_r split_key
609 _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
610 _EQ -> fm_r
611 #else
612 | split_key > key = splitGT fm_r split_key
613 | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r
614 | otherwise = fm_r
615 #endif
616
617 findMin :: FiniteMap key elt -> (key,elt)
618 findMin (Branch key elt _ EmptyFM _) = (key,elt)
619 findMin (Branch key elt _ fm_l _) = findMin fm_l
620
621 deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
622 deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r
623 deleteMin (Branch key elt _ fm_l fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r
624
625 findMax :: FiniteMap key elt -> (key,elt)
626 findMax (Branch key elt _ _ EmptyFM) = (key,elt)
627 findMax (Branch key elt _ _ fm_r) = findMax fm_r
628
629 deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
630 deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l
631 deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
632
633
634 -- ---------------------------------------------------------------------------
635 -- Output-ery
636
637 #if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
638
639 instance (Outputable key) => Outputable (FiniteMap key elt) where
640 ppr sty fm = pprX sty fm
641
642 pprX sty EmptyFM = ppChar '!'
643 pprX sty (Branch key elt sz fm_l fm_r)
644 = ppBesides [ppLparen, pprX sty fm_l, ppSP,
645 ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP,
646 pprX sty fm_r, ppRparen]
647 #endif
648
649 #ifndef COMPILING_GHC
650 instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
651 fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
652 (fmToList fm_1 == fmToList fm_2)
653
654 {- NO: not clear what The Right Thing to do is:
655 instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
656 fm_1 <= fm_2 = (sizeFM fm_1 <= sizeFM fm_2) && -- quick test
657 (fmToList fm_1 <= fmToList fm_2)
658 -}
659 #endif
660
661 -- ---------------------------------------------------------------------------
662 -- Efficiency pragmas for GHC
663
664 -- When the FiniteMap module is used in GHC, we specialise it for
665 -- \tr{Uniques}, for dastardly efficiency reasons.
666
667 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3)
668
669 {-# SPECIALIZE addListToFM
670 :: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
671 , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt
672 IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
673 #-}
674 {-# SPECIALIZE addListToFM_C
675 :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt
676 , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
677 IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
678 #-}
679 {-# SPECIALIZE addToFM
680 :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
681 , FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
682 , FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt
683 , FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt
684 , FiniteMap OrigName elt -> OrigName -> elt -> FiniteMap OrigName elt
685 IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
686 #-}
687 {-# SPECIALIZE addToFM_C
688 :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt
689 , (elt -> elt -> elt) -> FiniteMap (OrigName, OrigName) elt -> (OrigName, OrigName) -> elt -> FiniteMap (OrigName, OrigName) elt
690 , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
691 IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
692 #-}
693 {-# SPECIALIZE bagToFM
694 :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt
695 #-}
696 {-# SPECIALIZE delListFromFM
697 :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt
698 , FiniteMap OrigName elt -> [OrigName] -> FiniteMap OrigName elt
699 , FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt
700 IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
701 #-}
702 {-# SPECIALIZE listToFM
703 :: [([Char],elt)] -> FiniteMap [Char] elt
704 , [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
705 , [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
706 , [(OrigName,elt)] -> FiniteMap OrigName elt
707 IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
708 #-}
709 {-# SPECIALIZE lookupFM
710 :: FiniteMap CLabel elt -> CLabel -> Maybe elt
711 , FiniteMap [Char] elt -> [Char] -> Maybe elt
712 , FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt
713 , FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
714 , FiniteMap OrigName elt -> OrigName -> Maybe elt
715 , FiniteMap (OrigName,OrigName) elt -> (OrigName,OrigName) -> Maybe elt
716 , FiniteMap RdrName elt -> RdrName -> Maybe elt
717 , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
718 IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt)
719 #-}
720 {-# SPECIALIZE lookupWithDefaultFM
721 :: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt
722 IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt)
723 #-}
724 {-# SPECIALIZE plusFM
725 :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt
726 , FiniteMap OrigName elt -> FiniteMap OrigName elt -> FiniteMap OrigName elt
727 , FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
728 IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
729 #-}
730 {-# SPECIALIZE plusFM_C
731 :: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
732 IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
733 #-}
734
735 #endif {- compiling for GHC -}