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, only,
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
201 snocView :: [a] -> ([a], a) -- Split off the last element
202 snocView xs = go xs []
204 go [x] acc = (reverse acc, x)
205 go (x:xs) acc = go xs (x:acc)
208 Debugging/specialising versions of \tr{elem} and \tr{notElem}
211 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
214 isIn msg x ys = elem__ x ys
215 isn'tIn msg x ys = notElem__ x ys
217 --these are here to be SPECIALIZEd (automagically)
219 elem__ x (y:ys) = x==y || elem__ x ys
221 notElem__ x [] = True
222 notElem__ x (y:ys) = x /= y && notElem__ x ys
230 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
231 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
234 = notElem ILIT(0) x ys
236 notElem i x [] = True
238 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
239 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
245 %************************************************************************
247 \subsection[Utils-assoc]{Association lists}
249 %************************************************************************
251 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
254 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
255 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
256 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
257 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
259 assocDefaultUsing eq deflt ((k,v) : rest) key
261 | otherwise = assocDefaultUsing eq deflt rest key
263 assocDefaultUsing eq deflt [] key = deflt
265 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
266 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
267 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
270 %************************************************************************
272 \subsection[Utils-dups]{Duplicate-handling}
274 %************************************************************************
277 hasNoDups :: (Eq a) => [a] -> Bool
279 hasNoDups xs = f [] xs
281 f seen_so_far [] = True
282 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
287 is_elem = isIn "hasNoDups"
291 equivClasses :: (a -> a -> Ordering) -- Comparison
295 equivClasses cmp stuff@[] = []
296 equivClasses cmp stuff@[item] = [stuff]
297 equivClasses cmp items
298 = runs eq (sortLt lt items)
300 eq a b = case cmp a b of { EQ -> True; _ -> False }
301 lt a b = case cmp a b of { LT -> True; _ -> False }
304 The first cases in @equivClasses@ above are just to cut to the point
307 @runs@ groups a list into a list of lists, each sublist being a run of
308 identical elements of the input list. It is passed a predicate @p@ which
309 tells when two elements are equal.
312 runs :: (a -> a -> Bool) -- Equality
317 runs p (x:xs) = case (span (p x) xs) of
318 (first, rest) -> (x:first) : (runs p rest)
322 removeDups :: (a -> a -> Ordering) -- Comparison function
324 -> ([a], -- List with no duplicates
325 [[a]]) -- List of duplicate groups. One representative from
326 -- each group appears in the first result
328 removeDups cmp [] = ([], [])
329 removeDups cmp [x] = ([x],[])
331 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
334 collect_dups dups_so_far [x] = (dups_so_far, x)
335 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
340 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
341 -- NB: it's *very* important that if we have the input list [a,b,c],
342 -- where a,b,c all have the same unique, then we get back the list
346 -- Hence the use of foldr, plus the reversed-args tack_on below
347 equivClassesByUniq get_uniq xs
348 = eltsUFM (foldr add emptyUFM xs)
350 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
351 tack_on old new = new++old
354 %************************************************************************
356 \subsection[Utils-sorting]{Sorting}
358 %************************************************************************
360 %************************************************************************
362 \subsubsection[Utils-quicksorting]{Quicksorts}
364 %************************************************************************
367 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
368 quicksort :: (a -> a -> Bool) -- Less-than predicate
370 -> [a] -- Result list in increasing order
373 quicksort lt [x] = [x]
374 quicksort lt (x:xs) = split x [] [] xs
376 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
377 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
378 | True = split x lo (y:hi) ys
381 Quicksort variant from Lennart's Haskell-library contribution. This
382 is a {\em stable} sort.
385 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
387 sortLt :: (a -> a -> Bool) -- Less-than predicate
389 -> [a] -- Result list
391 sortLt lt l = qsort lt l []
393 -- qsort is stable and does not concatenate.
394 qsort :: (a -> a -> Bool) -- Less-than predicate
395 -> [a] -- xs, Input list
396 -> [a] -- r, Concatenate this list to the sorted input list
397 -> [a] -- Result = sort xs ++ r
401 qsort lt (x:xs) r = qpart lt x xs [] [] r
403 -- qpart partitions and sorts the sublists
404 -- rlt contains things less than x,
405 -- rge contains the ones greater than or equal to x.
406 -- Both have equal elements reversed with respect to the original list.
408 qpart lt x [] rlt rge r =
409 -- rlt and rge are in reverse order and must be sorted with an
410 -- anti-stable sorting
411 rqsort lt rlt (x : rqsort lt rge r)
413 qpart lt x (y:ys) rlt rge r =
416 qpart lt x ys (y:rlt) rge r
419 qpart lt x ys rlt (y:rge) r
421 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
423 rqsort lt [x] r = x:r
424 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
426 rqpart lt x [] rle rgt r =
427 qsort lt rle (x : qsort lt rgt r)
429 rqpart lt x (y:ys) rle rgt r =
432 rqpart lt x ys rle (y:rgt) r
435 rqpart lt x ys (y:rle) rgt r
438 %************************************************************************
440 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
442 %************************************************************************
445 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
447 mergesort cmp xs = merge_lists (split_into_runs [] xs)
449 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
450 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
452 split_into_runs [] [] = []
453 split_into_runs run [] = [run]
454 split_into_runs [] (x:xs) = split_into_runs [x] xs
455 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
456 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
457 | True = rl : (split_into_runs [x] xs)
460 merge_lists (x:xs) = merge x (merge_lists xs)
464 merge xl@(x:xs) yl@(y:ys)
466 EQ -> x : y : (merge xs ys)
467 LT -> x : (merge xs yl)
468 GT -> y : (merge xl ys)
471 %************************************************************************
473 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
475 %************************************************************************
478 Date: Mon, 3 May 93 20:45:23 +0200
479 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
480 To: partain@dcs.gla.ac.uk
481 Subject: natural merge sort beats quick sort [ and it is prettier ]
483 Here is a piece of Haskell code that I'm rather fond of. See it as an
484 attempt to get rid of the ridiculous quick-sort routine. group is
485 quite useful by itself I think it was John's idea originally though I
486 believe the lazy version is due to me [surprisingly complicated].
487 gamma [used to be called] is called gamma because I got inspired by
488 the Gamma calculus. It is not very close to the calculus but does
489 behave less sequentially than both foldr and foldl. One could imagine
490 a version of gamma that took a unit element as well thereby avoiding
491 the problem with empty lists.
493 I've tried this code against
495 1) insertion sort - as provided by haskell
496 2) the normal implementation of quick sort
497 3) a deforested version of quick sort due to Jan Sparud
498 4) a super-optimized-quick-sort of Lennart's
500 If the list is partially sorted both merge sort and in particular
501 natural merge sort wins. If the list is random [ average length of
502 rising subsequences = approx 2 ] mergesort still wins and natural
503 merge sort is marginally beaten by Lennart's soqs. The space
504 consumption of merge sort is a bit worse than Lennart's quick sort
505 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
506 fpca article ] isn't used because of group.
513 group :: (a -> a -> Bool) -> [a] -> [[a]]
516 Date: Mon, 12 Feb 1996 15:09:41 +0000
517 From: Andy Gill <andy@dcs.gla.ac.uk>
519 Here is a `better' definition of group.
522 group p (x:xs) = group' xs x x (x :)
524 group' [] _ _ s = [s []]
525 group' (x:xs) x_min x_max s
526 | not (x `p` x_max) = group' xs x_min x (s . (x :))
527 | x `p` x_min = group' xs x x_max ((x :) . s)
528 | otherwise = s [] : group' xs x x (x :)
530 -- This one works forwards *and* backwards, as well as also being
531 -- faster that the one in Util.lhs.
536 let ((h1:t1):tt1) = group p xs
537 (t,tt) = if null xs then ([],[]) else
538 if x `p` h1 then (h1:t1,tt1) else
543 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
544 generalMerge p xs [] = xs
545 generalMerge p [] ys = ys
546 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
547 | otherwise = y : generalMerge p (x:xs) ys
549 -- gamma is now called balancedFold
551 balancedFold :: (a -> a -> a) -> [a] -> a
552 balancedFold f [] = error "can't reduce an empty list using balancedFold"
553 balancedFold f [x] = x
554 balancedFold f l = balancedFold f (balancedFold' f l)
556 balancedFold' :: (a -> a -> a) -> [a] -> [a]
557 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
558 balancedFold' f xs = xs
560 generalMergeSort p [] = []
561 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
563 generalNaturalMergeSort p [] = []
564 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
566 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
568 mergeSort = generalMergeSort (<=)
569 naturalMergeSort = generalNaturalMergeSort (<=)
571 mergeSortLe le = generalMergeSort le
572 naturalMergeSortLe le = generalNaturalMergeSort le
575 %************************************************************************
577 \subsection[Utils-transitive-closure]{Transitive closure}
579 %************************************************************************
581 This algorithm for transitive closure is straightforward, albeit quadratic.
584 transitiveClosure :: (a -> [a]) -- Successor function
585 -> (a -> a -> Bool) -- Equality predicate
587 -> [a] -- The transitive closure
589 transitiveClosure succ eq xs
593 go done (x:xs) | x `is_in` done = go done xs
594 | otherwise = go (x:done) (succ x ++ xs)
597 x `is_in` (y:ys) | eq x y = True
598 | otherwise = x `is_in` ys
601 %************************************************************************
603 \subsection[Utils-accum]{Accumulating}
605 %************************************************************************
607 @mapAccumL@ behaves like a combination
608 of @map@ and @foldl@;
609 it applies a function to each element of a list, passing an accumulating
610 parameter from left to right, and returning a final value of this
611 accumulator together with the new list.
614 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
615 -- and accumulator, returning new
616 -- accumulator and elt of result list
617 -> acc -- Initial accumulator
619 -> (acc, [y]) -- Final accumulator and result list
621 mapAccumL f b [] = (b, [])
622 mapAccumL f b (x:xs) = (b'', x':xs') where
624 (b'', xs') = mapAccumL f b' xs
627 @mapAccumR@ does the same, but working from right to left instead. Its type is
628 the same as @mapAccumL@, though.
631 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
632 -- and accumulator, returning new
633 -- accumulator and elt of result list
634 -> acc -- Initial accumulator
636 -> (acc, [y]) -- Final accumulator and result list
638 mapAccumR f b [] = (b, [])
639 mapAccumR f b (x:xs) = (b'', x':xs') where
641 (b', xs') = mapAccumR f b xs
644 Here is the bi-directional version, that works from both left and right.
647 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
648 -- Function of elt of input list
649 -- and accumulator, returning new
650 -- accumulator and elt of result list
651 -> accl -- Initial accumulator from left
652 -> accr -- Initial accumulator from right
654 -> (accl, accr, [y]) -- Final accumulators and result list
656 mapAccumB f a b [] = (a,b,[])
657 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
659 (a',b'',y) = f a b' x
660 (a'',b',ys) = mapAccumB f a' b xs
663 %************************************************************************
665 \subsection[Utils-comparison]{Comparisons}
667 %************************************************************************
670 thenCmp :: Ordering -> Ordering -> Ordering
671 {-# INLINE thenCmp #-}
673 thenCmp other any = other
675 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
676 -- `cmpList' uses a user-specified comparer
678 cmpList cmp [] [] = EQ
679 cmpList cmp [] _ = LT
680 cmpList cmp _ [] = GT
681 cmpList cmp (a:as) (b:bs)
682 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
686 cmpString :: String -> String -> Ordering
689 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
690 else if x < y then LT
698 %************************************************************************
700 \subsection[Utils-pairs]{Pairs}
702 %************************************************************************
704 The following are curried versions of @fst@ and @snd@.
707 cfst :: a -> b -> a -- stranal-sem only (Note)
711 The following provide us higher order functions that, when applied
712 to a function, operate on pairs.
715 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
716 applyToPair (f,g) (x,y) = (f x, g y)
718 applyToFst :: (a -> c) -> (a,b)-> (c,b)
719 applyToFst f (x,y) = (f x,y)
721 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
722 applyToSnd f (x,y) = (x,f y)
724 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
725 foldPair fg ab [] = ab
726 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
727 where (u,v) = foldPair fg ab abs
731 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
732 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
737 seqList :: [a] -> b -> b
739 seqList :: (Eval a) => [a] -> b -> b
742 seqList (x:xs) b = x `seq` seqList xs b
744 #if __HASKELL1__ <= 4
745 ($!) :: (Eval a) => (a -> b) -> a -> b