2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow 1992-2002
7 -- | Highly random utility functions
9 -- * Flags dependent on the compiler build
10 ghciSupported, debugIsOn, ghciTablesNextToCode, picIsOn,
11 isWindowsHost, isWindowsTarget, isDarwinTarget,
13 -- * General list processing
14 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
15 zipLazy, stretchZipWith,
20 mapAndUnzip, mapAndUnzip3,
21 nOfThem, filterOut, partitionWith, splitEithers,
23 foldl1', foldl2, count, all2,
25 lengthExceeds, lengthIs, lengthAtLeast,
26 listLengthCmp, atLength, equalLength, compareLength,
28 isSingleton, only, singleton,
33 -- * List operations controlled by another list
34 takeList, dropList, splitAtList, split,
48 -- * Transitive closures
57 -- * Argument processing
58 getCmd, toCmdArgs, toArgs,
64 createDirectoryHierarchy,
66 modificationTimeIfExists,
68 global, consIORef, globalMVar, globalEmptyMVar,
70 -- * Filenames and paths
75 Direction(..), reslash,
78 #include "HsVersions.h"
82 import Data.IORef ( IORef, newIORef, atomicModifyIORef )
83 import System.IO.Unsafe ( unsafePerformIO )
84 import Data.List hiding (group)
85 import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar )
88 import qualified Data.List as List ( elem, notElem )
92 import Control.Monad ( unless )
93 import System.IO.Error as IO ( catch, isDoesNotExistError )
94 import System.Directory ( doesDirectoryExist, createDirectory,
96 import System.FilePath
97 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
98 import Data.Ratio ( (%) )
99 import System.Time ( ClockTime )
104 %************************************************************************
106 \subsection{Is DEBUG on, are we on Windows, etc?}
108 %************************************************************************
110 These booleans are global constants, set by CPP flags. They allow us to
111 recompile a single module (this one) to change whether or not debug output
112 appears. They sometimes let us avoid even running CPP elsewhere.
114 It's important that the flags are literal constants (True/False). Then,
115 with -0, tests of the flags in other modules will simplify to the correct
116 branch of the conditional, thereby dropping debug code altogether when
120 ghciSupported :: Bool
124 ghciSupported = False
134 ghciTablesNextToCode :: Bool
135 #ifdef GHCI_TABLES_NEXT_TO_CODE
136 ghciTablesNextToCode = True
138 ghciTablesNextToCode = False
148 isWindowsHost :: Bool
149 #ifdef mingw32_HOST_OS
152 isWindowsHost = False
155 isWindowsTarget :: Bool
156 #ifdef mingw32_TARGET_OS
157 isWindowsTarget = True
159 isWindowsTarget = False
162 isDarwinTarget :: Bool
163 #ifdef darwin_TARGET_OS
164 isDarwinTarget = True
166 isDarwinTarget = False
170 %************************************************************************
172 \subsection{A for loop}
174 %************************************************************************
177 -- | Compose a function with itself n times. (nth rather than twice)
178 nTimes :: Int -> (a -> a) -> (a -> a)
181 nTimes n f = f . nTimes (n-1) f
184 %************************************************************************
186 \subsection[Utils-lists]{General list processing}
188 %************************************************************************
191 filterOut :: (a->Bool) -> [a] -> [a]
192 -- ^ Like filter, only it reverses the sense of the test
194 filterOut p (x:xs) | p x = filterOut p xs
195 | otherwise = x : filterOut p xs
197 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
198 -- ^ Uses a function to determine which of two output lists an input element should join
199 partitionWith _ [] = ([],[])
200 partitionWith f (x:xs) = case f x of
202 Right c -> (bs, c:cs)
203 where (bs,cs) = partitionWith f xs
205 splitEithers :: [Either a b] -> ([a], [b])
206 -- ^ Teases a list of 'Either's apart into two lists
207 splitEithers [] = ([],[])
208 splitEithers (e : es) = case e of
210 Right y -> (xs, y:ys)
211 where (xs,ys) = splitEithers es
214 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
215 are of equal length. Alastair Reid thinks this should only happen if
216 DEBUGging on; hey, why not?
219 zipEqual :: String -> [a] -> [b] -> [(a,b)]
220 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
221 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
222 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
226 zipWithEqual _ = zipWith
227 zipWith3Equal _ = zipWith3
228 zipWith4Equal _ = zipWith4
230 zipEqual _ [] [] = []
231 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
232 zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)
234 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
235 zipWithEqual _ _ [] [] = []
236 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
238 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
239 = z a b c : zipWith3Equal msg z as bs cs
240 zipWith3Equal _ _ [] [] [] = []
241 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
243 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
244 = z a b c d : zipWith4Equal msg z as bs cs ds
245 zipWith4Equal _ _ [] [] [] [] = []
246 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
251 -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
252 zipLazy :: [a] -> [b] -> [(a,b)]
254 -- We want to write this, but with GHC 6.4 we get a warning, so it
256 -- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
257 -- so we write this instead:
258 zipLazy (x:xs) zs = let y : ys = zs
259 in (x,y) : zipLazy xs ys
264 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
265 -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
266 -- the places where @p@ returns @True@
268 stretchZipWith _ _ _ [] _ = []
269 stretchZipWith p z f (x:xs) ys
270 | p x = f x z : stretchZipWith p z f xs ys
271 | otherwise = case ys of
273 (y:ys) -> f x y : stretchZipWith p z f xs ys
278 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
279 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
281 mapFst f xys = [(f x, y) | (x,y) <- xys]
282 mapSnd f xys = [(x, f y) | (x,y) <- xys]
284 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
286 mapAndUnzip _ [] = ([], [])
289 (rs1, rs2) = mapAndUnzip f xs
293 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
295 mapAndUnzip3 _ [] = ([], [], [])
296 mapAndUnzip3 f (x:xs)
297 = let (r1, r2, r3) = f x
298 (rs1, rs2, rs3) = mapAndUnzip3 f xs
300 (r1:rs1, r2:rs2, r3:rs3)
304 nOfThem :: Int -> a -> [a]
305 nOfThem n thing = replicate n thing
307 -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
310 -- atLength atLenPred atEndPred ls n
311 -- | n < 0 = atLenPred n
312 -- | length ls < n = atEndPred (n - length ls)
313 -- | otherwise = atLenPred (drop n ls)
315 atLength :: ([a] -> b)
320 atLength atLenPred atEndPred ls n
321 | n < 0 = atEndPred n
322 | otherwise = go n ls
324 go n [] = atEndPred n
325 go 0 ls = atLenPred ls
326 go n (_:xs) = go (n-1) xs
328 -- Some special cases of atLength:
330 lengthExceeds :: [a] -> Int -> Bool
331 -- ^ > (lengthExceeds xs n) = (length xs > n)
332 lengthExceeds = atLength notNull (const False)
334 lengthAtLeast :: [a] -> Int -> Bool
335 lengthAtLeast = atLength notNull (== 0)
337 lengthIs :: [a] -> Int -> Bool
338 lengthIs = atLength null (==0)
340 listLengthCmp :: [a] -> Int -> Ordering
341 listLengthCmp = atLength atLen atEnd
345 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
351 equalLength :: [a] -> [b] -> Bool
352 equalLength [] [] = True
353 equalLength (_:xs) (_:ys) = equalLength xs ys
354 equalLength _ _ = False
356 compareLength :: [a] -> [b] -> Ordering
357 compareLength [] [] = EQ
358 compareLength (_:xs) (_:ys) = compareLength xs ys
359 compareLength [] _ = LT
360 compareLength _ [] = GT
362 ----------------------------
363 singleton :: a -> [a]
366 isSingleton :: [a] -> Bool
367 isSingleton [_] = True
368 isSingleton _ = False
370 notNull :: [a] -> Bool
380 only _ = panic "Util: only"
383 Debugging/specialising versions of \tr{elem} and \tr{notElem}
386 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
389 isIn _msg x ys = x `elem` ys
390 isn'tIn _msg x ys = x `notElem` ys
394 = elem100 (_ILIT(0)) x ys
396 elem100 _ _ [] = False
398 | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
400 | otherwise = x == y || elem100 (i +# _ILIT(1)) x ys
403 = notElem100 (_ILIT(0)) x ys
405 notElem100 _ _ [] = True
406 notElem100 i x (y:ys)
407 | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
409 | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys
413 %************************************************************************
415 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
417 %************************************************************************
420 Date: Mon, 3 May 93 20:45:23 +0200
421 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
422 To: partain@dcs.gla.ac.uk
423 Subject: natural merge sort beats quick sort [ and it is prettier ]
425 Here is a piece of Haskell code that I'm rather fond of. See it as an
426 attempt to get rid of the ridiculous quick-sort routine. group is
427 quite useful by itself I think it was John's idea originally though I
428 believe the lazy version is due to me [surprisingly complicated].
429 gamma [used to be called] is called gamma because I got inspired by
430 the Gamma calculus. It is not very close to the calculus but does
431 behave less sequentially than both foldr and foldl. One could imagine
432 a version of gamma that took a unit element as well thereby avoiding
433 the problem with empty lists.
435 I've tried this code against
437 1) insertion sort - as provided by haskell
438 2) the normal implementation of quick sort
439 3) a deforested version of quick sort due to Jan Sparud
440 4) a super-optimized-quick-sort of Lennart's
442 If the list is partially sorted both merge sort and in particular
443 natural merge sort wins. If the list is random [ average length of
444 rising subsequences = approx 2 ] mergesort still wins and natural
445 merge sort is marginally beaten by Lennart's soqs. The space
446 consumption of merge sort is a bit worse than Lennart's quick sort
447 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
448 fpca article ] isn't used because of group.
455 group :: (a -> a -> Bool) -> [a] -> [[a]]
456 -- Given a <= function, group finds maximal contiguous up-runs
457 -- or down-runs in the input list.
458 -- It's stable, in the sense that it never re-orders equal elements
460 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
461 -- From: Andy Gill <andy@dcs.gla.ac.uk>
462 -- Here is a `better' definition of group.
465 group p (x:xs) = group' xs x x (x :)
467 group' [] _ _ s = [s []]
468 group' (x:xs) x_min x_max s
469 | x_max `p` x = group' xs x_min x (s . (x :))
470 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
471 | otherwise = s [] : group' xs x x (x :)
472 -- NB: the 'not' is essential for stablity
473 -- x `p` x_min would reverse equal elements
475 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
476 generalMerge _ xs [] = xs
477 generalMerge _ [] ys = ys
478 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
479 | otherwise = y : generalMerge p (x:xs) ys
481 -- gamma is now called balancedFold
483 balancedFold :: (a -> a -> a) -> [a] -> a
484 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
485 balancedFold _ [x] = x
486 balancedFold f l = balancedFold f (balancedFold' f l)
488 balancedFold' :: (a -> a -> a) -> [a] -> [a]
489 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
490 balancedFold' _ xs = xs
492 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
493 generalNaturalMergeSort _ [] = []
494 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
497 generalMergeSort p [] = []
498 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
500 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
502 mergeSort = generalMergeSort (<=)
503 naturalMergeSort = generalNaturalMergeSort (<=)
505 mergeSortLe le = generalMergeSort le
508 sortLe :: (a->a->Bool) -> [a] -> [a]
509 sortLe le = generalNaturalMergeSort le
511 sortWith :: Ord b => (a->b) -> [a] -> [a]
512 sortWith get_key xs = sortLe le xs
514 x `le` y = get_key x < get_key y
516 on :: (a -> a -> c) -> (b -> a) -> b -> b -> c
517 on cmp sel = \x y -> sel x `cmp` sel y
521 %************************************************************************
523 \subsection[Utils-transitive-closure]{Transitive closure}
525 %************************************************************************
527 This algorithm for transitive closure is straightforward, albeit quadratic.
530 transitiveClosure :: (a -> [a]) -- Successor function
531 -> (a -> a -> Bool) -- Equality predicate
533 -> [a] -- The transitive closure
535 transitiveClosure succ eq xs
539 go done (x:xs) | x `is_in` done = go done xs
540 | otherwise = go (x:done) (succ x ++ xs)
543 x `is_in` (y:ys) | eq x y = True
544 | otherwise = x `is_in` ys
547 %************************************************************************
549 \subsection[Utils-accum]{Accumulating}
551 %************************************************************************
553 A combination of foldl with zip. It works with equal length lists.
556 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
558 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
559 foldl2 _ _ _ _ = panic "Util: foldl2"
561 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
562 -- True if the lists are the same length, and
563 -- all corresponding elements satisfy the predicate
565 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
569 Count the number of times a predicate is true
572 count :: (a -> Bool) -> [a] -> Int
574 count p (x:xs) | p x = 1 + count p xs
575 | otherwise = count p xs
578 @splitAt@, @take@, and @drop@ but with length of another
579 list giving the break-off point:
582 takeList :: [b] -> [a] -> [a]
587 (y:ys) -> y : takeList xs ys
589 dropList :: [b] -> [a] -> [a]
591 dropList _ xs@[] = xs
592 dropList (_:xs) (_:ys) = dropList xs ys
595 splitAtList :: [b] -> [a] -> ([a], [a])
596 splitAtList [] xs = ([], xs)
597 splitAtList _ xs@[] = (xs, xs)
598 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
600 (ys', ys'') = splitAtList xs ys
602 -- drop from the end of a list
603 dropTail :: Int -> [a] -> [a]
604 dropTail n = reverse . drop n . reverse
606 snocView :: [a] -> Maybe ([a],a)
607 -- Split off the last element
608 snocView [] = Nothing
609 snocView xs = go [] xs
611 -- Invariant: second arg is non-empty
612 go acc [x] = Just (reverse acc, x)
613 go acc (x:xs) = go (x:acc) xs
614 go _ [] = panic "Util: snocView"
616 split :: Char -> String -> [String]
617 split c s = case rest of
619 _:rest -> chunk : split c rest
620 where (chunk, rest) = break (==c) s
624 %************************************************************************
626 \subsection[Utils-comparison]{Comparisons}
628 %************************************************************************
631 isEqual :: Ordering -> Bool
632 -- Often used in (isEqual (a `compare` b))
637 thenCmp :: Ordering -> Ordering -> Ordering
638 {-# INLINE thenCmp #-}
639 thenCmp EQ ordering = ordering
640 thenCmp ordering _ = ordering
642 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
643 eqListBy _ [] [] = True
644 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
645 eqListBy _ _ _ = False
647 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
648 -- `cmpList' uses a user-specified comparer
653 cmpList cmp (a:as) (b:bs)
654 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
658 removeSpaces :: String -> String
659 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
662 %************************************************************************
664 \subsection[Utils-pairs]{Pairs}
666 %************************************************************************
669 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
670 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
674 seqList :: [a] -> b -> b
676 seqList (x:xs) b = x `seq` seqList xs b
682 global :: a -> IORef a
683 global a = unsafePerformIO (newIORef a)
687 consIORef :: IORef [a] -> a -> IO ()
689 atomicModifyIORef var (\xs -> (x:xs,()))
693 globalMVar :: a -> MVar a
694 globalMVar a = unsafePerformIO (newMVar a)
696 globalEmptyMVar :: MVar a
697 globalEmptyMVar = unsafePerformIO newEmptyMVar
703 looksLikeModuleName :: String -> Bool
704 looksLikeModuleName [] = False
705 looksLikeModuleName (c:cs) = isUpper c && go cs
707 go ('.':cs) = looksLikeModuleName cs
708 go (c:cs) = (isAlphaNum c || c == '_') && go cs
711 Akin to @Prelude.words@, but acts like the Bourne shell, treating
712 quoted strings as Haskell Strings, and also parses Haskell [String]
716 getCmd :: String -> Either String -- Error
717 (String, String) -- (Cmd, Rest)
718 getCmd s = case break isSpace $ dropWhile isSpace s of
719 ([], _) -> Left ("Couldn't find command in " ++ show s)
722 toCmdArgs :: String -> Either String -- Error
723 (String, [String]) -- (Cmd, Args)
724 toCmdArgs s = case getCmd s of
726 Right (cmd, s') -> case toArgs s' of
728 Right args -> Right (cmd, args)
730 toArgs :: String -> Either String -- Error
733 = case dropWhile isSpace str of
734 s@('[':_) -> case reads s of
736 | all isSpace spaces ->
739 Left ("Couldn't read " ++ show str ++ "as [String]")
742 toArgs' s = case dropWhile isSpace s of
744 ('"' : _) -> case reads s of
746 -- rest must either be [] or start with a space
747 | all isSpace (take 1 rest) ->
750 Right args -> Right (arg : args)
752 Left ("Couldn't read " ++ show s ++ "as String")
753 s' -> case break isSpace s' of
754 (arg, s'') -> case toArgs' s'' of
756 Right args -> Right (arg : args)
759 -- -----------------------------------------------------------------------------
763 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
764 readRational__ r = do
767 return ((n%1)*10^^(k-d), t)
770 (ds,s) <- lexDecDigits r
771 (ds',t) <- lexDotDigits s
772 return (read (ds++ds'), length ds', t)
774 readExp (e:s) | e `elem` "eE" = readExp' s
775 readExp s = return (0,s)
777 readExp' ('+':s) = readDec s
778 readExp' ('-':s) = do (k,t) <- readDec s
780 readExp' s = readDec s
783 (ds,r) <- nonnull isDigit s
784 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
787 lexDecDigits = nonnull isDigit
789 lexDotDigits ('.':s) = return (span isDigit s)
790 lexDotDigits s = return ("",s)
792 nonnull p s = do (cs@(_:_),t) <- return (span p s)
795 readRational :: String -> Rational -- NB: *does* handle a leading "-"
798 '-' : xs -> - (read_me xs)
802 = case (do { (x,"") <- readRational__ s ; return x }) of
804 [] -> error ("readRational: no parse:" ++ top_s)
805 _ -> error ("readRational: ambiguous parse:" ++ top_s)
808 -----------------------------------------------------------------------------
809 -- Create a hierarchy of directories
811 createDirectoryHierarchy :: FilePath -> IO ()
812 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
813 createDirectoryHierarchy dir = do
814 b <- doesDirectoryExist dir
815 unless b $ do createDirectoryHierarchy (takeDirectory dir)
818 -----------------------------------------------------------------------------
819 -- Verify that the 'dirname' portion of a FilePath exists.
821 doesDirNameExist :: FilePath -> IO Bool
822 doesDirNameExist fpath = case takeDirectory fpath of
823 "" -> return True -- XXX Hack
824 _ -> doesDirectoryExist (takeDirectory fpath)
826 -- --------------------------------------------------------------
827 -- check existence & modification time at the same time
829 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
830 modificationTimeIfExists f = do
831 (do t <- getModificationTime f; return (Just t))
832 `IO.catch` \e -> if isDoesNotExistError e
836 -- split a string at the last character where 'pred' is True,
837 -- returning a pair of strings. The first component holds the string
838 -- up (but not including) the last character for which 'pred' returned
839 -- True, the second whatever comes after (but also not including the
842 -- If 'pred' returns False for all characters in the string, the original
843 -- string is returned in the first component (and the second one is just
845 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
846 splitLongestPrefix str pred
847 | null r_pre = (str, [])
848 | otherwise = (reverse (tail r_pre), reverse r_suf)
849 -- 'tail' drops the char satisfying 'pred'
850 where (r_suf, r_pre) = break pred (reverse str)
852 escapeSpaces :: String -> String
853 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
857 --------------------------------------------------------------
859 --------------------------------------------------------------
861 -- | The function splits the given string to substrings
862 -- using the 'searchPathSeparator'.
863 parseSearchPath :: String -> [FilePath]
864 parseSearchPath path = split path
866 split :: String -> [String]
870 _:rest -> chunk : split rest
874 #ifdef mingw32_HOST_OS
875 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
879 (chunk', rest') = break isSearchPathSeparator s
881 data Direction = Forwards | Backwards
883 reslash :: Direction -> FilePath -> FilePath
885 where f ('/' : xs) = slash : f xs
886 f ('\\' : xs) = slash : f xs
887 f (x : xs) = x : f xs