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,
56 getCmd, toCmdArgs, toArgs,
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 _ [] [] = []
167 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
168 zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)
170 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
171 zipWithEqual _ _ [] [] = []
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 _ _ [] [] [] = []
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 _ _ [] [] [] [] = []
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 _ _ [] = 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 defined(__GLASGOW_HASKELL__) && __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 as Haskell Strings, and also parses Haskell [String]
664 getCmd :: String -> Either String -- Error
665 (String, String) -- (Cmd, Rest)
666 getCmd s = case break isSpace $ dropWhile isSpace s of
667 ([], _) -> Left ("Couldn't find command in " ++ show s)
670 toCmdArgs :: String -> Either String -- Error
671 (String, [String]) -- (Cmd, Args)
672 toCmdArgs s = case getCmd s of
674 Right (cmd, s') -> case toArgs s' of
676 Right args -> Right (cmd, args)
678 toArgs :: String -> Either String -- Error
681 = case dropWhile isSpace str of
682 s@('[':_) -> case reads s of
684 | all isSpace spaces ->
687 Left ("Couldn't read " ++ show str ++ "as [String]")
690 toArgs' s = case dropWhile isSpace s of
692 ('"' : _) -> case reads s of
694 -- rest must either be [] or start with a space
695 | all isSpace (take 1 rest) ->
698 Right args -> Right (arg : args)
700 Left ("Couldn't read " ++ show s ++ "as String")
701 s' -> case break isSpace s' of
702 (arg, s'') -> case toArgs' s'' of
704 Right args -> Right (arg : args)
707 -- -----------------------------------------------------------------------------
711 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
712 readRational__ r = do
715 return ((n%1)*10^^(k-d), t)
718 (ds,s) <- lexDecDigits r
719 (ds',t) <- lexDotDigits s
720 return (read (ds++ds'), length ds', t)
722 readExp (e:s) | e `elem` "eE" = readExp' s
723 readExp s = return (0,s)
725 readExp' ('+':s) = readDec s
726 readExp' ('-':s) = do (k,t) <- readDec s
728 readExp' s = readDec s
731 (ds,r) <- nonnull isDigit s
732 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
735 lexDecDigits = nonnull isDigit
737 lexDotDigits ('.':s) = return (span isDigit s)
738 lexDotDigits s = return ("",s)
740 nonnull p s = do (cs@(_:_),t) <- return (span p s)
743 readRational :: String -> Rational -- NB: *does* handle a leading "-"
746 '-' : xs -> - (read_me xs)
750 = case (do { (x,"") <- readRational__ s ; return x }) of
752 [] -> error ("readRational: no parse:" ++ top_s)
753 _ -> error ("readRational: ambiguous parse:" ++ top_s)
756 -----------------------------------------------------------------------------
757 -- Create a hierarchy of directories
759 createDirectoryHierarchy :: FilePath -> IO ()
760 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
761 createDirectoryHierarchy dir = do
762 b <- doesDirectoryExist dir
763 unless b $ do 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 _ -> doesDirectoryExist (takeDirectory fpath)
774 -- -----------------------------------------------------------------------------
777 later :: IO b -> IO a -> IO a
780 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
781 handleDyn = flip catchDyn
783 handle :: (Exception -> IO a) -> IO a -> IO a
784 handle h f = f `Exception.catch` \e -> case e of
785 ExitException _ -> throw e
788 -- --------------------------------------------------------------
789 -- check existence & modification time at the same time
791 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
792 modificationTimeIfExists f = do
793 (do t <- getModificationTime f; return (Just t))
794 `IO.catch` \e -> if isDoesNotExistError e
798 -- split a string at the last character where 'pred' is True,
799 -- returning a pair of strings. The first component holds the string
800 -- up (but not including) the last character for which 'pred' returned
801 -- True, the second whatever comes after (but also not including the
804 -- If 'pred' returns False for all characters in the string, the original
805 -- string is returned in the first component (and the second one is just
807 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
808 splitLongestPrefix str pred
809 | null r_pre = (str, [])
810 | otherwise = (reverse (tail r_pre), reverse r_suf)
811 -- 'tail' drops the char satisfying 'pred'
812 where (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
845 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
846 searchPathSeparator :: Char
847 #if mingw32_HOST_OS || mingw32_TARGET_OS
848 searchPathSeparator = ';'
850 searchPathSeparator = ':'
853 data Direction = Forwards | Backwards
855 reslash :: Direction -> FilePath -> FilePath
857 where f ('/' : xs) = slash : f xs
858 f ('\\' : xs) = slash : f xs
859 f (x : xs) = x : f xs