2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow 1992-2002
5 \section[Util]{Highly random utility functions}
10 -- general list processing
11 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
12 zipLazy, stretchZipWith,
14 mapAndUnzip, mapAndUnzip3,
15 nOfThem, filterOut, partitionWith, splitEithers,
18 lengthExceeds, lengthIs, lengthAtLeast,
19 listLengthCmp, atLength, equalLength, compareLength,
21 isSingleton, only, singleton,
32 -- transitive closures
38 takeList, dropList, splitAtList, split,
42 thenCmp, cmpList, maybePrefixMatch,
58 -- Floating point stuff
62 createDirectoryHierarchy,
64 modificationTimeIfExists,
66 later, handleDyn, handle,
75 -- XXX This define is a bit of a hack, and should be done more nicely
76 #define FAST_STRING_NOT_NEEDED 1
77 #include "HsVersions.h"
81 import Control.Exception ( Exception(..), finally, catchDyn, throw )
82 import qualified Control.Exception as Exception
83 import Data.Dynamic ( Typeable )
84 import Data.IORef ( IORef, newIORef )
85 import System.IO.Unsafe ( unsafePerformIO )
86 import Data.IORef ( readIORef, writeIORef )
87 import Data.List hiding (group)
89 import qualified Data.List as List ( elem )
91 import qualified Data.List as List ( notElem )
95 import Control.Monad ( unless )
96 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
97 import System.Directory ( doesDirectoryExist, createDirectory,
99 import System.FilePath hiding ( searchPathSeparator )
100 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
101 import Data.Ratio ( (%) )
102 import System.Time ( ClockTime )
107 %************************************************************************
109 \subsection{A for loop}
111 %************************************************************************
114 -- Compose a function with itself n times. (nth rather than twice)
115 nTimes :: Int -> (a -> a) -> (a -> a)
118 nTimes n f = f . nTimes (n-1) f
121 %************************************************************************
123 \subsection[Utils-lists]{General list processing}
125 %************************************************************************
128 filterOut :: (a->Bool) -> [a] -> [a]
129 -- Like filter, only reverses the sense of the test
131 filterOut p (x:xs) | p x = filterOut p xs
132 | otherwise = x : filterOut p xs
134 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
135 partitionWith _ [] = ([],[])
136 partitionWith f (x:xs) = case f x of
138 Right c -> (bs, c:cs)
139 where (bs,cs) = partitionWith f xs
141 splitEithers :: [Either a b] -> ([a], [b])
142 splitEithers [] = ([],[])
143 splitEithers (e : es) = case e of
145 Right y -> (xs, y:ys)
146 where (xs,ys) = splitEithers es
149 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
150 are of equal length. Alastair Reid thinks this should only happen if
151 DEBUGging on; hey, why not?
154 zipEqual :: String -> [a] -> [b] -> [(a,b)]
155 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
156 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
157 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
161 zipWithEqual _ = zipWith
162 zipWith3Equal _ = zipWith3
163 zipWith4Equal _ = zipWith4
165 zipEqual msg [] [] = []
166 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
167 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
169 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
170 zipWithEqual msg _ [] [] = []
171 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
173 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
174 = z a b c : zipWith3Equal msg z as bs cs
175 zipWith3Equal msg _ [] [] [] = []
176 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
178 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
179 = z a b c d : zipWith4Equal msg z as bs cs ds
180 zipWith4Equal msg _ [] [] [] [] = []
181 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
186 -- zipLazy is lazy in the second list (observe the ~)
188 zipLazy :: [a] -> [b] -> [(a,b)]
190 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
195 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
196 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
197 -- the places where p returns *True*
199 stretchZipWith _ _ _ [] _ = []
200 stretchZipWith p z f (x:xs) ys
201 | p x = f x z : stretchZipWith p z f xs ys
202 | otherwise = case ys of
204 (y:ys) -> f x y : stretchZipWith p z f xs ys
209 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
210 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
212 mapFst f xys = [(f x, y) | (x,y) <- xys]
213 mapSnd f xys = [(x, f y) | (x,y) <- xys]
215 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
217 mapAndUnzip _ [] = ([], [])
220 (rs1, rs2) = mapAndUnzip f xs
224 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
226 mapAndUnzip3 _ [] = ([], [], [])
227 mapAndUnzip3 f (x:xs)
228 = let (r1, r2, r3) = f x
229 (rs1, rs2, rs3) = mapAndUnzip3 f xs
231 (r1:rs1, r2:rs2, r3:rs3)
235 nOfThem :: Int -> a -> [a]
236 nOfThem n thing = replicate n thing
238 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
241 -- atLength atLenPred atEndPred ls n
242 -- | n < 0 = atLenPred n
243 -- | length ls < n = atEndPred (n - length ls)
244 -- | otherwise = atLenPred (drop n ls)
246 atLength :: ([a] -> b)
251 atLength atLenPred atEndPred ls n
252 | n < 0 = atEndPred n
253 | otherwise = go n ls
255 go n [] = atEndPred n
256 go 0 ls = atLenPred ls
257 go n (_:xs) = go (n-1) xs
260 lengthExceeds :: [a] -> Int -> Bool
261 -- (lengthExceeds xs n) = (length xs > n)
262 lengthExceeds = atLength notNull (const False)
264 lengthAtLeast :: [a] -> Int -> Bool
265 lengthAtLeast = atLength notNull (== 0)
267 lengthIs :: [a] -> Int -> Bool
268 lengthIs = atLength null (==0)
270 listLengthCmp :: [a] -> Int -> Ordering
271 listLengthCmp = atLength atLen atEnd
275 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
281 equalLength :: [a] -> [b] -> Bool
282 equalLength [] [] = True
283 equalLength (_:xs) (_:ys) = equalLength xs ys
284 equalLength _ _ = False
286 compareLength :: [a] -> [b] -> Ordering
287 compareLength [] [] = EQ
288 compareLength (_:xs) (_:ys) = compareLength xs ys
289 compareLength [] _ = LT
290 compareLength _ [] = GT
292 ----------------------------
293 singleton :: a -> [a]
296 isSingleton :: [a] -> Bool
297 isSingleton [_] = True
298 isSingleton _ = False
300 notNull :: [a] -> Bool
310 only _ = panic "Util: only"
313 Debugging/specialising versions of \tr{elem} and \tr{notElem}
316 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
319 isIn _msg x ys = elem__ x ys
320 isn'tIn _msg x ys = notElem__ x ys
322 --these are here to be SPECIALIZEd (automagically)
323 elem__ :: Eq a => a -> [a] -> Bool
325 elem__ x (y:ys) = x == y || elem__ x ys
327 notElem__ :: Eq a => a -> [a] -> Bool
328 notElem__ _ [] = True
329 notElem__ x (y:ys) = x /= y && notElem__ x ys
333 = elem (_ILIT 0) x ys
337 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg)
338 (x `List.elem` (y:ys))
339 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
342 = notElem (_ILIT 0) x ys
344 notElem i x [] = True
346 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg)
347 (x `List.notElem` (y:ys))
348 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
352 foldl1' was added in GHC 6.4
355 #if __GLASGOW_HASKELL__ < 604
356 foldl1' :: (a -> a -> a) -> [a] -> a
357 foldl1' f (x:xs) = foldl' f x xs
358 foldl1' _ [] = panic "foldl1'"
362 %************************************************************************
364 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
366 %************************************************************************
369 Date: Mon, 3 May 93 20:45:23 +0200
370 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
371 To: partain@dcs.gla.ac.uk
372 Subject: natural merge sort beats quick sort [ and it is prettier ]
374 Here is a piece of Haskell code that I'm rather fond of. See it as an
375 attempt to get rid of the ridiculous quick-sort routine. group is
376 quite useful by itself I think it was John's idea originally though I
377 believe the lazy version is due to me [surprisingly complicated].
378 gamma [used to be called] is called gamma because I got inspired by
379 the Gamma calculus. It is not very close to the calculus but does
380 behave less sequentially than both foldr and foldl. One could imagine
381 a version of gamma that took a unit element as well thereby avoiding
382 the problem with empty lists.
384 I've tried this code against
386 1) insertion sort - as provided by haskell
387 2) the normal implementation of quick sort
388 3) a deforested version of quick sort due to Jan Sparud
389 4) a super-optimized-quick-sort of Lennart's
391 If the list is partially sorted both merge sort and in particular
392 natural merge sort wins. If the list is random [ average length of
393 rising subsequences = approx 2 ] mergesort still wins and natural
394 merge sort is marginally beaten by Lennart's soqs. The space
395 consumption of merge sort is a bit worse than Lennart's quick sort
396 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
397 fpca article ] isn't used because of group.
404 group :: (a -> a -> Bool) -> [a] -> [[a]]
405 -- Given a <= function, group finds maximal contiguous up-runs
406 -- or down-runs in the input list.
407 -- It's stable, in the sense that it never re-orders equal elements
409 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
410 -- From: Andy Gill <andy@dcs.gla.ac.uk>
411 -- Here is a `better' definition of group.
414 group p (x:xs) = group' xs x x (x :)
416 group' [] _ _ s = [s []]
417 group' (x:xs) x_min x_max s
418 | x_max `p` x = group' xs x_min x (s . (x :))
419 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
420 | otherwise = s [] : group' xs x x (x :)
421 -- NB: the 'not' is essential for stablity
422 -- x `p` x_min would reverse equal elements
424 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
425 generalMerge _ xs [] = xs
426 generalMerge _ [] ys = ys
427 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
428 | otherwise = y : generalMerge p (x:xs) ys
430 -- gamma is now called balancedFold
432 balancedFold :: (a -> a -> a) -> [a] -> a
433 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
434 balancedFold _ [x] = x
435 balancedFold f l = balancedFold f (balancedFold' f l)
437 balancedFold' :: (a -> a -> a) -> [a] -> [a]
438 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
439 balancedFold' _ xs = xs
441 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
442 generalNaturalMergeSort _ [] = []
443 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
446 generalMergeSort p [] = []
447 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
449 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
451 mergeSort = generalMergeSort (<=)
452 naturalMergeSort = generalNaturalMergeSort (<=)
454 mergeSortLe le = generalMergeSort le
457 sortLe :: (a->a->Bool) -> [a] -> [a]
458 sortLe le = generalNaturalMergeSort le
460 sortWith :: Ord b => (a->b) -> [a] -> [a]
461 sortWith get_key xs = sortLe le xs
463 x `le` y = get_key x < get_key y
465 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
466 on cmp sel = \x y -> sel x `cmp` sel y
470 %************************************************************************
472 \subsection[Utils-transitive-closure]{Transitive closure}
474 %************************************************************************
476 This algorithm for transitive closure is straightforward, albeit quadratic.
479 transitiveClosure :: (a -> [a]) -- Successor function
480 -> (a -> a -> Bool) -- Equality predicate
482 -> [a] -- The transitive closure
484 transitiveClosure succ eq xs
488 go done (x:xs) | x `is_in` done = go done xs
489 | otherwise = go (x:done) (succ x ++ xs)
492 x `is_in` (y:ys) | eq x y = True
493 | otherwise = x `is_in` ys
496 %************************************************************************
498 \subsection[Utils-accum]{Accumulating}
500 %************************************************************************
502 A combination of foldl with zip. It works with equal length lists.
505 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
507 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
508 foldl2 _ _ _ _ = panic "Util: foldl2"
510 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
511 -- True if the lists are the same length, and
512 -- all corresponding elements satisfy the predicate
514 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
518 Count the number of times a predicate is true
521 count :: (a -> Bool) -> [a] -> Int
523 count p (x:xs) | p x = 1 + count p xs
524 | otherwise = count p xs
527 @splitAt@, @take@, and @drop@ but with length of another
528 list giving the break-off point:
531 takeList :: [b] -> [a] -> [a]
536 (y:ys) -> y : takeList xs ys
538 dropList :: [b] -> [a] -> [a]
540 dropList _ xs@[] = xs
541 dropList (_:xs) (_:ys) = dropList xs ys
544 splitAtList :: [b] -> [a] -> ([a], [a])
545 splitAtList [] xs = ([], xs)
546 splitAtList _ xs@[] = (xs, xs)
547 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
549 (ys', ys'') = splitAtList xs ys
551 snocView :: [a] -> Maybe ([a],a)
552 -- Split off the last element
553 snocView [] = Nothing
554 snocView xs = go [] xs
556 -- Invariant: second arg is non-empty
557 go acc [x] = Just (reverse acc, x)
558 go acc (x:xs) = go (x:acc) xs
559 go _ [] = panic "Util: snocView"
561 split :: Char -> String -> [String]
562 split c s = case rest of
564 _:rest -> chunk : split c rest
565 where (chunk, rest) = break (==c) s
569 %************************************************************************
571 \subsection[Utils-comparison]{Comparisons}
573 %************************************************************************
576 isEqual :: Ordering -> Bool
577 -- Often used in (isEqual (a `compare` b))
582 thenCmp :: Ordering -> Ordering -> Ordering
583 {-# INLINE thenCmp #-}
584 thenCmp EQ ordering = ordering
585 thenCmp ordering _ = ordering
587 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
588 eqListBy _ [] [] = True
589 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
590 eqListBy _ _ _ = False
592 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
593 -- `cmpList' uses a user-specified comparer
598 cmpList cmp (a:as) (b:bs)
599 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
603 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
604 -- This definition can be removed once we require at least 6.8 to build.
605 maybePrefixMatch :: String -> String -> Maybe String
606 maybePrefixMatch [] rest = Just rest
607 maybePrefixMatch (_:_) [] = Nothing
608 maybePrefixMatch (p:pat) (r:rest)
609 | p == r = maybePrefixMatch pat rest
610 | otherwise = Nothing
612 removeSpaces :: String -> String
613 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
616 %************************************************************************
618 \subsection[Utils-pairs]{Pairs}
620 %************************************************************************
623 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
624 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
628 seqList :: [a] -> b -> b
630 seqList (x:xs) b = x `seq` seqList xs b
636 global :: a -> IORef a
637 global a = unsafePerformIO (newIORef a)
641 consIORef :: IORef [a] -> a -> IO ()
644 writeIORef var (x:xs)
650 looksLikeModuleName :: String -> Bool
651 looksLikeModuleName [] = False
652 looksLikeModuleName (c:cs) = isUpper c && go cs
654 go ('.':cs) = looksLikeModuleName cs
655 go (c:cs) = (isAlphaNum c || c == '_') && go cs
658 Akin to @Prelude.words@, but acts like the Bourne shell, treating
659 quoted strings and escaped characters within the input as solid blocks
660 of characters. Doesn't raise any exceptions on malformed escapes or
664 toArgs :: String -> [String]
667 case dropWhile isSpace s of -- drop initial spacing
668 [] -> [] -- empty, so no more tokens
669 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
671 -- Grab a token off the string, given that the first character exists and
672 -- isn't whitespace. The second argument is an accumulator which has to be
673 -- reversed at the end.
674 token [] acc = (reverse acc,[]) -- out of characters
675 token ('\\':c:aft) acc -- escapes
676 = token aft ((escape c) : acc)
677 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
678 = let (aft',acc') = quote q aft acc in token aft' acc'
679 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
681 token (c:aft) acc -- anything else goes in the token
684 -- Get the appropriate character for a single-character escape.
690 -- Read into accumulator until a quote character is found.
692 let quote' [] acc = ([],acc)
693 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
694 quote' (c:aft) acc | c == qc = (aft,acc)
695 quote' (c:aft) acc = quote' aft (c:acc)
699 -- -----------------------------------------------------------------------------
703 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
704 readRational__ r = do
707 return ((n%1)*10^^(k-d), t)
710 (ds,s) <- lexDecDigits r
711 (ds',t) <- lexDotDigits s
712 return (read (ds++ds'), length ds', t)
714 readExp (e:s) | e `elem` "eE" = readExp' s
715 readExp s = return (0,s)
717 readExp' ('+':s) = readDec s
718 readExp' ('-':s) = do (k,t) <- readDec s
720 readExp' s = readDec s
723 (ds,r) <- nonnull isDigit s
724 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
727 lexDecDigits = nonnull isDigit
729 lexDotDigits ('.':s) = return (span isDigit s)
730 lexDotDigits s = return ("",s)
732 nonnull p s = do (cs@(_:_),t) <- return (span p s)
735 readRational :: String -> Rational -- NB: *does* handle a leading "-"
738 '-' : xs -> - (read_me xs)
742 = case (do { (x,"") <- readRational__ s ; return x }) of
744 [] -> error ("readRational: no parse:" ++ top_s)
745 _ -> error ("readRational: ambiguous parse:" ++ top_s)
748 -----------------------------------------------------------------------------
749 -- Create a hierarchy of directories
751 createDirectoryHierarchy :: FilePath -> IO ()
752 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
753 createDirectoryHierarchy dir = do
754 b <- doesDirectoryExist dir
755 unless b $ do createDirectoryHierarchy (takeDirectory dir)
758 -----------------------------------------------------------------------------
759 -- Verify that the 'dirname' portion of a FilePath exists.
761 doesDirNameExist :: FilePath -> IO Bool
762 doesDirNameExist fpath = case takeDirectory fpath of
763 "" -> return True -- XXX Hack
764 _ -> doesDirectoryExist (takeDirectory fpath)
766 -- -----------------------------------------------------------------------------
769 later :: IO b -> IO a -> IO a
772 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
773 handleDyn = flip catchDyn
775 handle :: (Exception -> IO a) -> IO a -> IO a
776 handle h f = f `Exception.catch` \e -> case e of
777 ExitException _ -> throw e
780 -- --------------------------------------------------------------
781 -- check existence & modification time at the same time
783 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
784 modificationTimeIfExists f = do
785 (do t <- getModificationTime f; return (Just t))
786 `IO.catch` \e -> if isDoesNotExistError e
790 -- split a string at the last character where 'pred' is True,
791 -- returning a pair of strings. The first component holds the string
792 -- up (but not including) the last character for which 'pred' returned
793 -- True, the second whatever comes after (but also not including the
796 -- If 'pred' returns False for all characters in the string, the original
797 -- string is returned in the first component (and the second one is just
799 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
800 splitLongestPrefix str pred
801 | null r_pre = (str, [])
802 | otherwise = (reverse (tail r_pre), reverse r_suf)
803 -- 'tail' drops the char satisfying 'pred'
804 where (r_suf, r_pre) = break pred (reverse str)
806 escapeSpaces :: String -> String
807 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
811 --------------------------------------------------------------
813 --------------------------------------------------------------
815 -- | The function splits the given string to substrings
816 -- using the 'searchPathSeparator'.
817 parseSearchPath :: String -> [FilePath]
818 parseSearchPath path = split path
820 split :: String -> [String]
824 _:rest -> chunk : split rest
828 #ifdef mingw32_HOST_OS
829 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
833 (chunk', rest') = break (==searchPathSeparator) s
835 -- | A platform-specific character used to separate search path strings in
836 -- environment variables. The separator is a colon (\":\") on Unix and
837 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
838 searchPathSeparator :: Char
839 #if mingw32_HOST_OS || mingw32_TARGET_OS
840 searchPathSeparator = ';'
842 searchPathSeparator = ':'