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