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