FiniteMap.lhs 23.8 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
2
%
% (c) The University of Glasgow 2006
3
% (c) The AQUA Project, Glasgow University, 1994-1998
4
5
6
7
8
9
10
11
12
13
14
15
16
17
%

``Finite maps'' are the heart of the compiler's
lookup-tables/environments and its implementation of sets.  Important
stuff!

This code is derived from that in the paper:
\begin{display}
	S Adams
	"Efficient sets: a balancing act"
	Journal of functional programming 3(4) Oct 1993, pp553-562
\end{display}

The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
sof's avatar
sof committed
18
near the end.
19
20
21
22
23
24

\begin{code}

module FiniteMap (
	FiniteMap,		-- abstract type

25
	emptyFM, unitFM, listToFM,
26

27
28
29
	addToFM,
	addToFM_C,
	addListToFM,
30
	addListToFM_C,
sof's avatar
sof committed
31
	delFromFM,
32
33
	delListFromFM,

34
35
	plusFM,
	plusFM_C,
36
	minusFM,
37
	foldFM,
38

39
40
	intersectFM,
	intersectFM_C,
41
	mapFM, filterFM, 
42

43
	sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
44

45
	fmToList, keysFM, eltsFM
46

47
	, bagToFM
sof's avatar
sof committed
48

49
50
    ) where

51
52
53
54
55
#include "HsVersions.h"
#define IF_NOT_GHC(a) {--}

#if defined(DEBUG_FINITEMAPS)/* NB NB NB */
#define OUTPUTABLE_key , Outputable key
sof's avatar
sof committed
56
#else
57
#define OUTPUTABLE_key {--}
sof's avatar
sof committed
58
59
#endif

60
import Maybes
61
import Bag	  ( Bag, foldrBag )
62
import Util
63
import Outputable
64

Simon Marlow's avatar
Simon Marlow committed
65
import GHC.Exts
66

67
68
import Data.List

sof's avatar
sof committed
69
#if ! OMIT_NATIVE_CODEGEN
70
#  define IF_NCG(a) a
sof's avatar
sof committed
71
#else
72
#  define IF_NCG(a) {--}
73
74
#endif

sof's avatar
sof committed
75

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
-- SIGH: but we use unboxed "sizes"...
#if __GLASGOW_HASKELL__
#define IF_GHC(a,b) a
#else /* not GHC */
#define IF_GHC(a,b) b
#endif /* not GHC */
\end{code}


%************************************************************************
%*									*
\subsection{The signature of the module}
%*									*
%************************************************************************

\begin{code}
--	BUILDING
emptyFM		:: FiniteMap key elt
94
unitFM		:: key -> elt -> FiniteMap key elt
95
96
listToFM	:: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
			-- In the case of duplicates, the last is taken
97
98
bagToFM		:: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt
			-- In the case of duplicates, who knows which is taken
99
100
101
102
103
104
105
106
107

--	ADDING AND DELETING
		   -- Throws away any previous binding
		   -- In the list case, the items are added starting with the
		   -- first one in the list
addToFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt  -> FiniteMap key elt
addListToFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt

		   -- Combines with previous binding
108
		   -- The combining fn goes (old -> new -> new)
109
addToFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
110
			   -> FiniteMap key elt -> key -> elt
111
112
			   -> FiniteMap key elt
addListToFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
113
			   -> FiniteMap key elt -> [(key,elt)]
114
115
116
117
118
119
120
121
122
123
124
125
126
			   -> FiniteMap key elt

		   -- Deletion doesn't complain if you try to delete something
		   -- which isn't there
delFromFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key   -> FiniteMap key elt
delListFromFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt

--	COMBINING
		   -- Bindings in right argument shadow those in the left
plusFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
			   -> FiniteMap key elt

		   -- Combines bindings for the same thing with the given function
127
plusFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
128
129
130
131
132
			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt

minusFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
		   -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2

133
intersectFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
134
135
intersectFM_C	:: (Ord key OUTPUTABLE_key) => (elt1 -> elt2 -> elt3)
			   -> FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt3
136
137
138
139

--	MAPPING, FOLDING, FILTERING
foldFM		:: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
mapFM		:: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
140
filterFM	:: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
141
142
			   -> FiniteMap key elt -> FiniteMap key elt

143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
--	INTERROGATING
sizeFM		:: FiniteMap key elt -> Int
isEmptyFM	:: FiniteMap key elt -> Bool

elemFM		:: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool
lookupFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt
lookupWithDefaultFM
		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt
		-- lookupWithDefaultFM supplies a "default" elt
		-- to return for an unmapped key

--	LISTIFYING
fmToList	:: FiniteMap key elt -> [(key,elt)]
keysFM		:: FiniteMap key elt -> [key]
eltsFM		:: FiniteMap key elt -> [elt]
\end{code}

%************************************************************************
%*									*
\subsection{The @FiniteMap@ data type, and building of same}
%*									*
%************************************************************************

Invariants about @FiniteMap@:
\begin{enumerate}
\item
all keys in a FiniteMap are distinct
\item
all keys in left  subtree are $<$ key in Branch and
all keys in right subtree are $>$ key in Branch
\item
size field of a Branch gives number of Branch nodes in the tree
\item
size of left subtree is differs from size of right subtree by a
factor of at most \tr{sIZE_RATIO}
\end{enumerate}

\begin{code}
data FiniteMap key elt
183
  = EmptyFM
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
  | Branch key elt	    	-- Key and elt stored here
    IF_GHC(Int#,Int{-STRICT-})	-- Size >= 1
    (FiniteMap key elt)	    	-- Children
    (FiniteMap key elt)
\end{code}

\begin{code}
emptyFM = EmptyFM
{-
emptyFM
  = Branch bottom bottom IF_GHC(0#,0) bottom bottom
  where
    bottom = panic "emptyFM"
-}

199
--  #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
200

201
unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
202

203
204
listToFM = addListToFM emptyFM

205
bagToFM = foldrBag (\(k,v) fm -> addToFM fm k v) emptyFM
206
207
208
209
210
211
212
213
214
215
216
\end{code}

%************************************************************************
%*									*
\subsection{Adding to and deleting from @FiniteMaps@}
%*									*
%************************************************************************

\begin{code}
addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt

217
addToFM_C combiner EmptyFM key elt = unitFM key elt
218
addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
219
220
221
222
  = case compare new_key key of
	LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
	GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
	EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
223
224
225
226

addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs

addListToFM_C combiner fm key_elt_pairs
227
  = foldl' add fm key_elt_pairs	-- foldl adds from the left
228
229
230
231
232
233
234
  where
    add fmap (key,elt) = addToFM_C combiner fmap key elt
\end{code}

\begin{code}
delFromFM EmptyFM del_key = emptyFM
delFromFM (Branch key elt size fm_l fm_r) del_key
235
236
237
238
  = case compare del_key key of
	GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
	LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
	EQ -> glueBal fm_l fm_r
239

240
delListFromFM fm keys = foldl' delFromFM fm keys
241
242
243
244
245
246
247
248
249
250
251
252
\end{code}

%************************************************************************
%*									*
\subsection{Combining @FiniteMaps@}
%*									*
%************************************************************************

\begin{code}
plusFM_C combiner EmptyFM fm2 = fm2
plusFM_C combiner fm1 EmptyFM = fm1
plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
253
  = mkVBalBranch split_key new_elt
254
255
256
257
258
259
260
261
262
263
264
		 (plusFM_C combiner lts left)
		 (plusFM_C combiner gts right)
  where
    lts     = splitLT fm1 split_key
    gts     = splitGT fm1 split_key
    new_elt = case lookupFM fm1 split_key of
		Nothing   -> elt2
		Just elt1 -> combiner elt1 elt2

-- It's worth doing plusFM specially, because we don't need
-- to do the lookup in fm1.
265
-- FM2 over-rides FM1.
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

plusFM EmptyFM fm2 = fm2
plusFM fm1 EmptyFM = fm1
plusFM fm1 (Branch split_key elt1 _ left right)
  = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
  where
    lts     = splitLT fm1 split_key
    gts     = splitGT fm1 split_key

minusFM EmptyFM fm2 = emptyFM
minusFM fm1 EmptyFM = fm1
minusFM fm1 (Branch split_key elt _ left right)
  = glueVBal (minusFM lts left) (minusFM gts right)
	-- The two can be way different, so we need glueVBal
  where
    lts = splitLT fm1 split_key		-- NB gt and lt, so the equal ones
    gts = splitGT fm1 split_key		-- are not in either.

intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2

intersectFM_C combiner fm1 EmptyFM = emptyFM
intersectFM_C combiner EmptyFM fm2 = emptyFM
intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)

  | maybeToBool maybe_elt1	-- split_elt *is* in intersection
  = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
292
						(intersectFM_C combiner gts right)
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

  | otherwise			-- split_elt is *not* in intersection
  = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)

  where
    lts = splitLT fm1 split_key		-- NB gt and lt, so the equal ones
    gts = splitGT fm1 split_key		-- are not in either.

    maybe_elt1 = lookupFM fm1 split_key
    Just elt1  = maybe_elt1
\end{code}

%************************************************************************
%*									*
\subsection{Mapping, folding, and filtering with @FiniteMaps@}
%*									*
%************************************************************************

\begin{code}
foldFM k z EmptyFM = z
foldFM k z (Branch key elt _ fm_l fm_r)
  = foldFM k (k key elt (foldFM k z fm_r)) fm_l

mapFM f EmptyFM = emptyFM
317
mapFM f (Branch key elt size fm_l fm_r)
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
  = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)

filterFM p EmptyFM = emptyFM
filterFM p (Branch key elt _ fm_l fm_r)
  | p key elt		-- Keep the item
  = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)

  | otherwise		-- Drop the item
  = glueVBal (filterFM p fm_l) (filterFM p fm_r)
\end{code}

%************************************************************************
%*									*
\subsection{Interrogating @FiniteMaps@}
%*									*
%************************************************************************

\begin{code}
--{-# INLINE sizeFM #-}
sizeFM EmptyFM		     = 0
sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size)

isEmptyFM fm = sizeFM fm == 0

lookupFM EmptyFM key = Nothing
lookupFM (Branch key elt _ fm_l fm_r) key_to_find
344
345
346
347
  = case compare key_to_find key of
	LT -> lookupFM fm_l key_to_find
	GT -> lookupFM fm_r key_to_find
	EQ -> Just elt
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383

key `elemFM` fm
  = case (lookupFM fm key) of { Nothing -> False; Just elt -> True }

lookupWithDefaultFM fm deflt key
  = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
\end{code}

%************************************************************************
%*									*
\subsection{Listifying @FiniteMaps@}
%*									*
%************************************************************************

\begin{code}
fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
keysFM fm   = foldFM (\ key elt rest -> key : rest)       [] fm
eltsFM fm   = foldFM (\ key elt rest -> elt : rest)       [] fm
\end{code}


%************************************************************************
%*									*
\subsection{The implementation of balancing}
%*									*
%************************************************************************

%************************************************************************
%*									*
\subsubsection{Basic construction of a @FiniteMap@}
%*									*
%************************************************************************

@mkBranch@ simply gets the size component right.  This is the ONLY
(non-trivial) place the Branch object is built, so the ASSERTion
recursively checks consistency.  (The trivial use of Branch is in
384
@unitFM@.)
385
386
387
388
389
390
391

\begin{code}
sIZE_RATIO :: Int
sIZE_RATIO = 5

mkBranch :: (Ord key OUTPUTABLE_key) 		-- Used for the assertion checking only
	 => Int
392
	 -> key -> elt
393
394
395
396
397
	 -> FiniteMap key elt -> FiniteMap key elt
	 -> FiniteMap key elt

mkBranch which key elt fm_l fm_r
  = --ASSERT( left_ok && right_ok && balance_ok )
sof's avatar
sof committed
398
#if defined(DEBUG_FINITEMAPS)
399
    if not ( left_ok && right_ok && balance_ok ) then
400
401
402
403
	pprPanic ("mkBranch:"++show which) (vcat [ppr [left_ok, right_ok, balance_ok],
				       ppr key,
				       ppr fm_l,
				       ppr fm_r])
404
405
406
407
408
409
410
411
    else
#endif
    let
	result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r
    in
--    if sizeFM result <= 8 then
	result
--    else
412
--	pprTrace ("mkBranch:"++(show which)) (ppr result) (
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
--	result
--	)
  where
    left_ok  = case fm_l of
		EmptyFM		         -> True
		Branch left_key _ _ _ _  -> let
						biggest_left_key = fst (findMax fm_l)
					    in
					    biggest_left_key < key
    right_ok = case fm_r of
		EmptyFM		         -> True
		Branch right_key _ _ _ _ -> let
						smallest_right_key = fst (findMin fm_r)
					    in
					    key < smallest_right_key
    balance_ok = True -- sigh
{- LATER:
    balance_ok
      = -- Both subtrees have one or no elements...
	(left_size + right_size <= 1)
-- NO	      || left_size == 0  -- ???
-- NO	      || right_size == 0 -- ???
    	-- ... or the number of elements in a subtree does not exceed
	-- sIZE_RATIO times the number of elements in the other subtree
      || (left_size  * sIZE_RATIO >= right_size &&
    	  right_size * sIZE_RATIO >= left_size)
-}

    left_size  = sizeFM fm_l
    right_size = sizeFM fm_r

#ifdef __GLASGOW_HASKELL__
    unbox :: Int -> Int#
    unbox (I# size) = size
#else
    unbox :: Int -> Int
    unbox x = x
#endif
\end{code}

%************************************************************************
%*									*
\subsubsection{{\em Balanced} construction of a @FiniteMap@}
%*									*
%************************************************************************

@mkBalBranch@ rebalances, assuming that the subtrees aren't too far
out of whack.

\begin{code}
mkBalBranch :: (Ord key OUTPUTABLE_key)
464
	    => key -> elt
465
466
467
468
469
	    -> FiniteMap key elt -> FiniteMap key elt
	    -> FiniteMap key elt

mkBalBranch key elt fm_L fm_R

470
  | size_l + size_r < 2
471
472
473
474
  = mkBranch 1{-which-} key elt fm_L fm_R

  | size_r > sIZE_RATIO * size_l	-- Right tree too big
  = case fm_R of
475
	Branch _ _ _ fm_rl fm_rr
476
477
478
479
480
481
		| sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
		| otherwise	   	          -> double_L fm_L fm_R
	-- Other case impossible

  | size_l > sIZE_RATIO * size_r	-- Left tree too big
  = case fm_L of
482
	Branch _ _ _ fm_ll fm_lr
483
484
485
486
487
488
		| sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
		| otherwise		          -> double_R fm_L fm_R
	-- Other case impossible

  | otherwise				-- No imbalance
  = mkBranch 2{-which-} key elt fm_L fm_R
489

490
491
492
493
  where
    size_l   = sizeFM fm_L
    size_r   = sizeFM fm_R

494
    single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
495
496
497
	= mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr

    double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
498
	= mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key   elt   fm_l   fm_rll)
499
500
501
502
503
504
505
506
507
508
509
510
511
				 (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)

    single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
	= mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)

    double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
	= mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll  fm_lrl)
				 (mkBranch 12{-which-} key   elt   fm_lrr fm_r)
\end{code}


\begin{code}
mkVBalBranch :: (Ord key OUTPUTABLE_key)
512
	     => key -> elt
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
	     -> FiniteMap key elt -> FiniteMap key elt
	     -> FiniteMap key elt

-- Assert: in any call to (mkVBalBranch_C comb key elt l r),
--	   (a) all keys in l are < all keys in r
--	   (b) all keys in l are < key
--	   (c) all keys in r are > key

mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt

mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
		     fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
  | sIZE_RATIO * size_l < size_r
  = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr

  | sIZE_RATIO * size_r < size_l
  = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)

  | otherwise
  = mkBranch 13{-which-} key elt fm_l fm_r

535
  where
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
    size_l = sizeFM fm_l
    size_r = sizeFM fm_r
\end{code}

%************************************************************************
%*									*
\subsubsection{Gluing two trees together}
%*									*
%************************************************************************

@glueBal@ assumes its two arguments aren't too far out of whack, just
like @mkBalBranch@.  But: all keys in first arg are $<$ all keys in
second.

\begin{code}
glueBal :: (Ord key OUTPUTABLE_key)
	=> FiniteMap key elt -> FiniteMap key elt
	-> FiniteMap key elt

glueBal EmptyFM fm2 = fm2
glueBal fm1 EmptyFM = fm1
557
glueBal fm1 fm2
558
559
560
561
562
	-- The case analysis here (absent in Adams' program) is really to deal
	-- with the case where fm2 is a singleton. Then deleting the minimum means
	-- we pass an empty tree to mkBalBranch, which breaks its invariant.
  | sizeFM fm2 > sizeFM fm1
  = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
563

564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
  | otherwise
  = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
  where
    (mid_key1, mid_elt1) = findMax fm1
    (mid_key2, mid_elt2) = findMin fm2
\end{code}

@glueVBal@ copes with arguments which can be of any size.
But: all keys in first arg are $<$ all keys in second.

\begin{code}
glueVBal :: (Ord key OUTPUTABLE_key)
	 => FiniteMap key elt -> FiniteMap key elt
	 -> FiniteMap key elt

glueVBal EmptyFM fm2 = fm2
glueVBal fm1 EmptyFM = fm1
glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
582
	 fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
  | sIZE_RATIO * size_l < size_r
  = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr

  | sIZE_RATIO * size_r < size_l
  = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)

  | otherwise		-- We now need the same two cases as in glueBal above.
  = glueBal fm_l fm_r
  where
    size_l = sizeFM fm_l
    size_r = sizeFM fm_r
\end{code}

%************************************************************************
%*									*
\subsection{Local utilities}
%*									*
%************************************************************************

\begin{code}
splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt

-- splitLT fm split_key  =  fm restricted to keys <  split_key
-- splitGT fm split_key  =  fm restricted to keys >  split_key

splitLT EmptyFM split_key = emptyFM
splitLT (Branch key elt _ fm_l fm_r) split_key
610
611
612
613
  = case compare split_key key of
	LT -> splitLT fm_l split_key
	GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
	EQ -> fm_l
614
615
616

splitGT EmptyFM split_key = emptyFM
splitGT (Branch key elt _ fm_l fm_r) split_key
617
618
619
620
  = case compare split_key key of
	GT -> splitGT fm_r split_key
	LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
	EQ -> fm_r
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645

findMin :: FiniteMap key elt -> (key,elt)
findMin (Branch key elt _ EmptyFM _) = (key,elt)
findMin (Branch key elt _ fm_l    _) = findMin fm_l

deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r
deleteMin (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r

findMax :: FiniteMap key elt -> (key,elt)
findMax (Branch key elt _ _ EmptyFM) = (key,elt)
findMax (Branch key elt _ _    fm_r) = findMax fm_r

deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l
deleteMax (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
\end{code}

%************************************************************************
%*									*
\subsection{Output-ery}
%*									*
%************************************************************************

\begin{code}
sof's avatar
sof committed
646
#if defined(DEBUG_FINITEMAPS)
647
648

instance (Outputable key) => Outputable (FiniteMap key elt) where
649
    ppr fm = pprX fm
650

651
652
653
654
655
pprX EmptyFM = char '!'
pprX (Branch key elt sz fm_l fm_r)
 = parens (hcat [pprX fm_l, space,
		      ppr key, space, int (IF_GHC(I# sz, sz)), space,
		      pprX fm_r])
656
657
658
659
#else
-- and when not debugging the package itself...
instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
    ppr fm = ppr (fmToList fm)
660
#endif
661

sof's avatar
sof committed
662
#if 0
663
664
instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
  fm_1 == fm_2 = (sizeFM   fm_1 == sizeFM   fm_2) &&   -- quick test
665
		 (fmToList fm_1 == fmToList fm_2)
666
667
668
669

{- NO: not clear what The Right Thing to do is:
instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
  fm_1 <= fm_2 = (sizeFM   fm_1 <= sizeFM   fm_2) &&   -- quick test
670
		 (fmToList fm_1 <= fmToList fm_2)
671
672
-}
#endif
673
674
675
676
677
678
679
680
681
682
683
684
\end{code}

%************************************************************************
%*									*
\subsection{Efficiency pragmas for GHC}
%*									*
%************************************************************************

When the FiniteMap module is used in GHC, we specialise it for
\tr{Uniques}, for dastardly efficiency reasons.

\begin{code}
685
686
687
#if 0

#if __GLASGOW_HASKELL__
688
689

{-# SPECIALIZE addListToFM
690
		:: FiniteMap (FastString, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
691
		 , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt
692
693
694
    IF_NCG(COMMA   FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
    #-}
{-# SPECIALIZE addListToFM_C
695
		:: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt
696
		 , (elt -> elt -> elt) -> FiniteMap FastString elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
697
698
    IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
    #-}
699
{-# SPECIALIZE addToFM
700
		:: FiniteMap CLabel elt -> CLabel -> elt  -> FiniteMap CLabel elt
701
702
		 , FiniteMap FastString elt -> FAST_STRING -> elt  -> FiniteMap FAST_STRING elt
		 , FiniteMap (FastString, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt  -> FiniteMap (FAST_STRING, FAST_STRING) elt
703
		 , FiniteMap RdrName elt -> RdrName -> elt  -> FiniteMap RdrName elt
704
    IF_NCG(COMMA   FiniteMap Reg elt -> Reg -> elt  -> FiniteMap Reg elt)
705
    #-}
706
{-# SPECIALIZE addToFM_C
707
		:: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt
708
		 , (elt -> elt -> elt) -> FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
709
    IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
710
    #-}
711
{-# SPECIALIZE bagToFM
712
		:: Bag (FastString,elt) -> FiniteMap FAST_STRING elt
713
    #-}
714
{-# SPECIALIZE delListFromFM
715
		:: FiniteMap RdrName elt -> [RdrName]   -> FiniteMap RdrName elt
716
		 , FiniteMap FastString elt -> [FAST_STRING]   -> FiniteMap FAST_STRING elt
717
    IF_NCG(COMMA   FiniteMap Reg elt -> [Reg]   -> FiniteMap Reg elt)
718
    #-}
719
{-# SPECIALIZE listToFM
720
		:: [([Char],elt)] -> FiniteMap [Char] elt
721
722
		 , [(FastString,elt)] -> FiniteMap FAST_STRING elt
		 , [((FastString,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
723
    IF_NCG(COMMA   [(Reg COMMA elt)] -> FiniteMap Reg elt)
724
725
    #-}
{-# SPECIALIZE lookupFM
726
727
		:: FiniteMap CLabel elt -> CLabel -> Maybe elt
		 , FiniteMap [Char] elt -> [Char] -> Maybe elt
728
729
		 , FiniteMap FastString elt -> FAST_STRING -> Maybe elt
		 , FiniteMap (FastString,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
730
731
		 , FiniteMap RdrName elt -> RdrName -> Maybe elt
		 , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
732
733
734
    IF_NCG(COMMA   FiniteMap Reg elt -> Reg -> Maybe elt)
    #-}
{-# SPECIALIZE lookupWithDefaultFM
735
		:: FiniteMap FastString elt -> elt -> FAST_STRING -> elt
736
737
738
    IF_NCG(COMMA   FiniteMap Reg elt -> elt -> Reg -> elt)
    #-}
{-# SPECIALIZE plusFM
739
		:: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt
740
		 , FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
741
742
743
    IF_NCG(COMMA   FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
    #-}
{-# SPECIALIZE plusFM_C
744
		:: (elt -> elt -> elt) -> FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
745
746
747
    IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
    #-}

ross's avatar
ross committed
748
#endif /* compiling with ghc and have specialiser */
749

ross's avatar
ross committed
750
#endif /* 0 */
751
\end{code}