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 IF_NOT_GHC(forall COMMA exists COMMA)
16 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
17 zipLazy, stretchZipEqual,
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
163 stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
164 -- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
166 stretchZipEqual f [] [] = []
167 stretchZipEqual f (x:xs) (y:ys) = case f x y of
168 Just x' -> x' : stretchZipEqual f xs ys
169 Nothing -> x : stretchZipEqual f xs (y:ys)
174 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
176 mapAndUnzip f [] = ([],[])
180 (rs1, rs2) = mapAndUnzip f xs
184 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
186 mapAndUnzip3 f [] = ([],[],[])
187 mapAndUnzip3 f (x:xs)
190 (rs1, rs2, rs3) = mapAndUnzip3 f xs
192 (r1:rs1, r2:rs2, r3:rs3)
196 nOfThem :: Int -> a -> [a]
197 nOfThem n thing = take n (repeat thing)
199 lengthExceeds :: [a] -> Int -> Bool
201 [] `lengthExceeds` n = 0 > n
202 (x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
204 isSingleton :: [a] -> Bool
206 isSingleton [x] = True
207 isSingleton _ = False
209 startsWith, endsWith :: String -> String -> Maybe String
211 startsWith [] str = Just str
212 startsWith (c:cs) (s:ss)
213 = if c /= s then Nothing else startsWith cs ss
214 startsWith _ [] = Nothing
217 = case (startsWith (reverse cs) (reverse ss)) of
219 Just rs -> Just (reverse rs)
223 snocView :: [a] -> ([a], a) -- Split off the last element
224 snocView xs = go xs []
226 go [x] acc = (reverse acc, x)
227 go (x:xs) acc = go xs (x:acc)
230 Debugging/specialising versions of \tr{elem} and \tr{notElem}
233 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
236 isIn msg x ys = elem__ x ys
237 isn'tIn msg x ys = notElem__ x ys
239 --these are here to be SPECIALIZEd (automagically)
241 elem__ x (y:ys) = x==y || elem__ x ys
243 notElem__ x [] = True
244 notElem__ x (y:ys) = x /= y && notElem__ x ys
252 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
253 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
256 = notElem ILIT(0) x ys
258 notElem i x [] = True
260 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
261 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
267 %************************************************************************
269 \subsection[Utils-assoc]{Association lists}
271 %************************************************************************
273 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
276 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
277 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
278 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
279 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
281 assocDefaultUsing eq deflt ((k,v) : rest) key
283 | otherwise = assocDefaultUsing eq deflt rest key
285 assocDefaultUsing eq deflt [] key = deflt
287 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
288 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
289 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
292 %************************************************************************
294 \subsection[Utils-dups]{Duplicate-handling}
296 %************************************************************************
299 hasNoDups :: (Eq a) => [a] -> Bool
301 hasNoDups xs = f [] xs
303 f seen_so_far [] = True
304 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
309 is_elem = isIn "hasNoDups"
313 equivClasses :: (a -> a -> Ordering) -- Comparison
317 equivClasses cmp stuff@[] = []
318 equivClasses cmp stuff@[item] = [stuff]
319 equivClasses cmp items
320 = runs eq (sortLt lt items)
322 eq a b = case cmp a b of { EQ -> True; _ -> False }
323 lt a b = case cmp a b of { LT -> True; _ -> False }
326 The first cases in @equivClasses@ above are just to cut to the point
329 @runs@ groups a list into a list of lists, each sublist being a run of
330 identical elements of the input list. It is passed a predicate @p@ which
331 tells when two elements are equal.
334 runs :: (a -> a -> Bool) -- Equality
339 runs p (x:xs) = case (span (p x) xs) of
340 (first, rest) -> (x:first) : (runs p rest)
344 removeDups :: (a -> a -> Ordering) -- Comparison function
346 -> ([a], -- List with no duplicates
347 [[a]]) -- List of duplicate groups. One representative from
348 -- each group appears in the first result
350 removeDups cmp [] = ([], [])
351 removeDups cmp [x] = ([x],[])
353 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
356 collect_dups dups_so_far [x] = (dups_so_far, x)
357 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
361 %************************************************************************
363 \subsection[Utils-sorting]{Sorting}
365 %************************************************************************
367 %************************************************************************
369 \subsubsection[Utils-quicksorting]{Quicksorts}
371 %************************************************************************
374 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
375 quicksort :: (a -> a -> Bool) -- Less-than predicate
377 -> [a] -- Result list in increasing order
380 quicksort lt [x] = [x]
381 quicksort lt (x:xs) = split x [] [] xs
383 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
384 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
385 | True = split x lo (y:hi) ys
388 Quicksort variant from Lennart's Haskell-library contribution. This
389 is a {\em stable} sort.
392 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
394 sortLt :: (a -> a -> Bool) -- Less-than predicate
396 -> [a] -- Result list
398 sortLt lt l = qsort lt l []
400 -- qsort is stable and does not concatenate.
401 qsort :: (a -> a -> Bool) -- Less-than predicate
402 -> [a] -- xs, Input list
403 -> [a] -- r, Concatenate this list to the sorted input list
404 -> [a] -- Result = sort xs ++ r
408 qsort lt (x:xs) r = qpart lt x xs [] [] r
410 -- qpart partitions and sorts the sublists
411 -- rlt contains things less than x,
412 -- rge contains the ones greater than or equal to x.
413 -- Both have equal elements reversed with respect to the original list.
415 qpart lt x [] rlt rge r =
416 -- rlt and rge are in reverse order and must be sorted with an
417 -- anti-stable sorting
418 rqsort lt rlt (x : rqsort lt rge r)
420 qpart lt x (y:ys) rlt rge r =
423 qpart lt x ys (y:rlt) rge r
426 qpart lt x ys rlt (y:rge) r
428 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
430 rqsort lt [x] r = x:r
431 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
433 rqpart lt x [] rle rgt r =
434 qsort lt rle (x : qsort lt rgt r)
436 rqpart lt x (y:ys) rle rgt r =
439 rqpart lt x ys rle (y:rgt) r
442 rqpart lt x ys (y:rle) rgt r
445 %************************************************************************
447 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
449 %************************************************************************
452 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
454 mergesort cmp xs = merge_lists (split_into_runs [] xs)
456 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
457 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
459 split_into_runs [] [] = []
460 split_into_runs run [] = [run]
461 split_into_runs [] (x:xs) = split_into_runs [x] xs
462 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
463 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
464 | True = rl : (split_into_runs [x] xs)
467 merge_lists (x:xs) = merge x (merge_lists xs)
471 merge xl@(x:xs) yl@(y:ys)
473 EQ -> x : y : (merge xs ys)
474 LT -> x : (merge xs yl)
475 GT -> y : (merge xl ys)
478 %************************************************************************
480 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
482 %************************************************************************
485 Date: Mon, 3 May 93 20:45:23 +0200
486 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
487 To: partain@dcs.gla.ac.uk
488 Subject: natural merge sort beats quick sort [ and it is prettier ]
490 Here is a piece of Haskell code that I'm rather fond of. See it as an
491 attempt to get rid of the ridiculous quick-sort routine. group is
492 quite useful by itself I think it was John's idea originally though I
493 believe the lazy version is due to me [surprisingly complicated].
494 gamma [used to be called] is called gamma because I got inspired by
495 the Gamma calculus. It is not very close to the calculus but does
496 behave less sequentially than both foldr and foldl. One could imagine
497 a version of gamma that took a unit element as well thereby avoiding
498 the problem with empty lists.
500 I've tried this code against
502 1) insertion sort - as provided by haskell
503 2) the normal implementation of quick sort
504 3) a deforested version of quick sort due to Jan Sparud
505 4) a super-optimized-quick-sort of Lennart's
507 If the list is partially sorted both merge sort and in particular
508 natural merge sort wins. If the list is random [ average length of
509 rising subsequences = approx 2 ] mergesort still wins and natural
510 merge sort is marginally beaten by Lennart's soqs. The space
511 consumption of merge sort is a bit worse than Lennart's quick sort
512 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
513 fpca article ] isn't used because of group.
520 group :: (a -> a -> Bool) -> [a] -> [[a]]
523 Date: Mon, 12 Feb 1996 15:09:41 +0000
524 From: Andy Gill <andy@dcs.gla.ac.uk>
526 Here is a `better' definition of group.
529 group p (x:xs) = group' xs x x (x :)
531 group' [] _ _ s = [s []]
532 group' (x:xs) x_min x_max s
533 | not (x `p` x_max) = group' xs x_min x (s . (x :))
534 | x `p` x_min = group' xs x x_max ((x :) . s)
535 | otherwise = s [] : group' xs x x (x :)
537 -- This one works forwards *and* backwards, as well as also being
538 -- faster that the one in Util.lhs.
543 let ((h1:t1):tt1) = group p xs
544 (t,tt) = if null xs then ([],[]) else
545 if x `p` h1 then (h1:t1,tt1) else
550 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
551 generalMerge p xs [] = xs
552 generalMerge p [] ys = ys
553 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
554 | otherwise = y : generalMerge p (x:xs) ys
556 -- gamma is now called balancedFold
558 balancedFold :: (a -> a -> a) -> [a] -> a
559 balancedFold f [] = error "can't reduce an empty list using balancedFold"
560 balancedFold f [x] = x
561 balancedFold f l = balancedFold f (balancedFold' f l)
563 balancedFold' :: (a -> a -> a) -> [a] -> [a]
564 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
565 balancedFold' f xs = xs
567 generalMergeSort p [] = []
568 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
570 generalNaturalMergeSort p [] = []
571 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
573 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
575 mergeSort = generalMergeSort (<=)
576 naturalMergeSort = generalNaturalMergeSort (<=)
578 mergeSortLe le = generalMergeSort le
579 naturalMergeSortLe le = generalNaturalMergeSort le
582 %************************************************************************
584 \subsection[Utils-transitive-closure]{Transitive closure}
586 %************************************************************************
588 This algorithm for transitive closure is straightforward, albeit quadratic.
591 transitiveClosure :: (a -> [a]) -- Successor function
592 -> (a -> a -> Bool) -- Equality predicate
594 -> [a] -- The transitive closure
596 transitiveClosure succ eq xs
600 go done (x:xs) | x `is_in` done = go done xs
601 | otherwise = go (x:done) (succ x ++ xs)
604 x `is_in` (y:ys) | eq x y = True
605 | otherwise = x `is_in` ys
608 %************************************************************************
610 \subsection[Utils-accum]{Accumulating}
612 %************************************************************************
614 @mapAccumL@ behaves like a combination
615 of @map@ and @foldl@;
616 it applies a function to each element of a list, passing an accumulating
617 parameter from left to right, and returning a final value of this
618 accumulator together with the new list.
621 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
622 -- and accumulator, returning new
623 -- accumulator and elt of result list
624 -> acc -- Initial accumulator
626 -> (acc, [y]) -- Final accumulator and result list
628 mapAccumL f b [] = (b, [])
629 mapAccumL f b (x:xs) = (b'', x':xs') where
631 (b'', xs') = mapAccumL f b' xs
634 @mapAccumR@ does the same, but working from right to left instead. Its type is
635 the same as @mapAccumL@, though.
638 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
639 -- and accumulator, returning new
640 -- accumulator and elt of result list
641 -> acc -- Initial accumulator
643 -> (acc, [y]) -- Final accumulator and result list
645 mapAccumR f b [] = (b, [])
646 mapAccumR f b (x:xs) = (b'', x':xs') where
648 (b', xs') = mapAccumR f b xs
651 Here is the bi-directional version, that works from both left and right.
654 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
655 -- Function of elt of input list
656 -- and accumulator, returning new
657 -- accumulator and elt of result list
658 -> accl -- Initial accumulator from left
659 -> accr -- Initial accumulator from right
661 -> (accl, accr, [y]) -- Final accumulators and result list
663 mapAccumB f a b [] = (a,b,[])
664 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
666 (a',b'',y) = f a b' x
667 (a'',b',ys) = mapAccumB f a' b xs
670 %************************************************************************
672 \subsection[Utils-comparison]{Comparisons}
674 %************************************************************************
677 thenCmp :: Ordering -> Ordering -> Ordering
678 {-# INLINE thenCmp #-}
680 thenCmp other any = other
682 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
683 -- `cmpList' uses a user-specified comparer
685 cmpList cmp [] [] = EQ
686 cmpList cmp [] _ = LT
687 cmpList cmp _ [] = GT
688 cmpList cmp (a:as) (b:bs)
689 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
693 cmpString :: String -> String -> Ordering
696 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
697 else if x < y then LT
702 cmpString _ _ = panic "cmpString"
707 %************************************************************************
709 \subsection[Utils-pairs]{Pairs}
711 %************************************************************************
713 The following are curried versions of @fst@ and @snd@.
716 cfst :: a -> b -> a -- stranal-sem only (Note)
720 The following provide us higher order functions that, when applied
721 to a function, operate on pairs.
724 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
725 applyToPair (f,g) (x,y) = (f x, g y)
727 applyToFst :: (a -> c) -> (a,b)-> (c,b)
728 applyToFst f (x,y) = (f x,y)
730 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
731 applyToSnd f (x,y) = (x,f y)
733 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
734 foldPair fg ab [] = ab
735 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
736 where (u,v) = foldPair fg ab abs
740 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
741 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
745 %************************************************************************
747 \subsection[Utils-errors]{Error handling}
749 %************************************************************************
752 panic x = error ("panic! (the `impossible' happened):\n\t"
754 ++ "Please report it as a compiler bug "
755 ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
757 -- #-versions because panic can't return an unboxed int, and that's
758 -- what TAG_ is with GHC at the moment. Ugh. (Simon)
759 -- No, man -- Too Beautiful! (Will)
761 panic# :: String -> FAST_INT
762 panic# s = case (panic s) of () -> ILIT(0)
764 assertPanic :: String -> Int -> a
765 assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)