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 -- XXX This define is a bit of a hack, and should be done more nicely
78 #define FAST_STRING_NOT_NEEDED 1
79 #include "HsVersions.h"
83 import Control.Exception ( Exception(..), finally, catchDyn, throw )
84 import qualified Control.Exception as Exception
85 import Data.Dynamic ( Typeable )
86 import Data.IORef ( IORef, newIORef )
87 import System.IO.Unsafe ( unsafePerformIO )
88 import Data.IORef ( readIORef, writeIORef )
89 import Data.List hiding (group)
91 import qualified Data.List as List ( elem )
93 import qualified Data.List as List ( notElem )
97 import Control.Monad ( unless )
98 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
99 import System.Directory ( doesDirectoryExist, createDirectory,
100 getModificationTime )
101 import System.FilePath hiding ( searchPathSeparator )
102 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
103 import Data.Ratio ( (%) )
104 import System.Time ( ClockTime )
109 %************************************************************************
113 %************************************************************************
124 %************************************************************************
126 \subsection{A for loop}
128 %************************************************************************
131 -- Compose a function with itself n times. (nth rather than twice)
132 nTimes :: Int -> (a -> a) -> (a -> a)
135 nTimes n f = f . nTimes (n-1) f
138 %************************************************************************
140 \subsection[Utils-lists]{General list processing}
142 %************************************************************************
145 filterOut :: (a->Bool) -> [a] -> [a]
146 -- Like filter, only reverses the sense of the test
148 filterOut p (x:xs) | p x = filterOut p xs
149 | otherwise = x : filterOut p xs
151 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
152 partitionWith _ [] = ([],[])
153 partitionWith f (x:xs) = case f x of
155 Right c -> (bs, c:cs)
156 where (bs,cs) = partitionWith f xs
158 splitEithers :: [Either a b] -> ([a], [b])
159 splitEithers [] = ([],[])
160 splitEithers (e : es) = case e of
162 Right y -> (xs, y:ys)
163 where (xs,ys) = splitEithers es
166 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
167 are of equal length. Alastair Reid thinks this should only happen if
168 DEBUGging on; hey, why not?
171 zipEqual :: String -> [a] -> [b] -> [(a,b)]
172 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
173 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
174 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
178 zipWithEqual _ = zipWith
179 zipWith3Equal _ = zipWith3
180 zipWith4Equal _ = zipWith4
182 zipEqual _ [] [] = []
183 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
184 zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)
186 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
187 zipWithEqual _ _ [] [] = []
188 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
190 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
191 = z a b c : zipWith3Equal msg z as bs cs
192 zipWith3Equal _ _ [] [] [] = []
193 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
195 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
196 = z a b c d : zipWith4Equal msg z as bs cs ds
197 zipWith4Equal _ _ [] [] [] [] = []
198 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
203 -- zipLazy is lazy in the second list (observe the ~)
205 zipLazy :: [a] -> [b] -> [(a,b)]
207 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
212 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
213 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
214 -- the places where p returns *True*
216 stretchZipWith _ _ _ [] _ = []
217 stretchZipWith p z f (x:xs) ys
218 | p x = f x z : stretchZipWith p z f xs ys
219 | otherwise = case ys of
221 (y:ys) -> f x y : stretchZipWith p z f xs ys
226 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
227 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
229 mapFst f xys = [(f x, y) | (x,y) <- xys]
230 mapSnd f xys = [(x, f y) | (x,y) <- xys]
232 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
234 mapAndUnzip _ [] = ([], [])
237 (rs1, rs2) = mapAndUnzip f xs
241 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
243 mapAndUnzip3 _ [] = ([], [], [])
244 mapAndUnzip3 f (x:xs)
245 = let (r1, r2, r3) = f x
246 (rs1, rs2, rs3) = mapAndUnzip3 f xs
248 (r1:rs1, r2:rs2, r3:rs3)
252 nOfThem :: Int -> a -> [a]
253 nOfThem n thing = replicate n thing
255 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
258 -- atLength atLenPred atEndPred ls n
259 -- | n < 0 = atLenPred n
260 -- | length ls < n = atEndPred (n - length ls)
261 -- | otherwise = atLenPred (drop n ls)
263 atLength :: ([a] -> b)
268 atLength atLenPred atEndPred ls n
269 | n < 0 = atEndPred n
270 | otherwise = go n ls
272 go n [] = atEndPred n
273 go 0 ls = atLenPred ls
274 go n (_:xs) = go (n-1) xs
277 lengthExceeds :: [a] -> Int -> Bool
278 -- (lengthExceeds xs n) = (length xs > n)
279 lengthExceeds = atLength notNull (const False)
281 lengthAtLeast :: [a] -> Int -> Bool
282 lengthAtLeast = atLength notNull (== 0)
284 lengthIs :: [a] -> Int -> Bool
285 lengthIs = atLength null (==0)
287 listLengthCmp :: [a] -> Int -> Ordering
288 listLengthCmp = atLength atLen atEnd
292 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
298 equalLength :: [a] -> [b] -> Bool
299 equalLength [] [] = True
300 equalLength (_:xs) (_:ys) = equalLength xs ys
301 equalLength _ _ = False
303 compareLength :: [a] -> [b] -> Ordering
304 compareLength [] [] = EQ
305 compareLength (_:xs) (_:ys) = compareLength xs ys
306 compareLength [] _ = LT
307 compareLength _ [] = GT
309 ----------------------------
310 singleton :: a -> [a]
313 isSingleton :: [a] -> Bool
314 isSingleton [_] = True
315 isSingleton _ = False
317 notNull :: [a] -> Bool
327 only _ = panic "Util: only"
330 Debugging/specialising versions of \tr{elem} and \tr{notElem}
333 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
336 isIn _msg x ys = elem__ x ys
337 isn'tIn _msg x ys = notElem__ x ys
339 --these are here to be SPECIALIZEd (automagically)
340 elem__ :: Eq a => a -> [a] -> Bool
342 elem__ x (y:ys) = x == y || elem__ x ys
344 notElem__ :: Eq a => a -> [a] -> Bool
345 notElem__ _ [] = True
346 notElem__ x (y:ys) = x /= y && notElem__ x ys
350 = elem (_ILIT(0)) x ys
354 | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
355 (x `List.elem` (y:ys))
356 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
359 = notElem (_ILIT(0)) x ys
361 notElem _ _ [] = True
363 | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
364 (x `List.notElem` (y:ys))
365 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
369 foldl1' was added in GHC 6.4
372 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604
373 foldl1' :: (a -> a -> a) -> [a] -> a
374 foldl1' f (x:xs) = foldl' f x xs
375 foldl1' _ [] = panic "foldl1'"
379 %************************************************************************
381 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
383 %************************************************************************
386 Date: Mon, 3 May 93 20:45:23 +0200
387 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
388 To: partain@dcs.gla.ac.uk
389 Subject: natural merge sort beats quick sort [ and it is prettier ]
391 Here is a piece of Haskell code that I'm rather fond of. See it as an
392 attempt to get rid of the ridiculous quick-sort routine. group is
393 quite useful by itself I think it was John's idea originally though I
394 believe the lazy version is due to me [surprisingly complicated].
395 gamma [used to be called] is called gamma because I got inspired by
396 the Gamma calculus. It is not very close to the calculus but does
397 behave less sequentially than both foldr and foldl. One could imagine
398 a version of gamma that took a unit element as well thereby avoiding
399 the problem with empty lists.
401 I've tried this code against
403 1) insertion sort - as provided by haskell
404 2) the normal implementation of quick sort
405 3) a deforested version of quick sort due to Jan Sparud
406 4) a super-optimized-quick-sort of Lennart's
408 If the list is partially sorted both merge sort and in particular
409 natural merge sort wins. If the list is random [ average length of
410 rising subsequences = approx 2 ] mergesort still wins and natural
411 merge sort is marginally beaten by Lennart's soqs. The space
412 consumption of merge sort is a bit worse than Lennart's quick sort
413 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
414 fpca article ] isn't used because of group.
421 group :: (a -> a -> Bool) -> [a] -> [[a]]
422 -- Given a <= function, group finds maximal contiguous up-runs
423 -- or down-runs in the input list.
424 -- It's stable, in the sense that it never re-orders equal elements
426 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
427 -- From: Andy Gill <andy@dcs.gla.ac.uk>
428 -- Here is a `better' definition of group.
431 group p (x:xs) = group' xs x x (x :)
433 group' [] _ _ s = [s []]
434 group' (x:xs) x_min x_max s
435 | x_max `p` x = group' xs x_min x (s . (x :))
436 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
437 | otherwise = s [] : group' xs x x (x :)
438 -- NB: the 'not' is essential for stablity
439 -- x `p` x_min would reverse equal elements
441 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
442 generalMerge _ xs [] = xs
443 generalMerge _ [] ys = ys
444 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
445 | otherwise = y : generalMerge p (x:xs) ys
447 -- gamma is now called balancedFold
449 balancedFold :: (a -> a -> a) -> [a] -> a
450 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
451 balancedFold _ [x] = x
452 balancedFold f l = balancedFold f (balancedFold' f l)
454 balancedFold' :: (a -> a -> a) -> [a] -> [a]
455 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
456 balancedFold' _ xs = xs
458 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
459 generalNaturalMergeSort _ [] = []
460 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
463 generalMergeSort p [] = []
464 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
466 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
468 mergeSort = generalMergeSort (<=)
469 naturalMergeSort = generalNaturalMergeSort (<=)
471 mergeSortLe le = generalMergeSort le
474 sortLe :: (a->a->Bool) -> [a] -> [a]
475 sortLe le = generalNaturalMergeSort le
477 sortWith :: Ord b => (a->b) -> [a] -> [a]
478 sortWith get_key xs = sortLe le xs
480 x `le` y = get_key x < get_key y
482 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
483 on cmp sel = \x y -> sel x `cmp` sel y
487 %************************************************************************
489 \subsection[Utils-transitive-closure]{Transitive closure}
491 %************************************************************************
493 This algorithm for transitive closure is straightforward, albeit quadratic.
496 transitiveClosure :: (a -> [a]) -- Successor function
497 -> (a -> a -> Bool) -- Equality predicate
499 -> [a] -- The transitive closure
501 transitiveClosure succ eq xs
505 go done (x:xs) | x `is_in` done = go done xs
506 | otherwise = go (x:done) (succ x ++ xs)
509 x `is_in` (y:ys) | eq x y = True
510 | otherwise = x `is_in` ys
513 %************************************************************************
515 \subsection[Utils-accum]{Accumulating}
517 %************************************************************************
519 A combination of foldl with zip. It works with equal length lists.
522 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
524 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
525 foldl2 _ _ _ _ = panic "Util: foldl2"
527 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
528 -- True if the lists are the same length, and
529 -- all corresponding elements satisfy the predicate
531 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
535 Count the number of times a predicate is true
538 count :: (a -> Bool) -> [a] -> Int
540 count p (x:xs) | p x = 1 + count p xs
541 | otherwise = count p xs
544 @splitAt@, @take@, and @drop@ but with length of another
545 list giving the break-off point:
548 takeList :: [b] -> [a] -> [a]
553 (y:ys) -> y : takeList xs ys
555 dropList :: [b] -> [a] -> [a]
557 dropList _ xs@[] = xs
558 dropList (_:xs) (_:ys) = dropList xs ys
561 splitAtList :: [b] -> [a] -> ([a], [a])
562 splitAtList [] xs = ([], xs)
563 splitAtList _ xs@[] = (xs, xs)
564 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
566 (ys', ys'') = splitAtList xs ys
568 snocView :: [a] -> Maybe ([a],a)
569 -- Split off the last element
570 snocView [] = Nothing
571 snocView xs = go [] xs
573 -- Invariant: second arg is non-empty
574 go acc [x] = Just (reverse acc, x)
575 go acc (x:xs) = go (x:acc) xs
576 go _ [] = panic "Util: snocView"
578 split :: Char -> String -> [String]
579 split c s = case rest of
581 _:rest -> chunk : split c rest
582 where (chunk, rest) = break (==c) s
586 %************************************************************************
588 \subsection[Utils-comparison]{Comparisons}
590 %************************************************************************
593 isEqual :: Ordering -> Bool
594 -- Often used in (isEqual (a `compare` b))
599 thenCmp :: Ordering -> Ordering -> Ordering
600 {-# INLINE thenCmp #-}
601 thenCmp EQ ordering = ordering
602 thenCmp ordering _ = ordering
604 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
605 eqListBy _ [] [] = True
606 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
607 eqListBy _ _ _ = False
609 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
610 -- `cmpList' uses a user-specified comparer
615 cmpList cmp (a:as) (b:bs)
616 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
620 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
621 -- This definition can be removed once we require at least 6.8 to build.
622 maybePrefixMatch :: String -> String -> Maybe String
623 maybePrefixMatch [] rest = Just rest
624 maybePrefixMatch (_:_) [] = Nothing
625 maybePrefixMatch (p:pat) (r:rest)
626 | p == r = maybePrefixMatch pat rest
627 | otherwise = Nothing
629 removeSpaces :: String -> String
630 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
633 %************************************************************************
635 \subsection[Utils-pairs]{Pairs}
637 %************************************************************************
640 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
641 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
645 seqList :: [a] -> b -> b
647 seqList (x:xs) b = x `seq` seqList xs b
653 global :: a -> IORef a
654 global a = unsafePerformIO (newIORef a)
658 consIORef :: IORef [a] -> a -> IO ()
661 writeIORef var (x:xs)
667 looksLikeModuleName :: String -> Bool
668 looksLikeModuleName [] = False
669 looksLikeModuleName (c:cs) = isUpper c && go cs
671 go ('.':cs) = looksLikeModuleName cs
672 go (c:cs) = (isAlphaNum c || c == '_') && go cs
675 Akin to @Prelude.words@, but acts like the Bourne shell, treating
676 quoted strings as Haskell Strings, and also parses Haskell [String]
680 getCmd :: String -> Either String -- Error
681 (String, String) -- (Cmd, Rest)
682 getCmd s = case break isSpace $ dropWhile isSpace s of
683 ([], _) -> Left ("Couldn't find command in " ++ show s)
686 toCmdArgs :: String -> Either String -- Error
687 (String, [String]) -- (Cmd, Args)
688 toCmdArgs s = case getCmd s of
690 Right (cmd, s') -> case toArgs s' of
692 Right args -> Right (cmd, args)
694 toArgs :: String -> Either String -- Error
697 = case dropWhile isSpace str of
698 s@('[':_) -> case reads s of
700 | all isSpace spaces ->
703 Left ("Couldn't read " ++ show str ++ "as [String]")
706 toArgs' s = case dropWhile isSpace s of
708 ('"' : _) -> case reads s of
710 -- rest must either be [] or start with a space
711 | all isSpace (take 1 rest) ->
714 Right args -> Right (arg : args)
716 Left ("Couldn't read " ++ show s ++ "as String")
717 s' -> case break isSpace s' of
718 (arg, s'') -> case toArgs' s'' of
720 Right args -> Right (arg : args)
723 -- -----------------------------------------------------------------------------
727 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
728 readRational__ r = do
731 return ((n%1)*10^^(k-d), t)
734 (ds,s) <- lexDecDigits r
735 (ds',t) <- lexDotDigits s
736 return (read (ds++ds'), length ds', t)
738 readExp (e:s) | e `elem` "eE" = readExp' s
739 readExp s = return (0,s)
741 readExp' ('+':s) = readDec s
742 readExp' ('-':s) = do (k,t) <- readDec s
744 readExp' s = readDec s
747 (ds,r) <- nonnull isDigit s
748 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
751 lexDecDigits = nonnull isDigit
753 lexDotDigits ('.':s) = return (span isDigit s)
754 lexDotDigits s = return ("",s)
756 nonnull p s = do (cs@(_:_),t) <- return (span p s)
759 readRational :: String -> Rational -- NB: *does* handle a leading "-"
762 '-' : xs -> - (read_me xs)
766 = case (do { (x,"") <- readRational__ s ; return x }) of
768 [] -> error ("readRational: no parse:" ++ top_s)
769 _ -> error ("readRational: ambiguous parse:" ++ top_s)
772 -----------------------------------------------------------------------------
773 -- Create a hierarchy of directories
775 createDirectoryHierarchy :: FilePath -> IO ()
776 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
777 createDirectoryHierarchy dir = do
778 b <- doesDirectoryExist dir
779 unless b $ do createDirectoryHierarchy (takeDirectory dir)
782 -----------------------------------------------------------------------------
783 -- Verify that the 'dirname' portion of a FilePath exists.
785 doesDirNameExist :: FilePath -> IO Bool
786 doesDirNameExist fpath = case takeDirectory fpath of
787 "" -> return True -- XXX Hack
788 _ -> doesDirectoryExist (takeDirectory fpath)
790 -- -----------------------------------------------------------------------------
793 later :: IO b -> IO a -> IO a
796 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
797 handleDyn = flip catchDyn
799 handle :: (Exception -> IO a) -> IO a -> IO a
800 handle h f = f `Exception.catch` \e -> case e of
801 ExitException _ -> throw e
804 -- --------------------------------------------------------------
805 -- check existence & modification time at the same time
807 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
808 modificationTimeIfExists f = do
809 (do t <- getModificationTime f; return (Just t))
810 `IO.catch` \e -> if isDoesNotExistError e
814 -- split a string at the last character where 'pred' is True,
815 -- returning a pair of strings. The first component holds the string
816 -- up (but not including) the last character for which 'pred' returned
817 -- True, the second whatever comes after (but also not including the
820 -- If 'pred' returns False for all characters in the string, the original
821 -- string is returned in the first component (and the second one is just
823 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
824 splitLongestPrefix str pred
825 | null r_pre = (str, [])
826 | otherwise = (reverse (tail r_pre), reverse r_suf)
827 -- 'tail' drops the char satisfying 'pred'
828 where (r_suf, r_pre) = break pred (reverse str)
830 escapeSpaces :: String -> String
831 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
835 --------------------------------------------------------------
837 --------------------------------------------------------------
839 -- | The function splits the given string to substrings
840 -- using the 'searchPathSeparator'.
841 parseSearchPath :: String -> [FilePath]
842 parseSearchPath path = split path
844 split :: String -> [String]
848 _:rest -> chunk : split rest
852 #ifdef mingw32_HOST_OS
853 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
857 (chunk', rest') = break (==searchPathSeparator) s
859 -- | A platform-specific character used to separate search path strings in
860 -- environment variables. The separator is a colon (\":\") on Unix and
861 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
862 searchPathSeparator :: Char
863 #if mingw32_HOST_OS || mingw32_TARGET_OS
864 searchPathSeparator = ';'
866 searchPathSeparator = ':'
869 data Direction = Forwards | Backwards
871 reslash :: Direction -> FilePath -> FilePath
873 where f ('/' : xs) = slash : f xs
874 f ('\\' : xs) = slash : f xs
875 f (x : xs) = x : f xs