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,
73 Direction(..), reslash,
76 -- XXX This define is a bit of a hack, and should be done more nicely
77 #define FAST_STRING_NOT_NEEDED 1
78 #include "HsVersions.h"
82 import Control.Exception ( Exception(..), finally, catchDyn, throw )
83 import qualified Control.Exception as Exception
84 import Data.Dynamic ( Typeable )
85 import Data.IORef ( IORef, newIORef )
86 import System.IO.Unsafe ( unsafePerformIO )
87 import Data.IORef ( readIORef, writeIORef )
88 import Data.List hiding (group)
90 import qualified Data.List as List ( elem )
92 import qualified Data.List as List ( notElem )
96 import Control.Monad ( unless )
97 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
98 import System.Directory ( doesDirectoryExist, createDirectory,
100 import System.FilePath hiding ( searchPathSeparator )
101 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
102 import Data.Ratio ( (%) )
103 import System.Time ( ClockTime )
108 %************************************************************************
110 \subsection{A for loop}
112 %************************************************************************
115 -- Compose a function with itself n times. (nth rather than twice)
116 nTimes :: Int -> (a -> a) -> (a -> a)
119 nTimes n f = f . nTimes (n-1) f
122 %************************************************************************
124 \subsection[Utils-lists]{General list processing}
126 %************************************************************************
129 filterOut :: (a->Bool) -> [a] -> [a]
130 -- Like filter, only reverses the sense of the test
132 filterOut p (x:xs) | p x = filterOut p xs
133 | otherwise = x : filterOut p xs
135 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
136 partitionWith _ [] = ([],[])
137 partitionWith f (x:xs) = case f x of
139 Right c -> (bs, c:cs)
140 where (bs,cs) = partitionWith f xs
142 splitEithers :: [Either a b] -> ([a], [b])
143 splitEithers [] = ([],[])
144 splitEithers (e : es) = case e of
146 Right y -> (xs, y:ys)
147 where (xs,ys) = splitEithers es
150 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
151 are of equal length. Alastair Reid thinks this should only happen if
152 DEBUGging on; hey, why not?
155 zipEqual :: String -> [a] -> [b] -> [(a,b)]
156 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
157 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
158 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
162 zipWithEqual _ = zipWith
163 zipWith3Equal _ = zipWith3
164 zipWith4Equal _ = zipWith4
166 zipEqual msg [] [] = []
167 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
168 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
170 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
171 zipWithEqual msg _ [] [] = []
172 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
174 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
175 = z a b c : zipWith3Equal msg z as bs cs
176 zipWith3Equal msg _ [] [] [] = []
177 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
179 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
180 = z a b c d : zipWith4Equal msg z as bs cs ds
181 zipWith4Equal msg _ [] [] [] [] = []
182 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
187 -- zipLazy is lazy in the second list (observe the ~)
189 zipLazy :: [a] -> [b] -> [(a,b)]
191 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
196 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
197 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
198 -- the places where p returns *True*
200 stretchZipWith _ _ _ [] _ = []
201 stretchZipWith p z f (x:xs) ys
202 | p x = f x z : stretchZipWith p z f xs ys
203 | otherwise = case ys of
205 (y:ys) -> f x y : stretchZipWith p z f xs ys
210 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
211 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
213 mapFst f xys = [(f x, y) | (x,y) <- xys]
214 mapSnd f xys = [(x, f y) | (x,y) <- xys]
216 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
218 mapAndUnzip _ [] = ([], [])
221 (rs1, rs2) = mapAndUnzip f xs
225 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
227 mapAndUnzip3 _ [] = ([], [], [])
228 mapAndUnzip3 f (x:xs)
229 = let (r1, r2, r3) = f x
230 (rs1, rs2, rs3) = mapAndUnzip3 f xs
232 (r1:rs1, r2:rs2, r3:rs3)
236 nOfThem :: Int -> a -> [a]
237 nOfThem n thing = replicate n thing
239 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
242 -- atLength atLenPred atEndPred ls n
243 -- | n < 0 = atLenPred n
244 -- | length ls < n = atEndPred (n - length ls)
245 -- | otherwise = atLenPred (drop n ls)
247 atLength :: ([a] -> b)
252 atLength atLenPred atEndPred ls n
253 | n < 0 = atEndPred n
254 | otherwise = go n ls
256 go n [] = atEndPred n
257 go 0 ls = atLenPred ls
258 go n (_:xs) = go (n-1) xs
261 lengthExceeds :: [a] -> Int -> Bool
262 -- (lengthExceeds xs n) = (length xs > n)
263 lengthExceeds = atLength notNull (const False)
265 lengthAtLeast :: [a] -> Int -> Bool
266 lengthAtLeast = atLength notNull (== 0)
268 lengthIs :: [a] -> Int -> Bool
269 lengthIs = atLength null (==0)
271 listLengthCmp :: [a] -> Int -> Ordering
272 listLengthCmp = atLength atLen atEnd
276 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
282 equalLength :: [a] -> [b] -> Bool
283 equalLength [] [] = True
284 equalLength (_:xs) (_:ys) = equalLength xs ys
285 equalLength _ _ = False
287 compareLength :: [a] -> [b] -> Ordering
288 compareLength [] [] = EQ
289 compareLength (_:xs) (_:ys) = compareLength xs ys
290 compareLength [] _ = LT
291 compareLength _ [] = GT
293 ----------------------------
294 singleton :: a -> [a]
297 isSingleton :: [a] -> Bool
298 isSingleton [_] = True
299 isSingleton _ = False
301 notNull :: [a] -> Bool
311 only _ = panic "Util: only"
314 Debugging/specialising versions of \tr{elem} and \tr{notElem}
317 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
320 isIn _msg x ys = elem__ x ys
321 isn'tIn _msg x ys = notElem__ x ys
323 --these are here to be SPECIALIZEd (automagically)
324 elem__ :: Eq a => a -> [a] -> Bool
326 elem__ x (y:ys) = x == y || elem__ x ys
328 notElem__ :: Eq a => a -> [a] -> Bool
329 notElem__ _ [] = True
330 notElem__ x (y:ys) = x /= y && notElem__ x ys
334 = elem (_ILIT 0) x ys
338 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg)
339 (x `List.elem` (y:ys))
340 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
343 = notElem (_ILIT 0) x ys
345 notElem i x [] = True
347 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg)
348 (x `List.notElem` (y:ys))
349 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
353 foldl1' was added in GHC 6.4
356 #if __GLASGOW_HASKELL__ < 604
357 foldl1' :: (a -> a -> a) -> [a] -> a
358 foldl1' f (x:xs) = foldl' f x xs
359 foldl1' _ [] = panic "foldl1'"
363 %************************************************************************
365 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
367 %************************************************************************
370 Date: Mon, 3 May 93 20:45:23 +0200
371 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
372 To: partain@dcs.gla.ac.uk
373 Subject: natural merge sort beats quick sort [ and it is prettier ]
375 Here is a piece of Haskell code that I'm rather fond of. See it as an
376 attempt to get rid of the ridiculous quick-sort routine. group is
377 quite useful by itself I think it was John's idea originally though I
378 believe the lazy version is due to me [surprisingly complicated].
379 gamma [used to be called] is called gamma because I got inspired by
380 the Gamma calculus. It is not very close to the calculus but does
381 behave less sequentially than both foldr and foldl. One could imagine
382 a version of gamma that took a unit element as well thereby avoiding
383 the problem with empty lists.
385 I've tried this code against
387 1) insertion sort - as provided by haskell
388 2) the normal implementation of quick sort
389 3) a deforested version of quick sort due to Jan Sparud
390 4) a super-optimized-quick-sort of Lennart's
392 If the list is partially sorted both merge sort and in particular
393 natural merge sort wins. If the list is random [ average length of
394 rising subsequences = approx 2 ] mergesort still wins and natural
395 merge sort is marginally beaten by Lennart's soqs. The space
396 consumption of merge sort is a bit worse than Lennart's quick sort
397 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
398 fpca article ] isn't used because of group.
405 group :: (a -> a -> Bool) -> [a] -> [[a]]
406 -- Given a <= function, group finds maximal contiguous up-runs
407 -- or down-runs in the input list.
408 -- It's stable, in the sense that it never re-orders equal elements
410 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
411 -- From: Andy Gill <andy@dcs.gla.ac.uk>
412 -- Here is a `better' definition of group.
415 group p (x:xs) = group' xs x x (x :)
417 group' [] _ _ s = [s []]
418 group' (x:xs) x_min x_max s
419 | x_max `p` x = group' xs x_min x (s . (x :))
420 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
421 | otherwise = s [] : group' xs x x (x :)
422 -- NB: the 'not' is essential for stablity
423 -- x `p` x_min would reverse equal elements
425 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
426 generalMerge _ xs [] = xs
427 generalMerge _ [] ys = ys
428 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
429 | otherwise = y : generalMerge p (x:xs) ys
431 -- gamma is now called balancedFold
433 balancedFold :: (a -> a -> a) -> [a] -> a
434 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
435 balancedFold _ [x] = x
436 balancedFold f l = balancedFold f (balancedFold' f l)
438 balancedFold' :: (a -> a -> a) -> [a] -> [a]
439 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
440 balancedFold' _ xs = xs
442 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
443 generalNaturalMergeSort _ [] = []
444 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
447 generalMergeSort p [] = []
448 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
450 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
452 mergeSort = generalMergeSort (<=)
453 naturalMergeSort = generalNaturalMergeSort (<=)
455 mergeSortLe le = generalMergeSort le
458 sortLe :: (a->a->Bool) -> [a] -> [a]
459 sortLe le = generalNaturalMergeSort le
461 sortWith :: Ord b => (a->b) -> [a] -> [a]
462 sortWith get_key xs = sortLe le xs
464 x `le` y = get_key x < get_key y
466 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
467 on cmp sel = \x y -> sel x `cmp` sel y
471 %************************************************************************
473 \subsection[Utils-transitive-closure]{Transitive closure}
475 %************************************************************************
477 This algorithm for transitive closure is straightforward, albeit quadratic.
480 transitiveClosure :: (a -> [a]) -- Successor function
481 -> (a -> a -> Bool) -- Equality predicate
483 -> [a] -- The transitive closure
485 transitiveClosure succ eq xs
489 go done (x:xs) | x `is_in` done = go done xs
490 | otherwise = go (x:done) (succ x ++ xs)
493 x `is_in` (y:ys) | eq x y = True
494 | otherwise = x `is_in` ys
497 %************************************************************************
499 \subsection[Utils-accum]{Accumulating}
501 %************************************************************************
503 A combination of foldl with zip. It works with equal length lists.
506 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
508 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
509 foldl2 _ _ _ _ = panic "Util: foldl2"
511 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
512 -- True if the lists are the same length, and
513 -- all corresponding elements satisfy the predicate
515 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
519 Count the number of times a predicate is true
522 count :: (a -> Bool) -> [a] -> Int
524 count p (x:xs) | p x = 1 + count p xs
525 | otherwise = count p xs
528 @splitAt@, @take@, and @drop@ but with length of another
529 list giving the break-off point:
532 takeList :: [b] -> [a] -> [a]
537 (y:ys) -> y : takeList xs ys
539 dropList :: [b] -> [a] -> [a]
541 dropList _ xs@[] = xs
542 dropList (_:xs) (_:ys) = dropList xs ys
545 splitAtList :: [b] -> [a] -> ([a], [a])
546 splitAtList [] xs = ([], xs)
547 splitAtList _ xs@[] = (xs, xs)
548 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
550 (ys', ys'') = splitAtList xs ys
552 snocView :: [a] -> Maybe ([a],a)
553 -- Split off the last element
554 snocView [] = Nothing
555 snocView xs = go [] xs
557 -- Invariant: second arg is non-empty
558 go acc [x] = Just (reverse acc, x)
559 go acc (x:xs) = go (x:acc) xs
560 go _ [] = panic "Util: snocView"
562 split :: Char -> String -> [String]
563 split c s = case rest of
565 _:rest -> chunk : split c rest
566 where (chunk, rest) = break (==c) s
570 %************************************************************************
572 \subsection[Utils-comparison]{Comparisons}
574 %************************************************************************
577 isEqual :: Ordering -> Bool
578 -- Often used in (isEqual (a `compare` b))
583 thenCmp :: Ordering -> Ordering -> Ordering
584 {-# INLINE thenCmp #-}
585 thenCmp EQ ordering = ordering
586 thenCmp ordering _ = ordering
588 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
589 eqListBy _ [] [] = True
590 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
591 eqListBy _ _ _ = False
593 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
594 -- `cmpList' uses a user-specified comparer
599 cmpList cmp (a:as) (b:bs)
600 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
604 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
605 -- This definition can be removed once we require at least 6.8 to build.
606 maybePrefixMatch :: String -> String -> Maybe String
607 maybePrefixMatch [] rest = Just rest
608 maybePrefixMatch (_:_) [] = Nothing
609 maybePrefixMatch (p:pat) (r:rest)
610 | p == r = maybePrefixMatch pat rest
611 | otherwise = Nothing
613 removeSpaces :: String -> String
614 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
617 %************************************************************************
619 \subsection[Utils-pairs]{Pairs}
621 %************************************************************************
624 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
625 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
629 seqList :: [a] -> b -> b
631 seqList (x:xs) b = x `seq` seqList xs b
637 global :: a -> IORef a
638 global a = unsafePerformIO (newIORef a)
642 consIORef :: IORef [a] -> a -> IO ()
645 writeIORef var (x:xs)
651 looksLikeModuleName :: String -> Bool
652 looksLikeModuleName [] = False
653 looksLikeModuleName (c:cs) = isUpper c && go cs
655 go ('.':cs) = looksLikeModuleName cs
656 go (c:cs) = (isAlphaNum c || c == '_') && go cs
659 Akin to @Prelude.words@, but acts like the Bourne shell, treating
660 quoted strings and escaped characters within the input as solid blocks
661 of characters. Doesn't raise any exceptions on malformed escapes or
665 toArgs :: String -> [String]
668 case dropWhile isSpace s of -- drop initial spacing
669 [] -> [] -- empty, so no more tokens
670 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
672 -- Grab a token off the string, given that the first character exists and
673 -- isn't whitespace. The second argument is an accumulator which has to be
674 -- reversed at the end.
675 token [] acc = (reverse acc,[]) -- out of characters
676 token ('\\':c:aft) acc -- escapes
677 = token aft ((escape c) : acc)
678 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
679 = let (aft',acc') = quote q aft acc in token aft' acc'
680 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
682 token (c:aft) acc -- anything else goes in the token
685 -- Get the appropriate character for a single-character escape.
691 -- Read into accumulator until a quote character is found.
693 let quote' [] acc = ([],acc)
694 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
695 quote' (c:aft) acc | c == qc = (aft,acc)
696 quote' (c:aft) acc = quote' aft (c:acc)
700 -- -----------------------------------------------------------------------------
704 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
705 readRational__ r = do
708 return ((n%1)*10^^(k-d), t)
711 (ds,s) <- lexDecDigits r
712 (ds',t) <- lexDotDigits s
713 return (read (ds++ds'), length ds', t)
715 readExp (e:s) | e `elem` "eE" = readExp' s
716 readExp s = return (0,s)
718 readExp' ('+':s) = readDec s
719 readExp' ('-':s) = do (k,t) <- readDec s
721 readExp' s = readDec s
724 (ds,r) <- nonnull isDigit s
725 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
728 lexDecDigits = nonnull isDigit
730 lexDotDigits ('.':s) = return (span isDigit s)
731 lexDotDigits s = return ("",s)
733 nonnull p s = do (cs@(_:_),t) <- return (span p s)
736 readRational :: String -> Rational -- NB: *does* handle a leading "-"
739 '-' : xs -> - (read_me xs)
743 = case (do { (x,"") <- readRational__ s ; return x }) of
745 [] -> error ("readRational: no parse:" ++ top_s)
746 _ -> error ("readRational: ambiguous parse:" ++ top_s)
749 -----------------------------------------------------------------------------
750 -- Create a hierarchy of directories
752 createDirectoryHierarchy :: FilePath -> IO ()
753 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
754 createDirectoryHierarchy dir = do
755 b <- doesDirectoryExist dir
756 unless b $ do createDirectoryHierarchy (takeDirectory dir)
759 -----------------------------------------------------------------------------
760 -- Verify that the 'dirname' portion of a FilePath exists.
762 doesDirNameExist :: FilePath -> IO Bool
763 doesDirNameExist fpath = case takeDirectory fpath of
764 "" -> return True -- XXX Hack
765 _ -> doesDirectoryExist (takeDirectory fpath)
767 -- -----------------------------------------------------------------------------
770 later :: IO b -> IO a -> IO a
773 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
774 handleDyn = flip catchDyn
776 handle :: (Exception -> IO a) -> IO a -> IO a
777 handle h f = f `Exception.catch` \e -> case e of
778 ExitException _ -> throw e
781 -- --------------------------------------------------------------
782 -- check existence & modification time at the same time
784 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
785 modificationTimeIfExists f = do
786 (do t <- getModificationTime f; return (Just t))
787 `IO.catch` \e -> if isDoesNotExistError e
791 -- split a string at the last character where 'pred' is True,
792 -- returning a pair of strings. The first component holds the string
793 -- up (but not including) the last character for which 'pred' returned
794 -- True, the second whatever comes after (but also not including the
797 -- If 'pred' returns False for all characters in the string, the original
798 -- string is returned in the first component (and the second one is just
800 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
801 splitLongestPrefix str pred
802 | null r_pre = (str, [])
803 | otherwise = (reverse (tail r_pre), reverse r_suf)
804 -- 'tail' drops the char satisfying 'pred'
805 where (r_suf, r_pre) = break pred (reverse str)
807 escapeSpaces :: String -> String
808 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
812 --------------------------------------------------------------
814 --------------------------------------------------------------
816 -- | The function splits the given string to substrings
817 -- using the 'searchPathSeparator'.
818 parseSearchPath :: String -> [FilePath]
819 parseSearchPath path = split path
821 split :: String -> [String]
825 _:rest -> chunk : split rest
829 #ifdef mingw32_HOST_OS
830 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
834 (chunk', rest') = break (==searchPathSeparator) s
836 -- | A platform-specific character used to separate search path strings in
837 -- environment variables. The separator is a colon (\":\") on Unix and
838 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
839 searchPathSeparator :: Char
840 #if mingw32_HOST_OS || mingw32_TARGET_OS
841 searchPathSeparator = ';'
843 searchPathSeparator = ':'
846 data Direction = Forwards | Backwards
848 reslash :: Direction -> FilePath -> FilePath
850 where f ('/' : xs) = slash : f xs
851 f ('\\' : xs) = slash : f xs
852 f (x : xs) = x : f xs