2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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 IF_NOT_GHC(forall COMMA exists COMMA)
16 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
18 mapAndUnzip, mapAndUnzip3,
19 nOfThem, lengthExceeds, isSingleton,
20 startsWith, endsWith, snocView,
24 assoc, assocUsing, assocDefault, assocDefaultUsing,
27 hasNoDups, equivClasses, runs, removeDups,
30 IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
32 IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
33 IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
35 -- transitive closures
39 mapAccumL, mapAccumR, mapAccumB,
46 IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
47 IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
50 -- tracing (abstract away from lib home)
54 panic, panic#, assertPanic
58 #include "HsVersions.h"
60 import FastString ( FastString )
61 import List ( zipWith4 )
62 import GlaExts ( trace )
67 %************************************************************************
69 \subsection{The Eager monad}
71 %************************************************************************
73 The @Eager@ monad is just an encoding of continuation-passing style,
74 used to allow you to express "do this and then that", mainly to avoid
75 space leaks. It's done with a type synonym to save bureaucracy.
78 type Eager ans a = (a -> ans) -> ans
80 runEager :: Eager a a -> a
81 runEager m = m (\x -> x)
83 appEager :: Eager ans a -> (a -> ans) -> ans
84 appEager m cont = m cont
86 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
87 thenEager m k cont = m (\r -> k r cont)
89 returnEager :: a -> Eager ans a
90 returnEager v cont = cont v
92 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
93 mapEager f [] = returnEager []
94 mapEager f (x:xs) = f x `thenEager` \ y ->
95 mapEager f xs `thenEager` \ ys ->
99 %************************************************************************
101 \subsection[Utils-lists]{General list processing}
103 %************************************************************************
105 Quantifiers are not standard in Haskell. The following fill in the gap.
108 forall :: (a -> Bool) -> [a] -> Bool
109 forall pred [] = True
110 forall pred (x:xs) = pred x && forall pred xs
112 exists :: (a -> Bool) -> [a] -> Bool
113 exists pred [] = False
114 exists pred (x:xs) = pred x || exists pred xs
117 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
118 are of equal length. Alastair Reid thinks this should only happen if
119 DEBUGging on; hey, why not?
122 zipEqual :: String -> [a] -> [b] -> [(a,b)]
123 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
124 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
125 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
129 zipWithEqual _ = zipWith
130 zipWith3Equal _ = zipWith3
131 zipWith4Equal _ = zipWith4
133 zipEqual msg [] [] = []
134 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
135 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
137 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
138 zipWithEqual msg _ [] [] = []
139 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
141 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
142 = z a b c : zipWith3Equal msg z as bs cs
143 zipWith3Equal msg _ [] [] [] = []
144 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
146 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
147 = z a b c d : zipWith4Equal msg z as bs cs ds
148 zipWith4Equal msg _ [] [] [] [] = []
149 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
154 -- zipLazy is lazy in the second list (observe the ~)
156 zipLazy :: [a] -> [b] -> [(a,b)]
158 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
162 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
164 mapAndUnzip f [] = ([],[])
168 (rs1, rs2) = mapAndUnzip f xs
172 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
174 mapAndUnzip3 f [] = ([],[],[])
175 mapAndUnzip3 f (x:xs)
178 (rs1, rs2, rs3) = mapAndUnzip3 f xs
180 (r1:rs1, r2:rs2, r3:rs3)
184 nOfThem :: Int -> a -> [a]
185 nOfThem n thing = take n (repeat thing)
187 lengthExceeds :: [a] -> Int -> Bool
189 [] `lengthExceeds` n = 0 > n
190 (x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
192 isSingleton :: [a] -> Bool
194 isSingleton [x] = True
195 isSingleton _ = False
197 startsWith, endsWith :: String -> String -> Maybe String
199 startsWith [] str = Just str
200 startsWith (c:cs) (s:ss)
201 = if c /= s then Nothing else startsWith cs ss
202 startsWith _ [] = Nothing
205 = case (startsWith (reverse cs) (reverse ss)) of
207 Just rs -> Just (reverse rs)
211 snocView :: [a] -> ([a], a) -- Split off the last element
212 snocView xs = go xs []
214 go [x] acc = (reverse acc, x)
215 go (x:xs) acc = go xs (x:acc)
218 Debugging/specialising versions of \tr{elem} and \tr{notElem}
221 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
224 isIn msg x ys = elem__ x ys
225 isn'tIn msg x ys = notElem__ x ys
227 --these are here to be SPECIALIZEd (automagically)
229 elem__ x (y:ys) = x==y || elem__ x ys
231 notElem__ x [] = True
232 notElem__ x (y:ys) = x /= y && notElem__ x ys
240 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
241 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
244 = notElem ILIT(0) x ys
246 notElem i x [] = True
248 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
249 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
255 %************************************************************************
257 \subsection[Utils-assoc]{Association lists}
259 %************************************************************************
261 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
264 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
265 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
266 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
267 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
269 assocDefaultUsing eq deflt ((k,v) : rest) key
271 | otherwise = assocDefaultUsing eq deflt rest key
273 assocDefaultUsing eq deflt [] key = deflt
275 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
276 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
277 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
280 %************************************************************************
282 \subsection[Utils-dups]{Duplicate-handling}
284 %************************************************************************
287 hasNoDups :: (Eq a) => [a] -> Bool
289 hasNoDups xs = f [] xs
291 f seen_so_far [] = True
292 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
297 is_elem = isIn "hasNoDups"
301 equivClasses :: (a -> a -> Ordering) -- Comparison
305 equivClasses cmp stuff@[] = []
306 equivClasses cmp stuff@[item] = [stuff]
307 equivClasses cmp items
308 = runs eq (sortLt lt items)
310 eq a b = case cmp a b of { EQ -> True; _ -> False }
311 lt a b = case cmp a b of { LT -> True; _ -> False }
314 The first cases in @equivClasses@ above are just to cut to the point
317 @runs@ groups a list into a list of lists, each sublist being a run of
318 identical elements of the input list. It is passed a predicate @p@ which
319 tells when two elements are equal.
322 runs :: (a -> a -> Bool) -- Equality
327 runs p (x:xs) = case (span (p x) xs) of
328 (first, rest) -> (x:first) : (runs p rest)
332 removeDups :: (a -> a -> Ordering) -- Comparison function
334 -> ([a], -- List with no duplicates
335 [[a]]) -- List of duplicate groups. One representative from
336 -- each group appears in the first result
338 removeDups cmp [] = ([], [])
339 removeDups cmp [x] = ([x],[])
341 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
344 collect_dups dups_so_far [x] = (dups_so_far, x)
345 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
349 %************************************************************************
351 \subsection[Utils-sorting]{Sorting}
353 %************************************************************************
355 %************************************************************************
357 \subsubsection[Utils-quicksorting]{Quicksorts}
359 %************************************************************************
362 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
363 quicksort :: (a -> a -> Bool) -- Less-than predicate
365 -> [a] -- Result list in increasing order
368 quicksort lt [x] = [x]
369 quicksort lt (x:xs) = split x [] [] xs
371 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
372 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
373 | True = split x lo (y:hi) ys
376 Quicksort variant from Lennart's Haskell-library contribution. This
377 is a {\em stable} sort.
380 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
382 sortLt :: (a -> a -> Bool) -- Less-than predicate
384 -> [a] -- Result list
386 sortLt lt l = qsort lt l []
388 -- qsort is stable and does not concatenate.
389 qsort :: (a -> a -> Bool) -- Less-than predicate
390 -> [a] -- xs, Input list
391 -> [a] -- r, Concatenate this list to the sorted input list
392 -> [a] -- Result = sort xs ++ r
396 qsort lt (x:xs) r = qpart lt x xs [] [] r
398 -- qpart partitions and sorts the sublists
399 -- rlt contains things less than x,
400 -- rge contains the ones greater than or equal to x.
401 -- Both have equal elements reversed with respect to the original list.
403 qpart lt x [] rlt rge r =
404 -- rlt and rge are in reverse order and must be sorted with an
405 -- anti-stable sorting
406 rqsort lt rlt (x : rqsort lt rge r)
408 qpart lt x (y:ys) rlt rge r =
411 qpart lt x ys (y:rlt) rge r
414 qpart lt x ys rlt (y:rge) r
416 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
418 rqsort lt [x] r = x:r
419 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
421 rqpart lt x [] rle rgt r =
422 qsort lt rle (x : qsort lt rgt r)
424 rqpart lt x (y:ys) rle rgt r =
427 rqpart lt x ys rle (y:rgt) r
430 rqpart lt x ys (y:rle) rgt r
433 %************************************************************************
435 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
437 %************************************************************************
440 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
442 mergesort cmp xs = merge_lists (split_into_runs [] xs)
444 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
445 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
447 split_into_runs [] [] = []
448 split_into_runs run [] = [run]
449 split_into_runs [] (x:xs) = split_into_runs [x] xs
450 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
451 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
452 | True = rl : (split_into_runs [x] xs)
455 merge_lists (x:xs) = merge x (merge_lists xs)
459 merge xl@(x:xs) yl@(y:ys)
461 EQ -> x : y : (merge xs ys)
462 LT -> x : (merge xs yl)
463 GT -> y : (merge xl ys)
466 %************************************************************************
468 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
470 %************************************************************************
473 Date: Mon, 3 May 93 20:45:23 +0200
474 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
475 To: partain@dcs.gla.ac.uk
476 Subject: natural merge sort beats quick sort [ and it is prettier ]
478 Here is a piece of Haskell code that I'm rather fond of. See it as an
479 attempt to get rid of the ridiculous quick-sort routine. group is
480 quite useful by itself I think it was John's idea originally though I
481 believe the lazy version is due to me [surprisingly complicated].
482 gamma [used to be called] is called gamma because I got inspired by
483 the Gamma calculus. It is not very close to the calculus but does
484 behave less sequentially than both foldr and foldl. One could imagine
485 a version of gamma that took a unit element as well thereby avoiding
486 the problem with empty lists.
488 I've tried this code against
490 1) insertion sort - as provided by haskell
491 2) the normal implementation of quick sort
492 3) a deforested version of quick sort due to Jan Sparud
493 4) a super-optimized-quick-sort of Lennart's
495 If the list is partially sorted both merge sort and in particular
496 natural merge sort wins. If the list is random [ average length of
497 rising subsequences = approx 2 ] mergesort still wins and natural
498 merge sort is marginally beaten by Lennart's soqs. The space
499 consumption of merge sort is a bit worse than Lennart's quick sort
500 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
501 fpca article ] isn't used because of group.
508 group :: (a -> a -> Bool) -> [a] -> [[a]]
511 Date: Mon, 12 Feb 1996 15:09:41 +0000
512 From: Andy Gill <andy@dcs.gla.ac.uk>
514 Here is a `better' definition of group.
517 group p (x:xs) = group' xs x x (x :)
519 group' [] _ _ s = [s []]
520 group' (x:xs) x_min x_max s
521 | not (x `p` x_max) = group' xs x_min x (s . (x :))
522 | x `p` x_min = group' xs x x_max ((x :) . s)
523 | otherwise = s [] : group' xs x x (x :)
525 -- This one works forwards *and* backwards, as well as also being
526 -- faster that the one in Util.lhs.
531 let ((h1:t1):tt1) = group p xs
532 (t,tt) = if null xs then ([],[]) else
533 if x `p` h1 then (h1:t1,tt1) else
538 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
539 generalMerge p xs [] = xs
540 generalMerge p [] ys = ys
541 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
542 | otherwise = y : generalMerge p (x:xs) ys
544 -- gamma is now called balancedFold
546 balancedFold :: (a -> a -> a) -> [a] -> a
547 balancedFold f [] = error "can't reduce an empty list using balancedFold"
548 balancedFold f [x] = x
549 balancedFold f l = balancedFold f (balancedFold' f l)
551 balancedFold' :: (a -> a -> a) -> [a] -> [a]
552 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
553 balancedFold' f xs = xs
555 generalMergeSort p [] = []
556 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
558 generalNaturalMergeSort p [] = []
559 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
561 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
563 mergeSort = generalMergeSort (<=)
564 naturalMergeSort = generalNaturalMergeSort (<=)
566 mergeSortLe le = generalMergeSort le
567 naturalMergeSortLe le = generalNaturalMergeSort le
570 %************************************************************************
572 \subsection[Utils-transitive-closure]{Transitive closure}
574 %************************************************************************
576 This algorithm for transitive closure is straightforward, albeit quadratic.
579 transitiveClosure :: (a -> [a]) -- Successor function
580 -> (a -> a -> Bool) -- Equality predicate
582 -> [a] -- The transitive closure
584 transitiveClosure succ eq xs
588 go done (x:xs) | x `is_in` done = go done xs
589 | otherwise = go (x:done) (succ x ++ xs)
592 x `is_in` (y:ys) | eq x y = True
593 | otherwise = x `is_in` ys
596 %************************************************************************
598 \subsection[Utils-accum]{Accumulating}
600 %************************************************************************
602 @mapAccumL@ behaves like a combination
603 of @map@ and @foldl@;
604 it applies a function to each element of a list, passing an accumulating
605 parameter from left to right, and returning a final value of this
606 accumulator together with the new list.
609 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
610 -- and accumulator, returning new
611 -- accumulator and elt of result list
612 -> acc -- Initial accumulator
614 -> (acc, [y]) -- Final accumulator and result list
616 mapAccumL f b [] = (b, [])
617 mapAccumL f b (x:xs) = (b'', x':xs') where
619 (b'', xs') = mapAccumL f b' xs
622 @mapAccumR@ does the same, but working from right to left instead. Its type is
623 the same as @mapAccumL@, though.
626 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
627 -- and accumulator, returning new
628 -- accumulator and elt of result list
629 -> acc -- Initial accumulator
631 -> (acc, [y]) -- Final accumulator and result list
633 mapAccumR f b [] = (b, [])
634 mapAccumR f b (x:xs) = (b'', x':xs') where
636 (b', xs') = mapAccumR f b xs
639 Here is the bi-directional version, that works from both left and right.
642 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
643 -- Function of elt of input list
644 -- and accumulator, returning new
645 -- accumulator and elt of result list
646 -> accl -- Initial accumulator from left
647 -> accr -- Initial accumulator from right
649 -> (accl, accr, [y]) -- Final accumulators and result list
651 mapAccumB f a b [] = (a,b,[])
652 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
654 (a',b'',y) = f a b' x
655 (a'',b',ys) = mapAccumB f a' b xs
658 %************************************************************************
660 \subsection[Utils-comparison]{Comparisons}
662 %************************************************************************
665 thenCmp :: Ordering -> Ordering -> Ordering
666 {-# INLINE thenCmp #-}
668 thenCmp other any = other
670 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
671 -- `cmpList' uses a user-specified comparer
673 cmpList cmp [] [] = EQ
674 cmpList cmp [] _ = LT
675 cmpList cmp _ [] = GT
676 cmpList cmp (a:as) (b:bs)
677 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
681 cmpString :: String -> String -> Ordering
684 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
685 else if x < y then LT
690 cmpString _ _ = panic "cmpString"
695 %************************************************************************
697 \subsection[Utils-pairs]{Pairs}
699 %************************************************************************
701 The following are curried versions of @fst@ and @snd@.
704 cfst :: a -> b -> a -- stranal-sem only (Note)
708 The following provide us higher order functions that, when applied
709 to a function, operate on pairs.
712 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
713 applyToPair (f,g) (x,y) = (f x, g y)
715 applyToFst :: (a -> c) -> (a,b)-> (c,b)
716 applyToFst f (x,y) = (f x,y)
718 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
719 applyToSnd f (x,y) = (x,f y)
721 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
722 foldPair fg ab [] = ab
723 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
724 where (u,v) = foldPair fg ab abs
728 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
729 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
733 %************************************************************************
735 \subsection[Utils-errors]{Error handling}
737 %************************************************************************
740 panic x = error ("panic! (the `impossible' happened):\n\t"
742 ++ "Please report it as a compiler bug "
743 ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
745 -- #-versions because panic can't return an unboxed int, and that's
746 -- what TAG_ is with GHC at the moment. Ugh. (Simon)
747 -- No, man -- Too Beautiful! (Will)
749 panic# :: String -> FAST_INT
750 panic# s = case (panic s) of () -> ILIT(0)
752 assertPanic :: String -> Int -> a
753 assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)