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)
51 panic, panic#, assertPanic
55 #include "HsVersions.h"
57 import FastString ( FastString )
58 import List ( zipWith4 )
63 %************************************************************************
65 \subsection{The Eager monad}
67 %************************************************************************
69 The @Eager@ monad is just an encoding of continuation-passing style,
70 used to allow you to express "do this and then that", mainly to avoid
71 space leaks. It's done with a type synonym to save bureaucracy.
74 type Eager ans a = (a -> ans) -> ans
76 runEager :: Eager a a -> a
77 runEager m = m (\x -> x)
79 appEager :: Eager ans a -> (a -> ans) -> ans
80 appEager m cont = m cont
82 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
83 thenEager m k cont = m (\r -> k r cont)
85 returnEager :: a -> Eager ans a
86 returnEager v cont = cont v
88 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
89 mapEager f [] = returnEager []
90 mapEager f (x:xs) = f x `thenEager` \ y ->
91 mapEager f xs `thenEager` \ ys ->
95 %************************************************************************
97 \subsection[Utils-lists]{General list processing}
99 %************************************************************************
101 Quantifiers are not standard in Haskell. The following fill in the gap.
104 forall :: (a -> Bool) -> [a] -> Bool
105 forall pred [] = True
106 forall pred (x:xs) = pred x && forall pred xs
108 exists :: (a -> Bool) -> [a] -> Bool
109 exists pred [] = False
110 exists pred (x:xs) = pred x || exists pred xs
113 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
114 are of equal length. Alastair Reid thinks this should only happen if
115 DEBUGging on; hey, why not?
118 zipEqual :: String -> [a] -> [b] -> [(a,b)]
119 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
120 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
121 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
125 zipWithEqual _ = zipWith
126 zipWith3Equal _ = zipWith3
127 zipWith4Equal _ = zipWith4
129 zipEqual msg [] [] = []
130 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
131 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
133 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
134 zipWithEqual msg _ [] [] = []
135 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
137 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
138 = z a b c : zipWith3Equal msg z as bs cs
139 zipWith3Equal msg _ [] [] [] = []
140 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
142 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
143 = z a b c d : zipWith4Equal msg z as bs cs ds
144 zipWith4Equal msg _ [] [] [] [] = []
145 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
150 -- zipLazy is lazy in the second list (observe the ~)
152 zipLazy :: [a] -> [b] -> [(a,b)]
154 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
158 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
160 mapAndUnzip f [] = ([],[])
164 (rs1, rs2) = mapAndUnzip f xs
168 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
170 mapAndUnzip3 f [] = ([],[],[])
171 mapAndUnzip3 f (x:xs)
174 (rs1, rs2, rs3) = mapAndUnzip3 f xs
176 (r1:rs1, r2:rs2, r3:rs3)
180 nOfThem :: Int -> a -> [a]
181 nOfThem n thing = take n (repeat thing)
183 lengthExceeds :: [a] -> Int -> Bool
185 [] `lengthExceeds` n = 0 > n
186 (x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
188 isSingleton :: [a] -> Bool
190 isSingleton [x] = True
191 isSingleton _ = False
193 startsWith, endsWith :: String -> String -> Maybe String
195 startsWith [] str = Just str
196 startsWith (c:cs) (s:ss)
197 = if c /= s then Nothing else startsWith cs ss
198 startsWith _ [] = Nothing
201 = case (startsWith (reverse cs) (reverse ss)) of
203 Just rs -> Just (reverse rs)
207 snocView :: [a] -> ([a], a) -- Split off the last element
208 snocView xs = go xs []
210 go [x] acc = (reverse acc, x)
211 go (x:xs) acc = go xs (x:acc)
214 Debugging/specialising versions of \tr{elem} and \tr{notElem}
217 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
220 isIn msg x ys = elem__ x ys
221 isn'tIn msg x ys = notElem__ x ys
223 --these are here to be SPECIALIZEd (automagically)
225 elem__ x (y:ys) = x==y || elem__ x ys
227 notElem__ x [] = True
228 notElem__ x (y:ys) = x /= y && notElem__ x ys
236 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
237 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
240 = notElem ILIT(0) x ys
242 notElem i x [] = True
244 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
245 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
251 %************************************************************************
253 \subsection[Utils-assoc]{Association lists}
255 %************************************************************************
257 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
260 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
261 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
262 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
263 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
265 assocDefaultUsing eq deflt ((k,v) : rest) key
267 | otherwise = assocDefaultUsing eq deflt rest key
269 assocDefaultUsing eq deflt [] key = deflt
271 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
272 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
273 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
276 %************************************************************************
278 \subsection[Utils-dups]{Duplicate-handling}
280 %************************************************************************
283 hasNoDups :: (Eq a) => [a] -> Bool
285 hasNoDups xs = f [] xs
287 f seen_so_far [] = True
288 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
293 is_elem = isIn "hasNoDups"
297 equivClasses :: (a -> a -> Ordering) -- Comparison
301 equivClasses cmp stuff@[] = []
302 equivClasses cmp stuff@[item] = [stuff]
303 equivClasses cmp items
304 = runs eq (sortLt lt items)
306 eq a b = case cmp a b of { EQ -> True; _ -> False }
307 lt a b = case cmp a b of { LT -> True; _ -> False }
310 The first cases in @equivClasses@ above are just to cut to the point
313 @runs@ groups a list into a list of lists, each sublist being a run of
314 identical elements of the input list. It is passed a predicate @p@ which
315 tells when two elements are equal.
318 runs :: (a -> a -> Bool) -- Equality
323 runs p (x:xs) = case (span (p x) xs) of
324 (first, rest) -> (x:first) : (runs p rest)
328 removeDups :: (a -> a -> Ordering) -- Comparison function
330 -> ([a], -- List with no duplicates
331 [[a]]) -- List of duplicate groups. One representative from
332 -- each group appears in the first result
334 removeDups cmp [] = ([], [])
335 removeDups cmp [x] = ([x],[])
337 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
340 collect_dups dups_so_far [x] = (dups_so_far, x)
341 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
345 %************************************************************************
347 \subsection[Utils-sorting]{Sorting}
349 %************************************************************************
351 %************************************************************************
353 \subsubsection[Utils-quicksorting]{Quicksorts}
355 %************************************************************************
358 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
359 quicksort :: (a -> a -> Bool) -- Less-than predicate
361 -> [a] -- Result list in increasing order
364 quicksort lt [x] = [x]
365 quicksort lt (x:xs) = split x [] [] xs
367 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
368 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
369 | True = split x lo (y:hi) ys
372 Quicksort variant from Lennart's Haskell-library contribution. This
373 is a {\em stable} sort.
376 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
378 sortLt :: (a -> a -> Bool) -- Less-than predicate
380 -> [a] -- Result list
382 sortLt lt l = qsort lt l []
384 -- qsort is stable and does not concatenate.
385 qsort :: (a -> a -> Bool) -- Less-than predicate
386 -> [a] -- xs, Input list
387 -> [a] -- r, Concatenate this list to the sorted input list
388 -> [a] -- Result = sort xs ++ r
392 qsort lt (x:xs) r = qpart lt x xs [] [] r
394 -- qpart partitions and sorts the sublists
395 -- rlt contains things less than x,
396 -- rge contains the ones greater than or equal to x.
397 -- Both have equal elements reversed with respect to the original list.
399 qpart lt x [] rlt rge r =
400 -- rlt and rge are in reverse order and must be sorted with an
401 -- anti-stable sorting
402 rqsort lt rlt (x : rqsort lt rge r)
404 qpart lt x (y:ys) rlt rge r =
407 qpart lt x ys (y:rlt) rge r
410 qpart lt x ys rlt (y:rge) r
412 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
414 rqsort lt [x] r = x:r
415 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
417 rqpart lt x [] rle rgt r =
418 qsort lt rle (x : qsort lt rgt r)
420 rqpart lt x (y:ys) rle rgt r =
423 rqpart lt x ys rle (y:rgt) r
426 rqpart lt x ys (y:rle) rgt r
429 %************************************************************************
431 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
433 %************************************************************************
436 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
438 mergesort cmp xs = merge_lists (split_into_runs [] xs)
440 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
441 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
443 split_into_runs [] [] = []
444 split_into_runs run [] = [run]
445 split_into_runs [] (x:xs) = split_into_runs [x] xs
446 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
447 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
448 | True = rl : (split_into_runs [x] xs)
451 merge_lists (x:xs) = merge x (merge_lists xs)
455 merge xl@(x:xs) yl@(y:ys)
457 EQ -> x : y : (merge xs ys)
458 LT -> x : (merge xs yl)
459 GT -> y : (merge xl ys)
462 %************************************************************************
464 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
466 %************************************************************************
469 Date: Mon, 3 May 93 20:45:23 +0200
470 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
471 To: partain@dcs.gla.ac.uk
472 Subject: natural merge sort beats quick sort [ and it is prettier ]
474 Here is a piece of Haskell code that I'm rather fond of. See it as an
475 attempt to get rid of the ridiculous quick-sort routine. group is
476 quite useful by itself I think it was John's idea originally though I
477 believe the lazy version is due to me [surprisingly complicated].
478 gamma [used to be called] is called gamma because I got inspired by
479 the Gamma calculus. It is not very close to the calculus but does
480 behave less sequentially than both foldr and foldl. One could imagine
481 a version of gamma that took a unit element as well thereby avoiding
482 the problem with empty lists.
484 I've tried this code against
486 1) insertion sort - as provided by haskell
487 2) the normal implementation of quick sort
488 3) a deforested version of quick sort due to Jan Sparud
489 4) a super-optimized-quick-sort of Lennart's
491 If the list is partially sorted both merge sort and in particular
492 natural merge sort wins. If the list is random [ average length of
493 rising subsequences = approx 2 ] mergesort still wins and natural
494 merge sort is marginally beaten by Lennart's soqs. The space
495 consumption of merge sort is a bit worse than Lennart's quick sort
496 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
497 fpca article ] isn't used because of group.
504 group :: (a -> a -> Bool) -> [a] -> [[a]]
507 Date: Mon, 12 Feb 1996 15:09:41 +0000
508 From: Andy Gill <andy@dcs.gla.ac.uk>
510 Here is a `better' definition of group.
513 group p (x:xs) = group' xs x x (x :)
515 group' [] _ _ s = [s []]
516 group' (x:xs) x_min x_max s
517 | not (x `p` x_max) = group' xs x_min x (s . (x :))
518 | x `p` x_min = group' xs x x_max ((x :) . s)
519 | otherwise = s [] : group' xs x x (x :)
521 -- This one works forwards *and* backwards, as well as also being
522 -- faster that the one in Util.lhs.
527 let ((h1:t1):tt1) = group p xs
528 (t,tt) = if null xs then ([],[]) else
529 if x `p` h1 then (h1:t1,tt1) else
534 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
535 generalMerge p xs [] = xs
536 generalMerge p [] ys = ys
537 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
538 | otherwise = y : generalMerge p (x:xs) ys
540 -- gamma is now called balancedFold
542 balancedFold :: (a -> a -> a) -> [a] -> a
543 balancedFold f [] = error "can't reduce an empty list using balancedFold"
544 balancedFold f [x] = x
545 balancedFold f l = balancedFold f (balancedFold' f l)
547 balancedFold' :: (a -> a -> a) -> [a] -> [a]
548 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
549 balancedFold' f xs = xs
551 generalMergeSort p [] = []
552 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
554 generalNaturalMergeSort p [] = []
555 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
557 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
559 mergeSort = generalMergeSort (<=)
560 naturalMergeSort = generalNaturalMergeSort (<=)
562 mergeSortLe le = generalMergeSort le
563 naturalMergeSortLe le = generalNaturalMergeSort le
566 %************************************************************************
568 \subsection[Utils-transitive-closure]{Transitive closure}
570 %************************************************************************
572 This algorithm for transitive closure is straightforward, albeit quadratic.
575 transitiveClosure :: (a -> [a]) -- Successor function
576 -> (a -> a -> Bool) -- Equality predicate
578 -> [a] -- The transitive closure
580 transitiveClosure succ eq xs
584 go done (x:xs) | x `is_in` done = go done xs
585 | otherwise = go (x:done) (succ x ++ xs)
588 x `is_in` (y:ys) | eq x y = True
589 | otherwise = x `is_in` ys
592 %************************************************************************
594 \subsection[Utils-accum]{Accumulating}
596 %************************************************************************
598 @mapAccumL@ behaves like a combination
599 of @map@ and @foldl@;
600 it applies a function to each element of a list, passing an accumulating
601 parameter from left to right, and returning a final value of this
602 accumulator together with the new list.
605 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
606 -- and accumulator, returning new
607 -- accumulator and elt of result list
608 -> acc -- Initial accumulator
610 -> (acc, [y]) -- Final accumulator and result list
612 mapAccumL f b [] = (b, [])
613 mapAccumL f b (x:xs) = (b'', x':xs') where
615 (b'', xs') = mapAccumL f b' xs
618 @mapAccumR@ does the same, but working from right to left instead. Its type is
619 the same as @mapAccumL@, though.
622 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
623 -- and accumulator, returning new
624 -- accumulator and elt of result list
625 -> acc -- Initial accumulator
627 -> (acc, [y]) -- Final accumulator and result list
629 mapAccumR f b [] = (b, [])
630 mapAccumR f b (x:xs) = (b'', x':xs') where
632 (b', xs') = mapAccumR f b xs
635 Here is the bi-directional version, that works from both left and right.
638 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
639 -- Function of elt of input list
640 -- and accumulator, returning new
641 -- accumulator and elt of result list
642 -> accl -- Initial accumulator from left
643 -> accr -- Initial accumulator from right
645 -> (accl, accr, [y]) -- Final accumulators and result list
647 mapAccumB f a b [] = (a,b,[])
648 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
650 (a',b'',y) = f a b' x
651 (a'',b',ys) = mapAccumB f a' b xs
654 %************************************************************************
656 \subsection[Utils-comparison]{Comparisons}
658 %************************************************************************
661 thenCmp :: Ordering -> Ordering -> Ordering
662 {-# INLINE thenCmp #-}
664 thenCmp other any = other
666 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
667 -- `cmpList' uses a user-specified comparer
669 cmpList cmp [] [] = EQ
670 cmpList cmp [] _ = LT
671 cmpList cmp _ [] = GT
672 cmpList cmp (a:as) (b:bs)
673 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
677 cmpString :: String -> String -> Ordering
680 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
681 else if x < y then LT
686 cmpString _ _ = panic "cmpString"
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
729 %************************************************************************
731 \subsection[Utils-errors]{Error handling}
733 %************************************************************************
736 panic x = error ("panic! (the `impossible' happened):\n\t"
738 ++ "Please report it as a compiler bug "
739 ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
741 -- #-versions because panic can't return an unboxed int, and that's
742 -- what TAG_ is with GHC at the moment. Ugh. (Simon)
743 -- No, man -- Too Beautiful! (Will)
745 panic# :: String -> FAST_INT
746 panic# s = case (panic s) of () -> ILIT(0)
748 assertPanic :: String -> Int -> a
749 assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)