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 )
94 import Control.Monad ( unless )
95 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
96 import System.Directory ( doesDirectoryExist, createDirectory,
98 import System.FilePath hiding ( searchPathSeparator )
99 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
100 import Data.Ratio ( (%) )
101 import System.Time ( ClockTime )
106 %************************************************************************
108 \subsection{A for loop}
110 %************************************************************************
113 -- Compose a function with itself n times. (nth rather than twice)
114 nTimes :: Int -> (a -> a) -> (a -> a)
117 nTimes n f = f . nTimes (n-1) f
120 %************************************************************************
122 \subsection[Utils-lists]{General list processing}
124 %************************************************************************
127 filterOut :: (a->Bool) -> [a] -> [a]
128 -- Like filter, only reverses the sense of the test
130 filterOut p (x:xs) | p x = filterOut p xs
131 | otherwise = x : filterOut p xs
133 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
134 partitionWith _ [] = ([],[])
135 partitionWith f (x:xs) = case f x of
137 Right c -> (bs, c:cs)
138 where (bs,cs) = partitionWith f xs
140 splitEithers :: [Either a b] -> ([a], [b])
141 splitEithers [] = ([],[])
142 splitEithers (e : es) = case e of
144 Right y -> (xs, y:ys)
145 where (xs,ys) = splitEithers es
148 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
149 are of equal length. Alastair Reid thinks this should only happen if
150 DEBUGging on; hey, why not?
153 zipEqual :: String -> [a] -> [b] -> [(a,b)]
154 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
155 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
156 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
160 zipWithEqual _ = zipWith
161 zipWith3Equal _ = zipWith3
162 zipWith4Equal _ = zipWith4
164 zipEqual msg [] [] = []
165 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
166 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
168 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
169 zipWithEqual msg _ [] [] = []
170 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
172 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
173 = z a b c : zipWith3Equal msg z as bs cs
174 zipWith3Equal msg _ [] [] [] = []
175 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
177 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
178 = z a b c d : zipWith4Equal msg z as bs cs ds
179 zipWith4Equal msg _ [] [] [] [] = []
180 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
185 -- zipLazy is lazy in the second list (observe the ~)
187 zipLazy :: [a] -> [b] -> [(a,b)]
189 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
194 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
195 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
196 -- the places where p returns *True*
198 stretchZipWith _ _ _ [] _ = []
199 stretchZipWith p z f (x:xs) ys
200 | p x = f x z : stretchZipWith p z f xs ys
201 | otherwise = case ys of
203 (y:ys) -> f x y : stretchZipWith p z f xs ys
208 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
209 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
211 mapFst f xys = [(f x, y) | (x,y) <- xys]
212 mapSnd f xys = [(x, f y) | (x,y) <- xys]
214 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
216 mapAndUnzip _ [] = ([], [])
219 (rs1, rs2) = mapAndUnzip f xs
223 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
225 mapAndUnzip3 _ [] = ([], [], [])
226 mapAndUnzip3 f (x:xs)
227 = let (r1, r2, r3) = f x
228 (rs1, rs2, rs3) = mapAndUnzip3 f xs
230 (r1:rs1, r2:rs2, r3:rs3)
234 nOfThem :: Int -> a -> [a]
235 nOfThem n thing = replicate n thing
237 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
240 -- atLength atLenPred atEndPred ls n
241 -- | n < 0 = atLenPred n
242 -- | length ls < n = atEndPred (n - length ls)
243 -- | otherwise = atLenPred (drop n ls)
245 atLength :: ([a] -> b)
250 atLength atLenPred atEndPred ls n
251 | n < 0 = atEndPred n
252 | otherwise = go n ls
254 go n [] = atEndPred n
255 go 0 ls = atLenPred ls
256 go n (_:xs) = go (n-1) xs
259 lengthExceeds :: [a] -> Int -> Bool
260 -- (lengthExceeds xs n) = (length xs > n)
261 lengthExceeds = atLength notNull (const False)
263 lengthAtLeast :: [a] -> Int -> Bool
264 lengthAtLeast = atLength notNull (== 0)
266 lengthIs :: [a] -> Int -> Bool
267 lengthIs = atLength null (==0)
269 listLengthCmp :: [a] -> Int -> Ordering
270 listLengthCmp = atLength atLen atEnd
274 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
280 equalLength :: [a] -> [b] -> Bool
281 equalLength [] [] = True
282 equalLength (_:xs) (_:ys) = equalLength xs ys
283 equalLength _ _ = False
285 compareLength :: [a] -> [b] -> Ordering
286 compareLength [] [] = EQ
287 compareLength (_:xs) (_:ys) = compareLength xs ys
288 compareLength [] _ = LT
289 compareLength _ [] = GT
291 ----------------------------
292 singleton :: a -> [a]
295 isSingleton :: [a] -> Bool
296 isSingleton [_] = True
297 isSingleton _ = False
299 notNull :: [a] -> Bool
309 only _ = panic "Util: only"
312 Debugging/specialising versions of \tr{elem} and \tr{notElem}
315 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
318 isIn _msg x ys = elem__ x ys
319 isn'tIn _msg x ys = notElem__ x ys
321 --these are here to be SPECIALIZEd (automagically)
322 elem__ :: Eq a => a -> [a] -> Bool
324 elem__ x (y:ys) = x == y || elem__ x ys
326 notElem__ :: Eq a => a -> [a] -> Bool
327 notElem__ _ [] = True
328 notElem__ x (y:ys) = x /= y && notElem__ x ys
332 = elem (_ILIT 0) x ys
336 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg)
337 (x `List.elem` (y:ys))
338 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
341 = notElem (_ILIT 0) x ys
343 notElem i x [] = True
345 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg)
346 (x `List.notElem` (y:ys))
347 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
351 foldl1' was added in GHC 6.4
354 #if __GLASGOW_HASKELL__ < 604
355 foldl1' :: (a -> a -> a) -> [a] -> a
356 foldl1' f (x:xs) = foldl' f x xs
357 foldl1' _ [] = panic "foldl1'"
361 %************************************************************************
363 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
365 %************************************************************************
368 Date: Mon, 3 May 93 20:45:23 +0200
369 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
370 To: partain@dcs.gla.ac.uk
371 Subject: natural merge sort beats quick sort [ and it is prettier ]
373 Here is a piece of Haskell code that I'm rather fond of. See it as an
374 attempt to get rid of the ridiculous quick-sort routine. group is
375 quite useful by itself I think it was John's idea originally though I
376 believe the lazy version is due to me [surprisingly complicated].
377 gamma [used to be called] is called gamma because I got inspired by
378 the Gamma calculus. It is not very close to the calculus but does
379 behave less sequentially than both foldr and foldl. One could imagine
380 a version of gamma that took a unit element as well thereby avoiding
381 the problem with empty lists.
383 I've tried this code against
385 1) insertion sort - as provided by haskell
386 2) the normal implementation of quick sort
387 3) a deforested version of quick sort due to Jan Sparud
388 4) a super-optimized-quick-sort of Lennart's
390 If the list is partially sorted both merge sort and in particular
391 natural merge sort wins. If the list is random [ average length of
392 rising subsequences = approx 2 ] mergesort still wins and natural
393 merge sort is marginally beaten by Lennart's soqs. The space
394 consumption of merge sort is a bit worse than Lennart's quick sort
395 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
396 fpca article ] isn't used because of group.
403 group :: (a -> a -> Bool) -> [a] -> [[a]]
404 -- Given a <= function, group finds maximal contiguous up-runs
405 -- or down-runs in the input list.
406 -- It's stable, in the sense that it never re-orders equal elements
408 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
409 -- From: Andy Gill <andy@dcs.gla.ac.uk>
410 -- Here is a `better' definition of group.
413 group p (x:xs) = group' xs x x (x :)
415 group' [] _ _ s = [s []]
416 group' (x:xs) x_min x_max s
417 | x_max `p` x = group' xs x_min x (s . (x :))
418 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
419 | otherwise = s [] : group' xs x x (x :)
420 -- NB: the 'not' is essential for stablity
421 -- x `p` x_min would reverse equal elements
423 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
424 generalMerge _ xs [] = xs
425 generalMerge _ [] ys = ys
426 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
427 | otherwise = y : generalMerge p (x:xs) ys
429 -- gamma is now called balancedFold
431 balancedFold :: (a -> a -> a) -> [a] -> a
432 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
433 balancedFold _ [x] = x
434 balancedFold f l = balancedFold f (balancedFold' f l)
436 balancedFold' :: (a -> a -> a) -> [a] -> [a]
437 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
438 balancedFold' _ xs = xs
440 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
441 generalNaturalMergeSort _ [] = []
442 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
445 generalMergeSort p [] = []
446 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
448 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
450 mergeSort = generalMergeSort (<=)
451 naturalMergeSort = generalNaturalMergeSort (<=)
453 mergeSortLe le = generalMergeSort le
456 sortLe :: (a->a->Bool) -> [a] -> [a]
457 sortLe le = generalNaturalMergeSort le
459 sortWith :: Ord b => (a->b) -> [a] -> [a]
460 sortWith get_key xs = sortLe le xs
462 x `le` y = get_key x < get_key y
464 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
465 on cmp sel = \x y -> sel x `cmp` sel y
469 %************************************************************************
471 \subsection[Utils-transitive-closure]{Transitive closure}
473 %************************************************************************
475 This algorithm for transitive closure is straightforward, albeit quadratic.
478 transitiveClosure :: (a -> [a]) -- Successor function
479 -> (a -> a -> Bool) -- Equality predicate
481 -> [a] -- The transitive closure
483 transitiveClosure succ eq xs
487 go done (x:xs) | x `is_in` done = go done xs
488 | otherwise = go (x:done) (succ x ++ xs)
491 x `is_in` (y:ys) | eq x y = True
492 | otherwise = x `is_in` ys
495 %************************************************************************
497 \subsection[Utils-accum]{Accumulating}
499 %************************************************************************
501 A combination of foldl with zip. It works with equal length lists.
504 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
506 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
507 foldl2 _ _ _ _ = panic "Util: foldl2"
509 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
510 -- True if the lists are the same length, and
511 -- all corresponding elements satisfy the predicate
513 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
517 Count the number of times a predicate is true
520 count :: (a -> Bool) -> [a] -> Int
522 count p (x:xs) | p x = 1 + count p xs
523 | otherwise = count p xs
526 @splitAt@, @take@, and @drop@ but with length of another
527 list giving the break-off point:
530 takeList :: [b] -> [a] -> [a]
535 (y:ys) -> y : takeList xs ys
537 dropList :: [b] -> [a] -> [a]
539 dropList _ xs@[] = xs
540 dropList (_:xs) (_:ys) = dropList xs ys
543 splitAtList :: [b] -> [a] -> ([a], [a])
544 splitAtList [] xs = ([], xs)
545 splitAtList _ xs@[] = (xs, xs)
546 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
548 (ys', ys'') = splitAtList xs ys
550 snocView :: [a] -> Maybe ([a],a)
551 -- Split off the last element
552 snocView [] = Nothing
553 snocView xs = go [] xs
555 -- Invariant: second arg is non-empty
556 go acc [x] = Just (reverse acc, x)
557 go acc (x:xs) = go (x:acc) xs
558 go _ [] = panic "Util: snocView"
560 split :: Char -> String -> [String]
561 split c s = case rest of
563 _:rest -> chunk : split c rest
564 where (chunk, rest) = break (==c) s
568 %************************************************************************
570 \subsection[Utils-comparison]{Comparisons}
572 %************************************************************************
575 isEqual :: Ordering -> Bool
576 -- Often used in (isEqual (a `compare` b))
581 thenCmp :: Ordering -> Ordering -> Ordering
582 {-# INLINE thenCmp #-}
583 thenCmp EQ ordering = ordering
584 thenCmp ordering _ = ordering
586 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
587 eqListBy _ [] [] = True
588 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
589 eqListBy _ _ _ = False
591 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
592 -- `cmpList' uses a user-specified comparer
597 cmpList cmp (a:as) (b:bs)
598 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
602 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
603 -- This definition can be removed once we require at least 6.8 to build.
604 maybePrefixMatch :: String -> String -> Maybe String
605 maybePrefixMatch [] rest = Just rest
606 maybePrefixMatch (_:_) [] = Nothing
607 maybePrefixMatch (p:pat) (r:rest)
608 | p == r = maybePrefixMatch pat rest
609 | otherwise = Nothing
611 removeSpaces :: String -> String
612 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
615 %************************************************************************
617 \subsection[Utils-pairs]{Pairs}
619 %************************************************************************
622 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
623 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
627 seqList :: [a] -> b -> b
629 seqList (x:xs) b = x `seq` seqList xs b
635 global :: a -> IORef a
636 global a = unsafePerformIO (newIORef a)
640 consIORef :: IORef [a] -> a -> IO ()
643 writeIORef var (x:xs)
649 looksLikeModuleName :: String -> Bool
650 looksLikeModuleName [] = False
651 looksLikeModuleName (c:cs) = isUpper c && go cs
653 go ('.':cs) = looksLikeModuleName cs
654 go (c:cs) = (isAlphaNum c || c == '_') && go cs
657 Akin to @Prelude.words@, but acts like the Bourne shell, treating
658 quoted strings and escaped characters within the input as solid blocks
659 of characters. Doesn't raise any exceptions on malformed escapes or
663 toArgs :: String -> [String]
666 case dropWhile isSpace s of -- drop initial spacing
667 [] -> [] -- empty, so no more tokens
668 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
670 -- Grab a token off the string, given that the first character exists and
671 -- isn't whitespace. The second argument is an accumulator which has to be
672 -- reversed at the end.
673 token [] acc = (reverse acc,[]) -- out of characters
674 token ('\\':c:aft) acc -- escapes
675 = token aft ((escape c) : acc)
676 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
677 = let (aft',acc') = quote q aft acc in token aft' acc'
678 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
680 token (c:aft) acc -- anything else goes in the token
683 -- Get the appropriate character for a single-character escape.
689 -- Read into accumulator until a quote character is found.
691 let quote' [] acc = ([],acc)
692 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
693 quote' (c:aft) acc | c == qc = (aft,acc)
694 quote' (c:aft) acc = quote' aft (c:acc)
698 -- -----------------------------------------------------------------------------
702 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
703 readRational__ r = do
706 return ((n%1)*10^^(k-d), t)
709 (ds,s) <- lexDecDigits r
710 (ds',t) <- lexDotDigits s
711 return (read (ds++ds'), length ds', t)
713 readExp (e:s) | e `elem` "eE" = readExp' s
714 readExp s = return (0,s)
716 readExp' ('+':s) = readDec s
717 readExp' ('-':s) = do (k,t) <- readDec s
719 readExp' s = readDec s
722 (ds,r) <- nonnull isDigit s
723 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
726 lexDecDigits = nonnull isDigit
728 lexDotDigits ('.':s) = return (span isDigit s)
729 lexDotDigits s = return ("",s)
731 nonnull p s = do (cs@(_:_),t) <- return (span p s)
734 readRational :: String -> Rational -- NB: *does* handle a leading "-"
737 '-' : xs -> - (read_me xs)
741 = case (do { (x,"") <- readRational__ s ; return x }) of
743 [] -> error ("readRational: no parse:" ++ top_s)
744 _ -> error ("readRational: ambiguous parse:" ++ top_s)
747 -----------------------------------------------------------------------------
748 -- Create a hierarchy of directories
750 createDirectoryHierarchy :: FilePath -> IO ()
751 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
752 createDirectoryHierarchy dir = do
753 b <- doesDirectoryExist dir
754 unless b $ do createDirectoryHierarchy (takeDirectory dir)
757 -----------------------------------------------------------------------------
758 -- Verify that the 'dirname' portion of a FilePath exists.
760 doesDirNameExist :: FilePath -> IO Bool
761 doesDirNameExist fpath = case takeDirectory fpath of
762 "" -> return True -- XXX Hack
763 _ -> doesDirectoryExist (takeDirectory fpath)
765 -- -----------------------------------------------------------------------------
768 later :: IO b -> IO a -> IO a
771 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
772 handleDyn = flip catchDyn
774 handle :: (Exception -> IO a) -> IO a -> IO a
775 handle h f = f `Exception.catch` \e -> case e of
776 ExitException _ -> throw e
779 -- --------------------------------------------------------------
780 -- check existence & modification time at the same time
782 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
783 modificationTimeIfExists f = do
784 (do t <- getModificationTime f; return (Just t))
785 `IO.catch` \e -> if isDoesNotExistError e
789 -- split a string at the last character where 'pred' is True,
790 -- returning a pair of strings. The first component holds the string
791 -- up (but not including) the last character for which 'pred' returned
792 -- True, the second whatever comes after (but also not including the
795 -- If 'pred' returns False for all characters in the string, the original
796 -- string is returned in the first component (and the second one is just
798 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
799 splitLongestPrefix str pred
800 | null r_pre = (str, [])
801 | otherwise = (reverse (tail r_pre), reverse r_suf)
802 -- 'tail' drops the char satisfying 'pred'
803 where (r_suf, r_pre) = break pred (reverse str)
805 escapeSpaces :: String -> String
806 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
810 --------------------------------------------------------------
812 --------------------------------------------------------------
814 -- | The function splits the given string to substrings
815 -- using the 'searchPathSeparator'.
816 parseSearchPath :: String -> [FilePath]
817 parseSearchPath path = split path
819 split :: String -> [String]
823 _:rest -> chunk : split rest
827 #ifdef mingw32_HOST_OS
828 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
832 (chunk', rest') = break (==searchPathSeparator) s
834 -- | A platform-specific character used to separate search path strings in
835 -- environment variables. The separator is a colon (\":\") on Unix and
836 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
837 searchPathSeparator :: Char
838 #if mingw32_HOST_OS || mingw32_TARGET_OS
839 searchPathSeparator = ';'
841 searchPathSeparator = ':'