2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Util]{Highly random utility functions}
7 -- IF_NOT_GHC is meant to make this module useful outside the context of GHC
12 Eager, thenEager, returnEager, mapEager, appEager, runEager,
14 -- general list processing
15 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
16 zipLazy, stretchZipEqual,
17 mapAndUnzip, mapAndUnzip3,
18 nOfThem, lengthExceeds, isSingleton,
23 assoc, assocUsing, assocDefault, assocDefaultUsing,
26 hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
29 IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
31 IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
32 IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
34 -- transitive closures
38 mapAccumL, mapAccumR, mapAccumB,
47 IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
48 IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
52 #include "HsVersions.h"
54 import List ( zipWith4 )
55 import Panic ( panic )
56 import Unique ( Unique )
57 import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
62 %************************************************************************
64 \subsection{The Eager monad}
66 %************************************************************************
68 The @Eager@ monad is just an encoding of continuation-passing style,
69 used to allow you to express "do this and then that", mainly to avoid
70 space leaks. It's done with a type synonym to save bureaucracy.
73 type Eager ans a = (a -> ans) -> ans
75 runEager :: Eager a a -> a
76 runEager m = m (\x -> x)
78 appEager :: Eager ans a -> (a -> ans) -> ans
79 appEager m cont = m cont
81 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
82 thenEager m k cont = m (\r -> k r cont)
84 returnEager :: a -> Eager ans a
85 returnEager v cont = cont v
87 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
88 mapEager f [] = returnEager []
89 mapEager f (x:xs) = f x `thenEager` \ y ->
90 mapEager f xs `thenEager` \ ys ->
94 %************************************************************************
96 \subsection[Utils-lists]{General list processing}
98 %************************************************************************
100 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
101 are of equal length. Alastair Reid thinks this should only happen if
102 DEBUGging on; hey, why not?
105 zipEqual :: String -> [a] -> [b] -> [(a,b)]
106 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
107 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
108 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
112 zipWithEqual _ = zipWith
113 zipWith3Equal _ = zipWith3
114 zipWith4Equal _ = zipWith4
116 zipEqual msg [] [] = []
117 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
118 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
120 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
121 zipWithEqual msg _ [] [] = []
122 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
124 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
125 = z a b c : zipWith3Equal msg z as bs cs
126 zipWith3Equal msg _ [] [] [] = []
127 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
129 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
130 = z a b c d : zipWith4Equal msg z as bs cs ds
131 zipWith4Equal msg _ [] [] [] [] = []
132 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
137 -- zipLazy is lazy in the second list (observe the ~)
139 zipLazy :: [a] -> [b] -> [(a,b)]
141 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
146 stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
147 -- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
149 stretchZipEqual f [] [] = []
150 stretchZipEqual f (x:xs) (y:ys) = case f x y of
151 Just x' -> x' : stretchZipEqual f xs ys
152 Nothing -> x : stretchZipEqual f xs (y:ys)
157 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
159 mapAndUnzip f [] = ([],[])
163 (rs1, rs2) = mapAndUnzip f xs
167 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
169 mapAndUnzip3 f [] = ([],[],[])
170 mapAndUnzip3 f (x:xs)
173 (rs1, rs2, rs3) = mapAndUnzip3 f xs
175 (r1:rs1, r2:rs2, r3:rs3)
179 nOfThem :: Int -> a -> [a]
180 nOfThem n thing = replicate n thing
182 lengthExceeds :: [a] -> Int -> Bool
184 [] `lengthExceeds` n = 0 > n
185 (x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
187 isSingleton :: [a] -> Bool
189 isSingleton [x] = True
190 isSingleton _ = False
194 snocView :: [a] -> ([a], a) -- Split off the last element
195 snocView xs = go xs []
197 go [x] acc = (reverse acc, x)
198 go (x:xs) acc = go xs (x:acc)
201 Debugging/specialising versions of \tr{elem} and \tr{notElem}
204 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
207 isIn msg x ys = elem__ x ys
208 isn'tIn msg x ys = notElem__ x ys
210 --these are here to be SPECIALIZEd (automagically)
212 elem__ x (y:ys) = x==y || elem__ x ys
214 notElem__ x [] = True
215 notElem__ x (y:ys) = x /= y && notElem__ x ys
223 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
224 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
227 = notElem ILIT(0) x ys
229 notElem i x [] = True
231 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
232 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
238 %************************************************************************
240 \subsection[Utils-assoc]{Association lists}
242 %************************************************************************
244 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
247 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
248 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
249 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
250 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
252 assocDefaultUsing eq deflt ((k,v) : rest) key
254 | otherwise = assocDefaultUsing eq deflt rest key
256 assocDefaultUsing eq deflt [] key = deflt
258 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
259 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
260 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
263 %************************************************************************
265 \subsection[Utils-dups]{Duplicate-handling}
267 %************************************************************************
270 hasNoDups :: (Eq a) => [a] -> Bool
272 hasNoDups xs = f [] xs
274 f seen_so_far [] = True
275 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
280 is_elem = isIn "hasNoDups"
284 equivClasses :: (a -> a -> Ordering) -- Comparison
288 equivClasses cmp stuff@[] = []
289 equivClasses cmp stuff@[item] = [stuff]
290 equivClasses cmp items
291 = runs eq (sortLt lt items)
293 eq a b = case cmp a b of { EQ -> True; _ -> False }
294 lt a b = case cmp a b of { LT -> True; _ -> False }
297 The first cases in @equivClasses@ above are just to cut to the point
300 @runs@ groups a list into a list of lists, each sublist being a run of
301 identical elements of the input list. It is passed a predicate @p@ which
302 tells when two elements are equal.
305 runs :: (a -> a -> Bool) -- Equality
310 runs p (x:xs) = case (span (p x) xs) of
311 (first, rest) -> (x:first) : (runs p rest)
315 removeDups :: (a -> a -> Ordering) -- Comparison function
317 -> ([a], -- List with no duplicates
318 [[a]]) -- List of duplicate groups. One representative from
319 -- each group appears in the first result
321 removeDups cmp [] = ([], [])
322 removeDups cmp [x] = ([x],[])
324 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
327 collect_dups dups_so_far [x] = (dups_so_far, x)
328 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
333 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
334 -- NB: it's *very* important that if we have the input list [a,b,c],
335 -- where a,b,c all have the same unique, then we get back the list
339 -- Hence the use of foldr, plus the reversed-args tack_on below
340 equivClassesByUniq get_uniq xs
341 = eltsUFM (foldr add emptyUFM xs)
343 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
344 tack_on old new = new++old
347 %************************************************************************
349 \subsection[Utils-sorting]{Sorting}
351 %************************************************************************
353 %************************************************************************
355 \subsubsection[Utils-quicksorting]{Quicksorts}
357 %************************************************************************
360 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
361 quicksort :: (a -> a -> Bool) -- Less-than predicate
363 -> [a] -- Result list in increasing order
366 quicksort lt [x] = [x]
367 quicksort lt (x:xs) = split x [] [] xs
369 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
370 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
371 | True = split x lo (y:hi) ys
374 Quicksort variant from Lennart's Haskell-library contribution. This
375 is a {\em stable} sort.
378 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
380 sortLt :: (a -> a -> Bool) -- Less-than predicate
382 -> [a] -- Result list
384 sortLt lt l = qsort lt l []
386 -- qsort is stable and does not concatenate.
387 qsort :: (a -> a -> Bool) -- Less-than predicate
388 -> [a] -- xs, Input list
389 -> [a] -- r, Concatenate this list to the sorted input list
390 -> [a] -- Result = sort xs ++ r
394 qsort lt (x:xs) r = qpart lt x xs [] [] r
396 -- qpart partitions and sorts the sublists
397 -- rlt contains things less than x,
398 -- rge contains the ones greater than or equal to x.
399 -- Both have equal elements reversed with respect to the original list.
401 qpart lt x [] rlt rge r =
402 -- rlt and rge are in reverse order and must be sorted with an
403 -- anti-stable sorting
404 rqsort lt rlt (x : rqsort lt rge r)
406 qpart lt x (y:ys) rlt rge r =
409 qpart lt x ys (y:rlt) rge r
412 qpart lt x ys rlt (y:rge) r
414 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
416 rqsort lt [x] r = x:r
417 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
419 rqpart lt x [] rle rgt r =
420 qsort lt rle (x : qsort lt rgt r)
422 rqpart lt x (y:ys) rle rgt r =
425 rqpart lt x ys rle (y:rgt) r
428 rqpart lt x ys (y:rle) rgt r
431 %************************************************************************
433 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
435 %************************************************************************
438 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
440 mergesort cmp xs = merge_lists (split_into_runs [] xs)
442 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
443 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
445 split_into_runs [] [] = []
446 split_into_runs run [] = [run]
447 split_into_runs [] (x:xs) = split_into_runs [x] xs
448 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
449 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
450 | True = rl : (split_into_runs [x] xs)
453 merge_lists (x:xs) = merge x (merge_lists xs)
457 merge xl@(x:xs) yl@(y:ys)
459 EQ -> x : y : (merge xs ys)
460 LT -> x : (merge xs yl)
461 GT -> y : (merge xl ys)
464 %************************************************************************
466 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
468 %************************************************************************
471 Date: Mon, 3 May 93 20:45:23 +0200
472 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
473 To: partain@dcs.gla.ac.uk
474 Subject: natural merge sort beats quick sort [ and it is prettier ]
476 Here is a piece of Haskell code that I'm rather fond of. See it as an
477 attempt to get rid of the ridiculous quick-sort routine. group is
478 quite useful by itself I think it was John's idea originally though I
479 believe the lazy version is due to me [surprisingly complicated].
480 gamma [used to be called] is called gamma because I got inspired by
481 the Gamma calculus. It is not very close to the calculus but does
482 behave less sequentially than both foldr and foldl. One could imagine
483 a version of gamma that took a unit element as well thereby avoiding
484 the problem with empty lists.
486 I've tried this code against
488 1) insertion sort - as provided by haskell
489 2) the normal implementation of quick sort
490 3) a deforested version of quick sort due to Jan Sparud
491 4) a super-optimized-quick-sort of Lennart's
493 If the list is partially sorted both merge sort and in particular
494 natural merge sort wins. If the list is random [ average length of
495 rising subsequences = approx 2 ] mergesort still wins and natural
496 merge sort is marginally beaten by Lennart's soqs. The space
497 consumption of merge sort is a bit worse than Lennart's quick sort
498 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
499 fpca article ] isn't used because of group.
506 group :: (a -> a -> Bool) -> [a] -> [[a]]
509 Date: Mon, 12 Feb 1996 15:09:41 +0000
510 From: Andy Gill <andy@dcs.gla.ac.uk>
512 Here is a `better' definition of group.
515 group p (x:xs) = group' xs x x (x :)
517 group' [] _ _ s = [s []]
518 group' (x:xs) x_min x_max s
519 | not (x `p` x_max) = group' xs x_min x (s . (x :))
520 | x `p` x_min = group' xs x x_max ((x :) . s)
521 | otherwise = s [] : group' xs x x (x :)
523 -- This one works forwards *and* backwards, as well as also being
524 -- faster that the one in Util.lhs.
529 let ((h1:t1):tt1) = group p xs
530 (t,tt) = if null xs then ([],[]) else
531 if x `p` h1 then (h1:t1,tt1) else
536 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
537 generalMerge p xs [] = xs
538 generalMerge p [] ys = ys
539 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
540 | otherwise = y : generalMerge p (x:xs) ys
542 -- gamma is now called balancedFold
544 balancedFold :: (a -> a -> a) -> [a] -> a
545 balancedFold f [] = error "can't reduce an empty list using balancedFold"
546 balancedFold f [x] = x
547 balancedFold f l = balancedFold f (balancedFold' f l)
549 balancedFold' :: (a -> a -> a) -> [a] -> [a]
550 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
551 balancedFold' f xs = xs
553 generalMergeSort p [] = []
554 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
556 generalNaturalMergeSort p [] = []
557 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
559 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
561 mergeSort = generalMergeSort (<=)
562 naturalMergeSort = generalNaturalMergeSort (<=)
564 mergeSortLe le = generalMergeSort le
565 naturalMergeSortLe le = generalNaturalMergeSort le
568 %************************************************************************
570 \subsection[Utils-transitive-closure]{Transitive closure}
572 %************************************************************************
574 This algorithm for transitive closure is straightforward, albeit quadratic.
577 transitiveClosure :: (a -> [a]) -- Successor function
578 -> (a -> a -> Bool) -- Equality predicate
580 -> [a] -- The transitive closure
582 transitiveClosure succ eq xs
586 go done (x:xs) | x `is_in` done = go done xs
587 | otherwise = go (x:done) (succ x ++ xs)
590 x `is_in` (y:ys) | eq x y = True
591 | otherwise = x `is_in` ys
594 %************************************************************************
596 \subsection[Utils-accum]{Accumulating}
598 %************************************************************************
600 @mapAccumL@ behaves like a combination
601 of @map@ and @foldl@;
602 it applies a function to each element of a list, passing an accumulating
603 parameter from left to right, and returning a final value of this
604 accumulator together with the new list.
607 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
608 -- and accumulator, returning new
609 -- accumulator and elt of result list
610 -> acc -- Initial accumulator
612 -> (acc, [y]) -- Final accumulator and result list
614 mapAccumL f b [] = (b, [])
615 mapAccumL f b (x:xs) = (b'', x':xs') where
617 (b'', xs') = mapAccumL f b' xs
620 @mapAccumR@ does the same, but working from right to left instead. Its type is
621 the same as @mapAccumL@, though.
624 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
625 -- and accumulator, returning new
626 -- accumulator and elt of result list
627 -> acc -- Initial accumulator
629 -> (acc, [y]) -- Final accumulator and result list
631 mapAccumR f b [] = (b, [])
632 mapAccumR f b (x:xs) = (b'', x':xs') where
634 (b', xs') = mapAccumR f b xs
637 Here is the bi-directional version, that works from both left and right.
640 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
641 -- Function of elt of input list
642 -- and accumulator, returning new
643 -- accumulator and elt of result list
644 -> accl -- Initial accumulator from left
645 -> accr -- Initial accumulator from right
647 -> (accl, accr, [y]) -- Final accumulators and result list
649 mapAccumB f a b [] = (a,b,[])
650 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
652 (a',b'',y) = f a b' x
653 (a'',b',ys) = mapAccumB f a' b xs
656 %************************************************************************
658 \subsection[Utils-comparison]{Comparisons}
660 %************************************************************************
663 thenCmp :: Ordering -> Ordering -> Ordering
664 {-# INLINE thenCmp #-}
666 thenCmp other any = other
668 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
669 -- `cmpList' uses a user-specified comparer
671 cmpList cmp [] [] = EQ
672 cmpList cmp [] _ = LT
673 cmpList cmp _ [] = GT
674 cmpList cmp (a:as) (b:bs)
675 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
679 cmpString :: String -> String -> Ordering
682 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
683 else if x < y then LT
691 %************************************************************************
693 \subsection[Utils-pairs]{Pairs}
695 %************************************************************************
697 The following are curried versions of @fst@ and @snd@.
700 cfst :: a -> b -> a -- stranal-sem only (Note)
704 The following provide us higher order functions that, when applied
705 to a function, operate on pairs.
708 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
709 applyToPair (f,g) (x,y) = (f x, g y)
711 applyToFst :: (a -> c) -> (a,b)-> (c,b)
712 applyToFst f (x,y) = (f x,y)
714 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
715 applyToSnd f (x,y) = (x,f y)
717 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
718 foldPair fg ab [] = ab
719 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
720 where (u,v) = foldPair fg ab abs
724 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
725 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
730 seqList :: [a] -> b -> b
732 seqList :: (Eval a) => [a] -> b -> b
735 seqList (x:xs) b = x `seq` seqList xs b
737 #if __HASKELL1__ <= 4
738 ($!) :: (Eval a) => (a -> b) -> a -> b