2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow 1992-2002
5 \section[Util]{Highly random utility functions}
11 -- general list processing
12 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
13 zipLazy, stretchZipWith,
15 mapAndUnzip, mapAndUnzip3,
16 nOfThem, filterOut, partitionWith, splitEithers,
19 lengthExceeds, lengthIs, lengthAtLeast,
20 listLengthCmp, atLength, equalLength, compareLength,
22 isSingleton, only, singleton,
33 -- transitive closures
39 takeList, dropList, splitAtList, split,
43 thenCmp, cmpList, maybePrefixMatch,
57 getCmd, toCmdArgs, toArgs,
59 -- Floating point stuff
63 createDirectoryHierarchy,
65 modificationTimeIfExists,
67 later, handleDyn, handle,
74 Direction(..), reslash,
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 %************************************************************************
111 %************************************************************************
122 %************************************************************************
124 \subsection{A for loop}
126 %************************************************************************
129 -- Compose a function with itself n times. (nth rather than twice)
130 nTimes :: Int -> (a -> a) -> (a -> a)
133 nTimes n f = f . nTimes (n-1) f
136 %************************************************************************
138 \subsection[Utils-lists]{General list processing}
140 %************************************************************************
143 filterOut :: (a->Bool) -> [a] -> [a]
144 -- Like filter, only reverses the sense of the test
146 filterOut p (x:xs) | p x = filterOut p xs
147 | otherwise = x : filterOut p xs
149 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
150 partitionWith _ [] = ([],[])
151 partitionWith f (x:xs) = case f x of
153 Right c -> (bs, c:cs)
154 where (bs,cs) = partitionWith f xs
156 splitEithers :: [Either a b] -> ([a], [b])
157 splitEithers [] = ([],[])
158 splitEithers (e : es) = case e of
160 Right y -> (xs, y:ys)
161 where (xs,ys) = splitEithers es
164 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
165 are of equal length. Alastair Reid thinks this should only happen if
166 DEBUGging on; hey, why not?
169 zipEqual :: String -> [a] -> [b] -> [(a,b)]
170 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
171 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
172 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
176 zipWithEqual _ = zipWith
177 zipWith3Equal _ = zipWith3
178 zipWith4Equal _ = zipWith4
180 zipEqual _ [] [] = []
181 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
182 zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)
184 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
185 zipWithEqual _ _ [] [] = []
186 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
188 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
189 = z a b c : zipWith3Equal msg z as bs cs
190 zipWith3Equal _ _ [] [] [] = []
191 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
193 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
194 = z a b c d : zipWith4Equal msg z as bs cs ds
195 zipWith4Equal _ _ [] [] [] [] = []
196 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
201 -- zipLazy is lazy in the second list (observe the ~)
203 zipLazy :: [a] -> [b] -> [(a,b)]
205 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
210 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
211 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
212 -- the places where p returns *True*
214 stretchZipWith _ _ _ [] _ = []
215 stretchZipWith p z f (x:xs) ys
216 | p x = f x z : stretchZipWith p z f xs ys
217 | otherwise = case ys of
219 (y:ys) -> f x y : stretchZipWith p z f xs ys
224 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
225 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
227 mapFst f xys = [(f x, y) | (x,y) <- xys]
228 mapSnd f xys = [(x, f y) | (x,y) <- xys]
230 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
232 mapAndUnzip _ [] = ([], [])
235 (rs1, rs2) = mapAndUnzip f xs
239 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
241 mapAndUnzip3 _ [] = ([], [], [])
242 mapAndUnzip3 f (x:xs)
243 = let (r1, r2, r3) = f x
244 (rs1, rs2, rs3) = mapAndUnzip3 f xs
246 (r1:rs1, r2:rs2, r3:rs3)
250 nOfThem :: Int -> a -> [a]
251 nOfThem n thing = replicate n thing
253 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
256 -- atLength atLenPred atEndPred ls n
257 -- | n < 0 = atLenPred n
258 -- | length ls < n = atEndPred (n - length ls)
259 -- | otherwise = atLenPred (drop n ls)
261 atLength :: ([a] -> b)
266 atLength atLenPred atEndPred ls n
267 | n < 0 = atEndPred n
268 | otherwise = go n ls
270 go n [] = atEndPred n
271 go 0 ls = atLenPred ls
272 go n (_:xs) = go (n-1) xs
275 lengthExceeds :: [a] -> Int -> Bool
276 -- (lengthExceeds xs n) = (length xs > n)
277 lengthExceeds = atLength notNull (const False)
279 lengthAtLeast :: [a] -> Int -> Bool
280 lengthAtLeast = atLength notNull (== 0)
282 lengthIs :: [a] -> Int -> Bool
283 lengthIs = atLength null (==0)
285 listLengthCmp :: [a] -> Int -> Ordering
286 listLengthCmp = atLength atLen atEnd
290 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
296 equalLength :: [a] -> [b] -> Bool
297 equalLength [] [] = True
298 equalLength (_:xs) (_:ys) = equalLength xs ys
299 equalLength _ _ = False
301 compareLength :: [a] -> [b] -> Ordering
302 compareLength [] [] = EQ
303 compareLength (_:xs) (_:ys) = compareLength xs ys
304 compareLength [] _ = LT
305 compareLength _ [] = GT
307 ----------------------------
308 singleton :: a -> [a]
311 isSingleton :: [a] -> Bool
312 isSingleton [_] = True
313 isSingleton _ = False
315 notNull :: [a] -> Bool
325 only _ = panic "Util: only"
328 Debugging/specialising versions of \tr{elem} and \tr{notElem}
331 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
334 isIn _msg x ys = elem__ x ys
335 isn'tIn _msg x ys = notElem__ x ys
337 --these are here to be SPECIALIZEd (automagically)
338 elem__ :: Eq a => a -> [a] -> Bool
340 elem__ x (y:ys) = x == y || elem__ x ys
342 notElem__ :: Eq a => a -> [a] -> Bool
343 notElem__ _ [] = True
344 notElem__ x (y:ys) = x /= y && notElem__ x ys
348 = elem (_ILIT(0)) x ys
352 | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
353 (x `List.elem` (y:ys))
354 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
357 = notElem (_ILIT(0)) x ys
359 notElem _ _ [] = True
361 | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
362 (x `List.notElem` (y:ys))
363 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
367 foldl1' was added in GHC 6.4
370 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604
371 foldl1' :: (a -> a -> a) -> [a] -> a
372 foldl1' f (x:xs) = foldl' f x xs
373 foldl1' _ [] = panic "foldl1'"
377 %************************************************************************
379 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
381 %************************************************************************
384 Date: Mon, 3 May 93 20:45:23 +0200
385 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
386 To: partain@dcs.gla.ac.uk
387 Subject: natural merge sort beats quick sort [ and it is prettier ]
389 Here is a piece of Haskell code that I'm rather fond of. See it as an
390 attempt to get rid of the ridiculous quick-sort routine. group is
391 quite useful by itself I think it was John's idea originally though I
392 believe the lazy version is due to me [surprisingly complicated].
393 gamma [used to be called] is called gamma because I got inspired by
394 the Gamma calculus. It is not very close to the calculus but does
395 behave less sequentially than both foldr and foldl. One could imagine
396 a version of gamma that took a unit element as well thereby avoiding
397 the problem with empty lists.
399 I've tried this code against
401 1) insertion sort - as provided by haskell
402 2) the normal implementation of quick sort
403 3) a deforested version of quick sort due to Jan Sparud
404 4) a super-optimized-quick-sort of Lennart's
406 If the list is partially sorted both merge sort and in particular
407 natural merge sort wins. If the list is random [ average length of
408 rising subsequences = approx 2 ] mergesort still wins and natural
409 merge sort is marginally beaten by Lennart's soqs. The space
410 consumption of merge sort is a bit worse than Lennart's quick sort
411 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
412 fpca article ] isn't used because of group.
419 group :: (a -> a -> Bool) -> [a] -> [[a]]
420 -- Given a <= function, group finds maximal contiguous up-runs
421 -- or down-runs in the input list.
422 -- It's stable, in the sense that it never re-orders equal elements
424 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
425 -- From: Andy Gill <andy@dcs.gla.ac.uk>
426 -- Here is a `better' definition of group.
429 group p (x:xs) = group' xs x x (x :)
431 group' [] _ _ s = [s []]
432 group' (x:xs) x_min x_max s
433 | x_max `p` x = group' xs x_min x (s . (x :))
434 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
435 | otherwise = s [] : group' xs x x (x :)
436 -- NB: the 'not' is essential for stablity
437 -- x `p` x_min would reverse equal elements
439 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
440 generalMerge _ xs [] = xs
441 generalMerge _ [] ys = ys
442 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
443 | otherwise = y : generalMerge p (x:xs) ys
445 -- gamma is now called balancedFold
447 balancedFold :: (a -> a -> a) -> [a] -> a
448 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
449 balancedFold _ [x] = x
450 balancedFold f l = balancedFold f (balancedFold' f l)
452 balancedFold' :: (a -> a -> a) -> [a] -> [a]
453 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
454 balancedFold' _ xs = xs
456 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
457 generalNaturalMergeSort _ [] = []
458 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
461 generalMergeSort p [] = []
462 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
464 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
466 mergeSort = generalMergeSort (<=)
467 naturalMergeSort = generalNaturalMergeSort (<=)
469 mergeSortLe le = generalMergeSort le
472 sortLe :: (a->a->Bool) -> [a] -> [a]
473 sortLe le = generalNaturalMergeSort le
475 sortWith :: Ord b => (a->b) -> [a] -> [a]
476 sortWith get_key xs = sortLe le xs
478 x `le` y = get_key x < get_key y
480 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
481 on cmp sel = \x y -> sel x `cmp` sel y
485 %************************************************************************
487 \subsection[Utils-transitive-closure]{Transitive closure}
489 %************************************************************************
491 This algorithm for transitive closure is straightforward, albeit quadratic.
494 transitiveClosure :: (a -> [a]) -- Successor function
495 -> (a -> a -> Bool) -- Equality predicate
497 -> [a] -- The transitive closure
499 transitiveClosure succ eq xs
503 go done (x:xs) | x `is_in` done = go done xs
504 | otherwise = go (x:done) (succ x ++ xs)
507 x `is_in` (y:ys) | eq x y = True
508 | otherwise = x `is_in` ys
511 %************************************************************************
513 \subsection[Utils-accum]{Accumulating}
515 %************************************************************************
517 A combination of foldl with zip. It works with equal length lists.
520 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
522 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
523 foldl2 _ _ _ _ = panic "Util: foldl2"
525 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
526 -- True if the lists are the same length, and
527 -- all corresponding elements satisfy the predicate
529 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
533 Count the number of times a predicate is true
536 count :: (a -> Bool) -> [a] -> Int
538 count p (x:xs) | p x = 1 + count p xs
539 | otherwise = count p xs
542 @splitAt@, @take@, and @drop@ but with length of another
543 list giving the break-off point:
546 takeList :: [b] -> [a] -> [a]
551 (y:ys) -> y : takeList xs ys
553 dropList :: [b] -> [a] -> [a]
555 dropList _ xs@[] = xs
556 dropList (_:xs) (_:ys) = dropList xs ys
559 splitAtList :: [b] -> [a] -> ([a], [a])
560 splitAtList [] xs = ([], xs)
561 splitAtList _ xs@[] = (xs, xs)
562 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
564 (ys', ys'') = splitAtList xs ys
566 snocView :: [a] -> Maybe ([a],a)
567 -- Split off the last element
568 snocView [] = Nothing
569 snocView xs = go [] xs
571 -- Invariant: second arg is non-empty
572 go acc [x] = Just (reverse acc, x)
573 go acc (x:xs) = go (x:acc) xs
574 go _ [] = panic "Util: snocView"
576 split :: Char -> String -> [String]
577 split c s = case rest of
579 _:rest -> chunk : split c rest
580 where (chunk, rest) = break (==c) s
584 %************************************************************************
586 \subsection[Utils-comparison]{Comparisons}
588 %************************************************************************
591 isEqual :: Ordering -> Bool
592 -- Often used in (isEqual (a `compare` b))
597 thenCmp :: Ordering -> Ordering -> Ordering
598 {-# INLINE thenCmp #-}
599 thenCmp EQ ordering = ordering
600 thenCmp ordering _ = ordering
602 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
603 eqListBy _ [] [] = True
604 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
605 eqListBy _ _ _ = False
607 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
608 -- `cmpList' uses a user-specified comparer
613 cmpList cmp (a:as) (b:bs)
614 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
618 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
619 -- This definition can be removed once we require at least 6.8 to build.
620 maybePrefixMatch :: String -> String -> Maybe String
621 maybePrefixMatch [] rest = Just rest
622 maybePrefixMatch (_:_) [] = Nothing
623 maybePrefixMatch (p:pat) (r:rest)
624 | p == r = maybePrefixMatch pat rest
625 | otherwise = Nothing
627 removeSpaces :: String -> String
628 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
631 %************************************************************************
633 \subsection[Utils-pairs]{Pairs}
635 %************************************************************************
638 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
639 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
643 seqList :: [a] -> b -> b
645 seqList (x:xs) b = x `seq` seqList xs b
651 global :: a -> IORef a
652 global a = unsafePerformIO (newIORef a)
656 consIORef :: IORef [a] -> a -> IO ()
659 writeIORef var (x:xs)
665 looksLikeModuleName :: String -> Bool
666 looksLikeModuleName [] = False
667 looksLikeModuleName (c:cs) = isUpper c && go cs
669 go ('.':cs) = looksLikeModuleName cs
670 go (c:cs) = (isAlphaNum c || c == '_') && go cs
673 Akin to @Prelude.words@, but acts like the Bourne shell, treating
674 quoted strings as Haskell Strings, and also parses Haskell [String]
678 getCmd :: String -> Either String -- Error
679 (String, String) -- (Cmd, Rest)
680 getCmd s = case break isSpace $ dropWhile isSpace s of
681 ([], _) -> Left ("Couldn't find command in " ++ show s)
684 toCmdArgs :: String -> Either String -- Error
685 (String, [String]) -- (Cmd, Args)
686 toCmdArgs s = case getCmd s of
688 Right (cmd, s') -> case toArgs s' of
690 Right args -> Right (cmd, args)
692 toArgs :: String -> Either String -- Error
695 = case dropWhile isSpace str of
696 s@('[':_) -> case reads s of
698 | all isSpace spaces ->
701 Left ("Couldn't read " ++ show str ++ "as [String]")
704 toArgs' s = case dropWhile isSpace s of
706 ('"' : _) -> case reads s of
708 -- rest must either be [] or start with a space
709 | all isSpace (take 1 rest) ->
712 Right args -> Right (arg : args)
714 Left ("Couldn't read " ++ show s ++ "as String")
715 s' -> case break isSpace s' of
716 (arg, s'') -> case toArgs' s'' of
718 Right args -> Right (arg : args)
721 -- -----------------------------------------------------------------------------
725 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
726 readRational__ r = do
729 return ((n%1)*10^^(k-d), t)
732 (ds,s) <- lexDecDigits r
733 (ds',t) <- lexDotDigits s
734 return (read (ds++ds'), length ds', t)
736 readExp (e:s) | e `elem` "eE" = readExp' s
737 readExp s = return (0,s)
739 readExp' ('+':s) = readDec s
740 readExp' ('-':s) = do (k,t) <- readDec s
742 readExp' s = readDec s
745 (ds,r) <- nonnull isDigit s
746 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
749 lexDecDigits = nonnull isDigit
751 lexDotDigits ('.':s) = return (span isDigit s)
752 lexDotDigits s = return ("",s)
754 nonnull p s = do (cs@(_:_),t) <- return (span p s)
757 readRational :: String -> Rational -- NB: *does* handle a leading "-"
760 '-' : xs -> - (read_me xs)
764 = case (do { (x,"") <- readRational__ s ; return x }) of
766 [] -> error ("readRational: no parse:" ++ top_s)
767 _ -> error ("readRational: ambiguous parse:" ++ top_s)
770 -----------------------------------------------------------------------------
771 -- Create a hierarchy of directories
773 createDirectoryHierarchy :: FilePath -> IO ()
774 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
775 createDirectoryHierarchy dir = do
776 b <- doesDirectoryExist dir
777 unless b $ do createDirectoryHierarchy (takeDirectory dir)
780 -----------------------------------------------------------------------------
781 -- Verify that the 'dirname' portion of a FilePath exists.
783 doesDirNameExist :: FilePath -> IO Bool
784 doesDirNameExist fpath = case takeDirectory fpath of
785 "" -> return True -- XXX Hack
786 _ -> doesDirectoryExist (takeDirectory fpath)
788 -- -----------------------------------------------------------------------------
791 later :: IO b -> IO a -> IO a
794 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
795 handleDyn = flip catchDyn
797 handle :: (Exception -> IO a) -> IO a -> IO a
798 handle h f = f `Exception.catch` \e -> case e of
799 ExitException _ -> throw e
802 -- --------------------------------------------------------------
803 -- check existence & modification time at the same time
805 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
806 modificationTimeIfExists f = do
807 (do t <- getModificationTime f; return (Just t))
808 `IO.catch` \e -> if isDoesNotExistError e
812 -- split a string at the last character where 'pred' is True,
813 -- returning a pair of strings. The first component holds the string
814 -- up (but not including) the last character for which 'pred' returned
815 -- True, the second whatever comes after (but also not including the
818 -- If 'pred' returns False for all characters in the string, the original
819 -- string is returned in the first component (and the second one is just
821 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
822 splitLongestPrefix str pred
823 | null r_pre = (str, [])
824 | otherwise = (reverse (tail r_pre), reverse r_suf)
825 -- 'tail' drops the char satisfying 'pred'
826 where (r_suf, r_pre) = break pred (reverse str)
828 escapeSpaces :: String -> String
829 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
833 --------------------------------------------------------------
835 --------------------------------------------------------------
837 -- | The function splits the given string to substrings
838 -- using the 'searchPathSeparator'.
839 parseSearchPath :: String -> [FilePath]
840 parseSearchPath path = split path
842 split :: String -> [String]
846 _:rest -> chunk : split rest
850 #ifdef mingw32_HOST_OS
851 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
855 (chunk', rest') = break (==searchPathSeparator) s
857 -- | A platform-specific character used to separate search path strings in
858 -- environment variables. The separator is a colon (\":\") on Unix and
859 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
860 searchPathSeparator :: Char
861 #if mingw32_HOST_OS || mingw32_TARGET_OS
862 searchPathSeparator = ';'
864 searchPathSeparator = ':'
867 data Direction = Forwards | Backwards
869 reslash :: Direction -> FilePath -> FilePath
871 where f ('/' : xs) = slash : f xs
872 f ('\\' : xs) = slash : f xs
873 f (x : xs) = x : f xs