Data/FiniteMap.hs

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