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, foldl2, count,
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
183 -- (lengthExceeds xs n) is True if length xs > n
184 (x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
185 [] `lengthExceeds` n = n < 0
187 isSingleton :: [a] -> Bool
188 isSingleton [x] = True
189 isSingleton _ = False
200 snocView :: [a] -> ([a], a) -- Split off the last element
201 snocView xs = go xs []
203 go [x] acc = (reverse acc, x)
204 go (x:xs) acc = go xs (x:acc)
207 Debugging/specialising versions of \tr{elem} and \tr{notElem}
210 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
213 isIn msg x ys = elem__ x ys
214 isn'tIn msg x ys = notElem__ x ys
216 --these are here to be SPECIALIZEd (automagically)
218 elem__ x (y:ys) = x==y || elem__ x ys
220 notElem__ x [] = True
221 notElem__ x (y:ys) = x /= y && notElem__ x ys
229 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
230 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
233 = notElem ILIT(0) x ys
235 notElem i x [] = True
237 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
238 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
244 %************************************************************************
246 \subsection[Utils-assoc]{Association lists}
248 %************************************************************************
250 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
253 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
254 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
255 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
256 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
258 assocDefaultUsing eq deflt ((k,v) : rest) key
260 | otherwise = assocDefaultUsing eq deflt rest key
262 assocDefaultUsing eq deflt [] key = deflt
264 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
265 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
266 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
269 %************************************************************************
271 \subsection[Utils-dups]{Duplicate-handling}
273 %************************************************************************
276 hasNoDups :: (Eq a) => [a] -> Bool
278 hasNoDups xs = f [] xs
280 f seen_so_far [] = True
281 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
286 is_elem = isIn "hasNoDups"
290 equivClasses :: (a -> a -> Ordering) -- Comparison
294 equivClasses cmp stuff@[] = []
295 equivClasses cmp stuff@[item] = [stuff]
296 equivClasses cmp items
297 = runs eq (sortLt lt items)
299 eq a b = case cmp a b of { EQ -> True; _ -> False }
300 lt a b = case cmp a b of { LT -> True; _ -> False }
303 The first cases in @equivClasses@ above are just to cut to the point
306 @runs@ groups a list into a list of lists, each sublist being a run of
307 identical elements of the input list. It is passed a predicate @p@ which
308 tells when two elements are equal.
311 runs :: (a -> a -> Bool) -- Equality
316 runs p (x:xs) = case (span (p x) xs) of
317 (first, rest) -> (x:first) : (runs p rest)
321 removeDups :: (a -> a -> Ordering) -- Comparison function
323 -> ([a], -- List with no duplicates
324 [[a]]) -- List of duplicate groups. One representative from
325 -- each group appears in the first result
327 removeDups cmp [] = ([], [])
328 removeDups cmp [x] = ([x],[])
330 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
333 collect_dups dups_so_far [x] = (dups_so_far, x)
334 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
339 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
340 -- NB: it's *very* important that if we have the input list [a,b,c],
341 -- where a,b,c all have the same unique, then we get back the list
345 -- Hence the use of foldr, plus the reversed-args tack_on below
346 equivClassesByUniq get_uniq xs
347 = eltsUFM (foldr add emptyUFM xs)
349 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
350 tack_on old new = new++old
353 %************************************************************************
355 \subsection[Utils-sorting]{Sorting}
357 %************************************************************************
359 %************************************************************************
361 \subsubsection[Utils-quicksorting]{Quicksorts}
363 %************************************************************************
366 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
367 quicksort :: (a -> a -> Bool) -- Less-than predicate
369 -> [a] -- Result list in increasing order
372 quicksort lt [x] = [x]
373 quicksort lt (x:xs) = split x [] [] xs
375 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
376 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
377 | True = split x lo (y:hi) ys
380 Quicksort variant from Lennart's Haskell-library contribution. This
381 is a {\em stable} sort.
384 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
386 sortLt :: (a -> a -> Bool) -- Less-than predicate
388 -> [a] -- Result list
390 sortLt lt l = qsort lt l []
392 -- qsort is stable and does not concatenate.
393 qsort :: (a -> a -> Bool) -- Less-than predicate
394 -> [a] -- xs, Input list
395 -> [a] -- r, Concatenate this list to the sorted input list
396 -> [a] -- Result = sort xs ++ r
400 qsort lt (x:xs) r = qpart lt x xs [] [] r
402 -- qpart partitions and sorts the sublists
403 -- rlt contains things less than x,
404 -- rge contains the ones greater than or equal to x.
405 -- Both have equal elements reversed with respect to the original list.
407 qpart lt x [] rlt rge r =
408 -- rlt and rge are in reverse order and must be sorted with an
409 -- anti-stable sorting
410 rqsort lt rlt (x : rqsort lt rge r)
412 qpart lt x (y:ys) rlt rge r =
415 qpart lt x ys (y:rlt) rge r
418 qpart lt x ys rlt (y:rge) r
420 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
422 rqsort lt [x] r = x:r
423 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
425 rqpart lt x [] rle rgt r =
426 qsort lt rle (x : qsort lt rgt r)
428 rqpart lt x (y:ys) rle rgt r =
431 rqpart lt x ys rle (y:rgt) r
434 rqpart lt x ys (y:rle) rgt r
437 %************************************************************************
439 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
441 %************************************************************************
444 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
446 mergesort cmp xs = merge_lists (split_into_runs [] xs)
448 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
449 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
451 split_into_runs [] [] = []
452 split_into_runs run [] = [run]
453 split_into_runs [] (x:xs) = split_into_runs [x] xs
454 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
455 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
456 | True = rl : (split_into_runs [x] xs)
459 merge_lists (x:xs) = merge x (merge_lists xs)
463 merge xl@(x:xs) yl@(y:ys)
465 EQ -> x : y : (merge xs ys)
466 LT -> x : (merge xs yl)
467 GT -> y : (merge xl ys)
470 %************************************************************************
472 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
474 %************************************************************************
477 Date: Mon, 3 May 93 20:45:23 +0200
478 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
479 To: partain@dcs.gla.ac.uk
480 Subject: natural merge sort beats quick sort [ and it is prettier ]
482 Here is a piece of Haskell code that I'm rather fond of. See it as an
483 attempt to get rid of the ridiculous quick-sort routine. group is
484 quite useful by itself I think it was John's idea originally though I
485 believe the lazy version is due to me [surprisingly complicated].
486 gamma [used to be called] is called gamma because I got inspired by
487 the Gamma calculus. It is not very close to the calculus but does
488 behave less sequentially than both foldr and foldl. One could imagine
489 a version of gamma that took a unit element as well thereby avoiding
490 the problem with empty lists.
492 I've tried this code against
494 1) insertion sort - as provided by haskell
495 2) the normal implementation of quick sort
496 3) a deforested version of quick sort due to Jan Sparud
497 4) a super-optimized-quick-sort of Lennart's
499 If the list is partially sorted both merge sort and in particular
500 natural merge sort wins. If the list is random [ average length of
501 rising subsequences = approx 2 ] mergesort still wins and natural
502 merge sort is marginally beaten by Lennart's soqs. The space
503 consumption of merge sort is a bit worse than Lennart's quick sort
504 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
505 fpca article ] isn't used because of group.
512 group :: (a -> a -> Bool) -> [a] -> [[a]]
515 Date: Mon, 12 Feb 1996 15:09:41 +0000
516 From: Andy Gill <andy@dcs.gla.ac.uk>
518 Here is a `better' definition of group.
521 group p (x:xs) = group' xs x x (x :)
523 group' [] _ _ s = [s []]
524 group' (x:xs) x_min x_max s
525 | not (x `p` x_max) = group' xs x_min x (s . (x :))
526 | x `p` x_min = group' xs x x_max ((x :) . s)
527 | otherwise = s [] : group' xs x x (x :)
529 -- This one works forwards *and* backwards, as well as also being
530 -- faster that the one in Util.lhs.
535 let ((h1:t1):tt1) = group p xs
536 (t,tt) = if null xs then ([],[]) else
537 if x `p` h1 then (h1:t1,tt1) else
542 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
543 generalMerge p xs [] = xs
544 generalMerge p [] ys = ys
545 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
546 | otherwise = y : generalMerge p (x:xs) ys
548 -- gamma is now called balancedFold
550 balancedFold :: (a -> a -> a) -> [a] -> a
551 balancedFold f [] = error "can't reduce an empty list using balancedFold"
552 balancedFold f [x] = x
553 balancedFold f l = balancedFold f (balancedFold' f l)
555 balancedFold' :: (a -> a -> a) -> [a] -> [a]
556 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
557 balancedFold' f xs = xs
559 generalMergeSort p [] = []
560 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
562 generalNaturalMergeSort p [] = []
563 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
565 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
567 mergeSort = generalMergeSort (<=)
568 naturalMergeSort = generalNaturalMergeSort (<=)
570 mergeSortLe le = generalMergeSort le
571 naturalMergeSortLe le = generalNaturalMergeSort le
574 %************************************************************************
576 \subsection[Utils-transitive-closure]{Transitive closure}
578 %************************************************************************
580 This algorithm for transitive closure is straightforward, albeit quadratic.
583 transitiveClosure :: (a -> [a]) -- Successor function
584 -> (a -> a -> Bool) -- Equality predicate
586 -> [a] -- The transitive closure
588 transitiveClosure succ eq xs
592 go done (x:xs) | x `is_in` done = go done xs
593 | otherwise = go (x:done) (succ x ++ xs)
596 x `is_in` (y:ys) | eq x y = True
597 | otherwise = x `is_in` ys
600 %************************************************************************
602 \subsection[Utils-accum]{Accumulating}
604 %************************************************************************
606 @mapAccumL@ behaves like a combination
607 of @map@ and @foldl@;
608 it applies a function to each element of a list, passing an accumulating
609 parameter from left to right, and returning a final value of this
610 accumulator together with the new list.
613 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
614 -- and accumulator, returning new
615 -- accumulator and elt of result list
616 -> acc -- Initial accumulator
618 -> (acc, [y]) -- Final accumulator and result list
620 mapAccumL f b [] = (b, [])
621 mapAccumL f b (x:xs) = (b'', x':xs') where
623 (b'', xs') = mapAccumL f b' xs
626 @mapAccumR@ does the same, but working from right to left instead. Its type is
627 the same as @mapAccumL@, though.
630 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
631 -- and accumulator, returning new
632 -- accumulator and elt of result list
633 -> acc -- Initial accumulator
635 -> (acc, [y]) -- Final accumulator and result list
637 mapAccumR f b [] = (b, [])
638 mapAccumR f b (x:xs) = (b'', x':xs') where
640 (b', xs') = mapAccumR f b xs
643 Here is the bi-directional version, that works from both left and right.
646 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
647 -- Function of elt of input list
648 -- and accumulator, returning new
649 -- accumulator and elt of result list
650 -> accl -- Initial accumulator from left
651 -> accr -- Initial accumulator from right
653 -> (accl, accr, [y]) -- Final accumulators and result list
655 mapAccumB f a b [] = (a,b,[])
656 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
658 (a',b'',y) = f a b' x
659 (a'',b',ys) = mapAccumB f a' b xs
662 A combination of foldl with zip. It works with equal length lists.
665 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
667 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
670 Count the number of times a predicate is true
673 count :: (a -> Bool) -> [a] -> Int
675 count p (x:xs) | p x = 1 + count p xs
676 | otherwise = count p xs
680 %************************************************************************
682 \subsection[Utils-comparison]{Comparisons}
684 %************************************************************************
687 thenCmp :: Ordering -> Ordering -> Ordering
688 {-# INLINE thenCmp #-}
690 thenCmp other any = other
692 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
693 -- `cmpList' uses a user-specified comparer
695 cmpList cmp [] [] = EQ
696 cmpList cmp [] _ = LT
697 cmpList cmp _ [] = GT
698 cmpList cmp (a:as) (b:bs)
699 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
703 cmpString :: String -> String -> Ordering
706 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
707 else if x < y then LT
714 %************************************************************************
716 \subsection[Utils-pairs]{Pairs}
718 %************************************************************************
720 The following are curried versions of @fst@ and @snd@.
723 cfst :: a -> b -> a -- stranal-sem only (Note)
727 The following provide us higher order functions that, when applied
728 to a function, operate on pairs.
731 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
732 applyToPair (f,g) (x,y) = (f x, g y)
734 applyToFst :: (a -> c) -> (a,b)-> (c,b)
735 applyToFst f (x,y) = (f x,y)
737 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
738 applyToSnd f (x,y) = (x,f y)
740 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
741 foldPair fg ab [] = ab
742 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
743 where (u,v) = foldPair fg ab abs
747 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
748 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
753 seqList :: [a] -> b -> b
755 seqList :: (Eval a) => [a] -> b -> b
758 seqList (x:xs) b = x `seq` seqList xs b
760 #if __HASKELL1__ <= 4
761 ($!) :: (Eval a) => (a -> b) -> a -> b
767 #if __GLASGOW_HASKELL__ < 402
768 bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
769 bracket before after thing = do
771 (thing a) `catch` (\err -> after a >>= fail err)