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