2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow 1992-2002
5 \section[Util]{Highly random utility functions}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 -- general list processing
18 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
19 zipLazy, stretchZipWith,
21 mapAndUnzip, mapAndUnzip3,
22 nOfThem, filterOut, partitionWith, splitEithers,
25 lengthExceeds, lengthIs, lengthAtLeast,
26 listLengthCmp, atLength, equalLength, compareLength,
28 isSingleton, only, singleton,
39 -- transitive closures
45 takeList, dropList, splitAtList, split,
49 thenCmp, cmpList, maybePrefixMatch,
65 -- Floating point stuff
69 createDirectoryHierarchy,
71 modificationTimeIfExists,
73 later, handleDyn, handle,
82 #include "HsVersions.h"
86 #if defined(DEBUG) || __GLASGOW_HASKELL__ < 604
90 import Control.Exception ( Exception(..), finally, catchDyn, throw )
91 import qualified Control.Exception as Exception
92 import Data.Dynamic ( Typeable )
93 import Data.IORef ( IORef, newIORef )
94 import System.IO.Unsafe ( unsafePerformIO )
95 import Data.IORef ( readIORef, writeIORef )
96 import Data.List hiding (group)
98 import qualified Data.List as List ( elem )
100 import qualified Data.List as List ( notElem )
103 import Control.Monad ( unless )
104 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
105 import System.Directory ( doesDirectoryExist, createDirectory,
106 getModificationTime )
107 import System.FilePath hiding ( searchPathSeparator )
108 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
109 import Data.Ratio ( (%) )
110 import System.Time ( ClockTime )
115 %************************************************************************
117 \subsection{A for loop}
119 %************************************************************************
122 -- Compose a function with itself n times. (nth rather than twice)
123 nTimes :: Int -> (a -> a) -> (a -> a)
126 nTimes n f = f . nTimes (n-1) f
129 %************************************************************************
131 \subsection[Utils-lists]{General list processing}
133 %************************************************************************
136 filterOut :: (a->Bool) -> [a] -> [a]
137 -- Like filter, only reverses the sense of the test
139 filterOut p (x:xs) | p x = filterOut p xs
140 | otherwise = x : filterOut p xs
142 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
143 partitionWith f [] = ([],[])
144 partitionWith f (x:xs) = case f x of
146 Right c -> (bs, c:cs)
148 (bs,cs) = partitionWith f xs
150 splitEithers :: [Either a b] -> ([a], [b])
151 splitEithers [] = ([],[])
152 splitEithers (e : es) = case e of
154 Right y -> (xs, y:ys)
156 (xs,ys) = splitEithers es
159 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
160 are of equal length. Alastair Reid thinks this should only happen if
161 DEBUGging on; hey, why not?
164 zipEqual :: String -> [a] -> [b] -> [(a,b)]
165 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
166 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
167 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
171 zipWithEqual _ = zipWith
172 zipWith3Equal _ = zipWith3
173 zipWith4Equal _ = zipWith4
175 zipEqual msg [] [] = []
176 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
177 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
179 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
180 zipWithEqual msg _ [] [] = []
181 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
183 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
184 = z a b c : zipWith3Equal msg z as bs cs
185 zipWith3Equal msg _ [] [] [] = []
186 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
188 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
189 = z a b c d : zipWith4Equal msg z as bs cs ds
190 zipWith4Equal msg _ [] [] [] [] = []
191 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
196 -- zipLazy is lazy in the second list (observe the ~)
198 zipLazy :: [a] -> [b] -> [(a,b)]
200 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
205 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
206 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
207 -- the places where p returns *True*
209 stretchZipWith p z f [] ys = []
210 stretchZipWith p z f (x:xs) ys
211 | p x = f x z : stretchZipWith p z f xs ys
212 | otherwise = case ys of
214 (y:ys) -> f x y : stretchZipWith p z f xs ys
219 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
220 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
222 mapFst f xys = [(f x, y) | (x,y) <- xys]
223 mapSnd f xys = [(x, f y) | (x,y) <- xys]
225 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
227 mapAndUnzip f [] = ([],[])
231 (rs1, rs2) = mapAndUnzip f xs
235 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
237 mapAndUnzip3 f [] = ([],[],[])
238 mapAndUnzip3 f (x:xs)
241 (rs1, rs2, rs3) = mapAndUnzip3 f xs
243 (r1:rs1, r2:rs2, r3:rs3)
247 nOfThem :: Int -> a -> [a]
248 nOfThem n thing = replicate n thing
250 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
253 -- atLength atLenPred atEndPred ls n
254 -- | n < 0 = atLenPred n
255 -- | length ls < n = atEndPred (n - length ls)
256 -- | otherwise = atLenPred (drop n ls)
258 atLength :: ([a] -> b)
263 atLength atLenPred atEndPred ls n
264 | n < 0 = atEndPred n
265 | otherwise = go n ls
267 go n [] = atEndPred n
268 go 0 ls = atLenPred ls
269 go n (_:xs) = go (n-1) xs
272 lengthExceeds :: [a] -> Int -> Bool
273 -- (lengthExceeds xs n) = (length xs > n)
274 lengthExceeds = atLength notNull (const False)
276 lengthAtLeast :: [a] -> Int -> Bool
277 lengthAtLeast = atLength notNull (== 0)
279 lengthIs :: [a] -> Int -> Bool
280 lengthIs = atLength null (==0)
282 listLengthCmp :: [a] -> Int -> Ordering
283 listLengthCmp = atLength atLen atEnd
287 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
293 equalLength :: [a] -> [b] -> Bool
294 equalLength [] [] = True
295 equalLength (_:xs) (_:ys) = equalLength xs ys
296 equalLength xs ys = False
298 compareLength :: [a] -> [b] -> Ordering
299 compareLength [] [] = EQ
300 compareLength (_:xs) (_:ys) = compareLength xs ys
301 compareLength [] _ys = LT
302 compareLength _xs [] = GT
304 ----------------------------
305 singleton :: a -> [a]
308 isSingleton :: [a] -> Bool
309 isSingleton [x] = True
310 isSingleton _ = False
312 notNull :: [a] -> Bool
324 Debugging/specialising versions of \tr{elem} and \tr{notElem}
327 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
330 isIn msg x ys = elem__ x ys
331 isn'tIn msg x ys = notElem__ x ys
333 --these are here to be SPECIALIZEd (automagically)
335 elem__ x (y:ys) = x==y || elem__ x ys
337 notElem__ x [] = True
338 notElem__ x (y:ys) = x /= y && notElem__ x ys
342 = elem (_ILIT 0) x ys
346 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
348 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
351 = notElem (_ILIT 0) x ys
353 notElem i x [] = True
355 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
356 x `List.notElem` (y:ys)
357 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
361 foldl1' was added in GHC 6.4
364 #if __GLASGOW_HASKELL__ < 604
365 foldl1' :: (a -> a -> a) -> [a] -> a
366 foldl1' f (x:xs) = foldl' f x xs
367 foldl1' _ [] = panic "foldl1'"
371 %************************************************************************
373 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
375 %************************************************************************
378 Date: Mon, 3 May 93 20:45:23 +0200
379 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
380 To: partain@dcs.gla.ac.uk
381 Subject: natural merge sort beats quick sort [ and it is prettier ]
383 Here is a piece of Haskell code that I'm rather fond of. See it as an
384 attempt to get rid of the ridiculous quick-sort routine. group is
385 quite useful by itself I think it was John's idea originally though I
386 believe the lazy version is due to me [surprisingly complicated].
387 gamma [used to be called] is called gamma because I got inspired by
388 the Gamma calculus. It is not very close to the calculus but does
389 behave less sequentially than both foldr and foldl. One could imagine
390 a version of gamma that took a unit element as well thereby avoiding
391 the problem with empty lists.
393 I've tried this code against
395 1) insertion sort - as provided by haskell
396 2) the normal implementation of quick sort
397 3) a deforested version of quick sort due to Jan Sparud
398 4) a super-optimized-quick-sort of Lennart's
400 If the list is partially sorted both merge sort and in particular
401 natural merge sort wins. If the list is random [ average length of
402 rising subsequences = approx 2 ] mergesort still wins and natural
403 merge sort is marginally beaten by Lennart's soqs. The space
404 consumption of merge sort is a bit worse than Lennart's quick sort
405 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
406 fpca article ] isn't used because of group.
413 group :: (a -> a -> Bool) -> [a] -> [[a]]
414 -- Given a <= function, group finds maximal contiguous up-runs
415 -- or down-runs in the input list.
416 -- It's stable, in the sense that it never re-orders equal elements
418 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
419 -- From: Andy Gill <andy@dcs.gla.ac.uk>
420 -- Here is a `better' definition of group.
423 group p (x:xs) = group' xs x x (x :)
425 group' [] _ _ s = [s []]
426 group' (x:xs) x_min x_max s
427 | x_max `p` x = group' xs x_min x (s . (x :))
428 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
429 | otherwise = s [] : group' xs x x (x :)
430 -- NB: the 'not' is essential for stablity
431 -- x `p` x_min would reverse equal elements
433 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
434 generalMerge p xs [] = xs
435 generalMerge p [] ys = ys
436 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
437 | otherwise = y : generalMerge p (x:xs) ys
439 -- gamma is now called balancedFold
441 balancedFold :: (a -> a -> a) -> [a] -> a
442 balancedFold f [] = error "can't reduce an empty list using balancedFold"
443 balancedFold f [x] = x
444 balancedFold f l = balancedFold f (balancedFold' f l)
446 balancedFold' :: (a -> a -> a) -> [a] -> [a]
447 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
448 balancedFold' f xs = xs
450 generalNaturalMergeSort p [] = []
451 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
454 generalMergeSort p [] = []
455 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
457 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
459 mergeSort = generalMergeSort (<=)
460 naturalMergeSort = generalNaturalMergeSort (<=)
462 mergeSortLe le = generalMergeSort le
465 sortLe :: (a->a->Bool) -> [a] -> [a]
466 sortLe le = generalNaturalMergeSort le
468 sortWith :: Ord b => (a->b) -> [a] -> [a]
469 sortWith get_key xs = sortLe le xs
471 x `le` y = get_key x < get_key y
473 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
474 on cmp sel = \x y -> sel x `cmp` sel y
478 %************************************************************************
480 \subsection[Utils-transitive-closure]{Transitive closure}
482 %************************************************************************
484 This algorithm for transitive closure is straightforward, albeit quadratic.
487 transitiveClosure :: (a -> [a]) -- Successor function
488 -> (a -> a -> Bool) -- Equality predicate
490 -> [a] -- The transitive closure
492 transitiveClosure succ eq xs
496 go done (x:xs) | x `is_in` done = go done xs
497 | otherwise = go (x:done) (succ x ++ xs)
500 x `is_in` (y:ys) | eq x y = True
501 | otherwise = x `is_in` ys
504 %************************************************************************
506 \subsection[Utils-accum]{Accumulating}
508 %************************************************************************
510 A combination of foldl with zip. It works with equal length lists.
513 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
515 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
517 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
518 -- True if the lists are the same length, and
519 -- all corresponding elements satisfy the predicate
521 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
525 Count the number of times a predicate is true
528 count :: (a -> Bool) -> [a] -> Int
530 count p (x:xs) | p x = 1 + count p xs
531 | otherwise = count p xs
534 @splitAt@, @take@, and @drop@ but with length of another
535 list giving the break-off point:
538 takeList :: [b] -> [a] -> [a]
543 (y:ys) -> y : takeList xs ys
545 dropList :: [b] -> [a] -> [a]
547 dropList _ xs@[] = xs
548 dropList (_:xs) (_:ys) = dropList xs ys
551 splitAtList :: [b] -> [a] -> ([a], [a])
552 splitAtList [] xs = ([], xs)
553 splitAtList _ xs@[] = (xs, xs)
554 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
556 (ys', ys'') = splitAtList xs ys
558 snocView :: [a] -> Maybe ([a],a)
559 -- Split off the last element
560 snocView [] = Nothing
561 snocView xs = go [] xs
563 -- Invariant: second arg is non-empty
564 go acc [x] = Just (reverse acc, x)
565 go acc (x:xs) = go (x:acc) xs
567 split :: Char -> String -> [String]
568 split c s = case rest of
570 _:rest -> chunk : split c rest
571 where (chunk, rest) = break (==c) s
575 %************************************************************************
577 \subsection[Utils-comparison]{Comparisons}
579 %************************************************************************
582 isEqual :: Ordering -> Bool
583 -- Often used in (isEqual (a `compare` b))
588 thenCmp :: Ordering -> Ordering -> Ordering
589 {-# INLINE thenCmp #-}
591 thenCmp other any = other
593 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
594 eqListBy eq [] [] = True
595 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
596 eqListBy eq xs ys = False
598 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
599 -- `cmpList' uses a user-specified comparer
601 cmpList cmp [] [] = EQ
602 cmpList cmp [] _ = LT
603 cmpList cmp _ [] = GT
604 cmpList cmp (a:as) (b:bs)
605 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
609 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
610 -- This definition can be removed once we require at least 6.8 to build.
611 maybePrefixMatch :: String -> String -> Maybe String
612 maybePrefixMatch [] rest = Just rest
613 maybePrefixMatch (_:_) [] = Nothing
614 maybePrefixMatch (p:pat) (r:rest)
615 | p == r = maybePrefixMatch pat rest
616 | otherwise = Nothing
618 removeSpaces :: String -> String
619 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
622 %************************************************************************
624 \subsection[Utils-pairs]{Pairs}
626 %************************************************************************
629 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
630 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
634 seqList :: [a] -> b -> b
636 seqList (x:xs) b = x `seq` seqList xs b
642 global :: a -> IORef a
643 global a = unsafePerformIO (newIORef a)
647 consIORef :: IORef [a] -> a -> IO ()
650 writeIORef var (x:xs)
656 looksLikeModuleName :: String -> Bool
657 looksLikeModuleName [] = False
658 looksLikeModuleName (c:cs) = isUpper c && go cs
660 go ('.':cs) = looksLikeModuleName cs
661 go (c:cs) = (isAlphaNum c || c == '_') && go cs
664 Akin to @Prelude.words@, but acts like the Bourne shell, treating
665 quoted strings and escaped characters within the input as solid blocks
666 of characters. Doesn't raise any exceptions on malformed escapes or
670 toArgs :: String -> [String]
673 case dropWhile isSpace s of -- drop initial spacing
674 [] -> [] -- empty, so no more tokens
675 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
677 -- Grab a token off the string, given that the first character exists and
678 -- isn't whitespace. The second argument is an accumulator which has to be
679 -- reversed at the end.
680 token [] acc = (reverse acc,[]) -- out of characters
681 token ('\\':c:aft) acc -- escapes
682 = token aft ((escape c) : acc)
683 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
684 = let (aft',acc') = quote q aft acc in token aft' acc'
685 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
687 token (c:aft) acc -- anything else goes in the token
690 -- Get the appropriate character for a single-character escape.
696 -- Read into accumulator until a quote character is found.
698 let quote' [] acc = ([],acc)
699 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
700 quote' (c:aft) acc | c == qc = (aft,acc)
701 quote' (c:aft) acc = quote' aft (c:acc)
705 -- -----------------------------------------------------------------------------
709 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
710 readRational__ r = do
713 return ((n%1)*10^^(k-d), t)
716 (ds,s) <- lexDecDigits r
717 (ds',t) <- lexDotDigits s
718 return (read (ds++ds'), length ds', t)
720 readExp (e:s) | e `elem` "eE" = readExp' s
721 readExp s = return (0,s)
723 readExp' ('+':s) = readDec s
724 readExp' ('-':s) = do
727 readExp' s = readDec s
730 (ds,r) <- nonnull isDigit s
731 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
734 lexDecDigits = nonnull isDigit
736 lexDotDigits ('.':s) = return (span isDigit s)
737 lexDotDigits s = return ("",s)
739 nonnull p s = do (cs@(_:_),t) <- return (span p s)
742 readRational :: String -> Rational -- NB: *does* handle a leading "-"
745 '-' : xs -> - (read_me xs)
749 = case (do { (x,"") <- readRational__ s ; return x }) of
751 [] -> error ("readRational: no parse:" ++ top_s)
752 _ -> error ("readRational: ambiguous parse:" ++ top_s)
755 -----------------------------------------------------------------------------
756 -- Create a hierarchy of directories
758 createDirectoryHierarchy :: FilePath -> IO ()
759 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
760 createDirectoryHierarchy dir = do
761 b <- doesDirectoryExist dir
763 createDirectoryHierarchy (takeDirectory dir)
766 -----------------------------------------------------------------------------
767 -- Verify that the 'dirname' portion of a FilePath exists.
769 doesDirNameExist :: FilePath -> IO Bool
770 doesDirNameExist fpath = case takeDirectory fpath of
771 "" -> return True -- XXX Hack
772 dir -> doesDirectoryExist (takeDirectory fpath)
774 -- -----------------------------------------------------------------------------
779 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
780 handleDyn = flip catchDyn
782 handle :: (Exception -> IO a) -> IO a -> IO a
783 handle h f = f `Exception.catch` \e -> case e of
784 ExitException _ -> throw e
787 -- --------------------------------------------------------------
788 -- check existence & modification time at the same time
790 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
791 modificationTimeIfExists f = do
792 (do t <- getModificationTime f; return (Just t))
793 `IO.catch` \e -> if isDoesNotExistError e
797 -- split a string at the last character where 'pred' is True,
798 -- returning a pair of strings. The first component holds the string
799 -- up (but not including) the last character for which 'pred' returned
800 -- True, the second whatever comes after (but also not including the
803 -- If 'pred' returns False for all characters in the string, the original
804 -- string is returned in the first component (and the second one is just
806 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
807 splitLongestPrefix str pred
808 | null r_pre = (str, [])
809 | otherwise = (reverse (tail r_pre), reverse r_suf)
810 -- 'tail' drops the char satisfying 'pred'
812 (r_suf, r_pre) = break pred (reverse str)
814 escapeSpaces :: String -> String
815 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
819 --------------------------------------------------------------
821 --------------------------------------------------------------
823 -- | The function splits the given string to substrings
824 -- using the 'searchPathSeparator'.
825 parseSearchPath :: String -> [FilePath]
826 parseSearchPath path = split path
828 split :: String -> [String]
832 _:rest -> chunk : split rest
836 #ifdef mingw32_HOST_OS
837 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
841 (chunk', rest') = break (==searchPathSeparator) s
843 -- | A platform-specific character used to separate search path strings in
844 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
845 -- and a semicolon (\";\") on the Windows operating system.
846 searchPathSeparator :: Char
847 #if mingw32_HOST_OS || mingw32_TARGET_OS
848 searchPathSeparator = ';'
850 searchPathSeparator = ':'