2 % (c) The University of Glasgow 1992-2002
4 \section[Util]{Highly random utility functions}
9 -- general list processing
10 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
11 zipLazy, stretchZipWith,
13 mapAndUnzip, mapAndUnzip3,
16 lengthExceeds, lengthIs, lengthAtLeast,
17 listLengthCmp, atLength, equalLength, compareLength,
19 isSingleton, only, singleton,
30 -- transitive closures
34 mapAccumL, mapAccumR, mapAccumB,
37 takeList, dropList, splitAtList, split,
41 thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
57 -- Floating point stuff
61 createDirectoryHierarchy,
63 modificationTimeIfExists,
65 later, handleDyn, handle,
69 splitFilename, suffixOf, basenameOf, joinFileExt,
70 splitFilenameDir, joinFileName,
73 replaceFilenameSuffix, directoryOf, filenameOf,
74 replaceFilenameDirectory,
75 escapeSpaces, isPathSeparator,
77 normalisePath, platformPath, pgmPath,
80 #include "HsVersions.h"
82 import Panic ( panic, trace )
85 import EXCEPTION ( Exception(..), finally, throwDyn, catchDyn, throw )
86 import qualified EXCEPTION as Exception
87 import DYNAMIC ( Typeable )
88 import DATA_IOREF ( IORef, newIORef )
89 import UNSAFE_IO ( unsafePerformIO )
90 import DATA_IOREF ( readIORef, writeIORef )
92 import qualified List ( elem, notElem )
95 import List ( zipWith4 )
99 import IO ( catch, isDoesNotExistError )
100 import Directory ( doesDirectoryExist, createDirectory )
101 import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
103 import Time ( ClockTime )
104 import Directory ( getModificationTime )
109 %************************************************************************
111 \subsection{The Eager monad}
113 %************************************************************************
115 The @Eager@ monad is just an encoding of continuation-passing style,
116 used to allow you to express "do this and then that", mainly to avoid
117 space leaks. It's done with a type synonym to save bureaucracy.
122 type Eager ans a = (a -> ans) -> ans
124 runEager :: Eager a a -> a
125 runEager m = m (\x -> x)
127 appEager :: Eager ans a -> (a -> ans) -> ans
128 appEager m cont = m cont
130 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
131 thenEager m k cont = m (\r -> k r cont)
133 returnEager :: a -> Eager ans a
134 returnEager v cont = cont v
136 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
137 mapEager f [] = returnEager []
138 mapEager f (x:xs) = f x `thenEager` \ y ->
139 mapEager f xs `thenEager` \ ys ->
144 %************************************************************************
146 \subsection{A for loop}
148 %************************************************************************
151 -- Compose a function with itself n times. (nth rather than twice)
152 nTimes :: Int -> (a -> a) -> (a -> a)
155 nTimes n f = f . nTimes (n-1) f
158 %************************************************************************
160 \subsection[Utils-lists]{General list processing}
162 %************************************************************************
165 filterOut :: (a->Bool) -> [a] -> [a]
166 -- Like filter, only reverses the sense of the test
168 filterOut p (x:xs) | p x = filterOut p xs
169 | otherwise = x : filterOut p xs
172 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
173 are of equal length. Alastair Reid thinks this should only happen if
174 DEBUGging on; hey, why not?
177 zipEqual :: String -> [a] -> [b] -> [(a,b)]
178 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
179 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
180 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
184 zipWithEqual _ = zipWith
185 zipWith3Equal _ = zipWith3
186 zipWith4Equal _ = zipWith4
188 zipEqual msg [] [] = []
189 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
190 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
192 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
193 zipWithEqual msg _ [] [] = []
194 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
196 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
197 = z a b c : zipWith3Equal msg z as bs cs
198 zipWith3Equal msg _ [] [] [] = []
199 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
201 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
202 = z a b c d : zipWith4Equal msg z as bs cs ds
203 zipWith4Equal msg _ [] [] [] [] = []
204 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
209 -- zipLazy is lazy in the second list (observe the ~)
211 zipLazy :: [a] -> [b] -> [(a,b)]
213 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
218 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
219 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
220 -- the places where p returns *True*
222 stretchZipWith p z f [] ys = []
223 stretchZipWith p z f (x:xs) ys
224 | p x = f x z : stretchZipWith p z f xs ys
225 | otherwise = case ys of
227 (y:ys) -> f x y : stretchZipWith p z f xs ys
232 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
233 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
235 mapFst f xys = [(f x, y) | (x,y) <- xys]
236 mapSnd f xys = [(x, f y) | (x,y) <- xys]
238 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
240 mapAndUnzip f [] = ([],[])
244 (rs1, rs2) = mapAndUnzip f xs
248 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
250 mapAndUnzip3 f [] = ([],[],[])
251 mapAndUnzip3 f (x:xs)
254 (rs1, rs2, rs3) = mapAndUnzip3 f xs
256 (r1:rs1, r2:rs2, r3:rs3)
260 nOfThem :: Int -> a -> [a]
261 nOfThem n thing = replicate n thing
263 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
266 -- atLength atLenPred atEndPred ls n
267 -- | n < 0 = atLenPred n
268 -- | length ls < n = atEndPred (n - length ls)
269 -- | otherwise = atLenPred (drop n ls)
271 atLength :: ([a] -> b)
276 atLength atLenPred atEndPred ls n
277 | n < 0 = atEndPred n
278 | otherwise = go n ls
280 go n [] = atEndPred n
281 go 0 ls = atLenPred ls
282 go n (_:xs) = go (n-1) xs
285 lengthExceeds :: [a] -> Int -> Bool
286 -- (lengthExceeds xs n) = (length xs > n)
287 lengthExceeds = atLength notNull (const False)
289 lengthAtLeast :: [a] -> Int -> Bool
290 lengthAtLeast = atLength notNull (== 0)
292 lengthIs :: [a] -> Int -> Bool
293 lengthIs = atLength null (==0)
295 listLengthCmp :: [a] -> Int -> Ordering
296 listLengthCmp = atLength atLen atEnd
300 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
306 equalLength :: [a] -> [b] -> Bool
307 equalLength [] [] = True
308 equalLength (_:xs) (_:ys) = equalLength xs ys
309 equalLength xs ys = False
311 compareLength :: [a] -> [b] -> Ordering
312 compareLength [] [] = EQ
313 compareLength (_:xs) (_:ys) = compareLength xs ys
314 compareLength [] _ys = LT
315 compareLength _xs [] = GT
317 ----------------------------
318 singleton :: a -> [a]
321 isSingleton :: [a] -> Bool
322 isSingleton [x] = True
323 isSingleton _ = False
325 notNull :: [a] -> Bool
337 Debugging/specialising versions of \tr{elem} and \tr{notElem}
340 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
343 isIn msg x ys = elem__ x ys
344 isn'tIn msg x ys = notElem__ x ys
346 --these are here to be SPECIALIZEd (automagically)
348 elem__ x (y:ys) = x==y || elem__ x ys
350 notElem__ x [] = True
351 notElem__ x (y:ys) = x /= y && notElem__ x ys
355 = elem (_ILIT 0) x ys
359 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
361 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
364 = notElem (_ILIT 0) x ys
366 notElem i x [] = True
368 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
369 x `List.notElem` (y:ys)
370 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
374 %************************************************************************
376 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
378 %************************************************************************
381 Date: Mon, 3 May 93 20:45:23 +0200
382 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
383 To: partain@dcs.gla.ac.uk
384 Subject: natural merge sort beats quick sort [ and it is prettier ]
386 Here is a piece of Haskell code that I'm rather fond of. See it as an
387 attempt to get rid of the ridiculous quick-sort routine. group is
388 quite useful by itself I think it was John's idea originally though I
389 believe the lazy version is due to me [surprisingly complicated].
390 gamma [used to be called] is called gamma because I got inspired by
391 the Gamma calculus. It is not very close to the calculus but does
392 behave less sequentially than both foldr and foldl. One could imagine
393 a version of gamma that took a unit element as well thereby avoiding
394 the problem with empty lists.
396 I've tried this code against
398 1) insertion sort - as provided by haskell
399 2) the normal implementation of quick sort
400 3) a deforested version of quick sort due to Jan Sparud
401 4) a super-optimized-quick-sort of Lennart's
403 If the list is partially sorted both merge sort and in particular
404 natural merge sort wins. If the list is random [ average length of
405 rising subsequences = approx 2 ] mergesort still wins and natural
406 merge sort is marginally beaten by Lennart's soqs. The space
407 consumption of merge sort is a bit worse than Lennart's quick sort
408 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
409 fpca article ] isn't used because of group.
416 group :: (a -> a -> Bool) -> [a] -> [[a]]
417 -- Given a <= function, group finds maximal contiguous up-runs
418 -- or down-runs in the input list.
419 -- It's stable, in the sense that it never re-orders equal elements
421 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
422 -- From: Andy Gill <andy@dcs.gla.ac.uk>
423 -- Here is a `better' definition of group.
426 group p (x:xs) = group' xs x x (x :)
428 group' [] _ _ s = [s []]
429 group' (x:xs) x_min x_max s
430 | x_max `p` x = group' xs x_min x (s . (x :))
431 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
432 | otherwise = s [] : group' xs x x (x :)
433 -- NB: the 'not' is essential for stablity
434 -- x `p` x_min would reverse equal elements
436 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
437 generalMerge p xs [] = xs
438 generalMerge p [] ys = ys
439 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
440 | otherwise = y : generalMerge p (x:xs) ys
442 -- gamma is now called balancedFold
444 balancedFold :: (a -> a -> a) -> [a] -> a
445 balancedFold f [] = error "can't reduce an empty list using balancedFold"
446 balancedFold f [x] = x
447 balancedFold f l = balancedFold f (balancedFold' f l)
449 balancedFold' :: (a -> a -> a) -> [a] -> [a]
450 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
451 balancedFold' f xs = xs
453 generalNaturalMergeSort p [] = []
454 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
457 generalMergeSort p [] = []
458 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
460 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
462 mergeSort = generalMergeSort (<=)
463 naturalMergeSort = generalNaturalMergeSort (<=)
465 mergeSortLe le = generalMergeSort le
468 sortLe :: (a->a->Bool) -> [a] -> [a]
469 sortLe le = generalNaturalMergeSort le
471 sortWith :: Ord b => (a->b) -> [a] -> [a]
472 sortWith get_key xs = sortLe le xs
474 x `le` y = get_key x < get_key y
477 %************************************************************************
479 \subsection[Utils-transitive-closure]{Transitive closure}
481 %************************************************************************
483 This algorithm for transitive closure is straightforward, albeit quadratic.
486 transitiveClosure :: (a -> [a]) -- Successor function
487 -> (a -> a -> Bool) -- Equality predicate
489 -> [a] -- The transitive closure
491 transitiveClosure succ eq xs
495 go done (x:xs) | x `is_in` done = go done xs
496 | otherwise = go (x:done) (succ x ++ xs)
499 x `is_in` (y:ys) | eq x y = True
500 | otherwise = x `is_in` ys
503 %************************************************************************
505 \subsection[Utils-accum]{Accumulating}
507 %************************************************************************
509 @mapAccumL@ behaves like a combination
510 of @map@ and @foldl@;
511 it applies a function to each element of a list, passing an accumulating
512 parameter from left to right, and returning a final value of this
513 accumulator together with the new list.
516 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
517 -- and accumulator, returning new
518 -- accumulator and elt of result list
519 -> acc -- Initial accumulator
521 -> (acc, [y]) -- Final accumulator and result list
523 mapAccumL f b [] = (b, [])
524 mapAccumL f b (x:xs) = (b'', x':xs') where
526 (b'', xs') = mapAccumL f b' xs
529 @mapAccumR@ does the same, but working from right to left instead. Its type is
530 the same as @mapAccumL@, though.
533 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
534 -- and accumulator, returning new
535 -- accumulator and elt of result list
536 -> acc -- Initial accumulator
538 -> (acc, [y]) -- Final accumulator and result list
540 mapAccumR f b [] = (b, [])
541 mapAccumR f b (x:xs) = (b'', x':xs') where
543 (b', xs') = mapAccumR f b xs
546 Here is the bi-directional version, that works from both left and right.
549 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
550 -- Function of elt of input list
551 -- and accumulator, returning new
552 -- accumulator and elt of result list
553 -> accl -- Initial accumulator from left
554 -> accr -- Initial accumulator from right
556 -> (accl, accr, [y]) -- Final accumulators and result list
558 mapAccumB f a b [] = (a,b,[])
559 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
561 (a',b'',y) = f a b' x
562 (a'',b',ys) = mapAccumB f a' b xs
565 A strict version of foldl.
568 foldl' :: (a -> b -> a) -> a -> [b] -> a
569 foldl' f z xs = lgo z xs
572 lgo z (x:xs) = (lgo $! (f z x)) xs
575 A combination of foldl with zip. It works with equal length lists.
578 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
580 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
582 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
583 -- True if the lists are the same length, and
584 -- all corresponding elements satisfy the predicate
586 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
590 Count the number of times a predicate is true
593 count :: (a -> Bool) -> [a] -> Int
595 count p (x:xs) | p x = 1 + count p xs
596 | otherwise = count p xs
599 @splitAt@, @take@, and @drop@ but with length of another
600 list giving the break-off point:
603 takeList :: [b] -> [a] -> [a]
608 (y:ys) -> y : takeList xs ys
610 dropList :: [b] -> [a] -> [a]
612 dropList _ xs@[] = xs
613 dropList (_:xs) (_:ys) = dropList xs ys
616 splitAtList :: [b] -> [a] -> ([a], [a])
617 splitAtList [] xs = ([], xs)
618 splitAtList _ xs@[] = (xs, xs)
619 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
621 (ys', ys'') = splitAtList xs ys
623 snocView :: [a] -> Maybe ([a],a)
624 -- Split off the last element
625 snocView [] = Nothing
626 snocView xs = go [] xs
628 -- Invariant: second arg is non-empty
629 go acc [x] = Just (reverse acc, x)
630 go acc (x:xs) = go (x:acc) xs
632 split :: Char -> String -> [String]
633 split c s = case rest of
635 _:rest -> chunk : split c rest
636 where (chunk, rest) = break (==c) s
640 %************************************************************************
642 \subsection[Utils-comparison]{Comparisons}
644 %************************************************************************
647 isEqual :: Ordering -> Bool
648 -- Often used in (isEqual (a `compare` b))
653 thenCmp :: Ordering -> Ordering -> Ordering
654 {-# INLINE thenCmp #-}
656 thenCmp other any = other
658 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
659 eqListBy eq [] [] = True
660 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
661 eqListBy eq xs ys = False
663 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
664 -- `cmpList' uses a user-specified comparer
666 cmpList cmp [] [] = EQ
667 cmpList cmp [] _ = LT
668 cmpList cmp _ [] = GT
669 cmpList cmp (a:as) (b:bs)
670 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
674 prefixMatch :: Eq a => [a] -> [a] -> Bool
675 prefixMatch [] _str = True
676 prefixMatch _pat [] = False
677 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
680 maybePrefixMatch :: String -> String -> Maybe String
681 maybePrefixMatch [] rest = Just rest
682 maybePrefixMatch (_:_) [] = Nothing
683 maybePrefixMatch (p:pat) (r:rest)
684 | p == r = maybePrefixMatch pat rest
685 | otherwise = Nothing
687 suffixMatch :: Eq a => [a] -> [a] -> Bool
688 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
690 removeSpaces :: String -> String
691 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
694 %************************************************************************
696 \subsection[Utils-pairs]{Pairs}
698 %************************************************************************
700 The following are curried versions of @fst@ and @snd@.
704 cfst :: a -> b -> a -- stranal-sem only (Note)
709 The following provide us higher order functions that, when applied
710 to a function, operate on pairs.
714 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
715 applyToPair (f,g) (x,y) = (f x, g y)
717 applyToFst :: (a -> c) -> (a,b)-> (c,b)
718 applyToFst f (x,y) = (f x,y)
720 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
721 applyToSnd f (x,y) = (x,f y)
726 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
727 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
731 seqList :: [a] -> b -> b
733 seqList (x:xs) b = x `seq` seqList xs b
739 global :: a -> IORef a
740 global a = unsafePerformIO (newIORef a)
744 consIORef :: IORef [a] -> a -> IO ()
747 writeIORef var (x:xs)
753 looksLikeModuleName [] = False
754 looksLikeModuleName (c:cs) = isUpper c && go cs
756 go ('.':cs) = looksLikeModuleName cs
757 go (c:cs) = (isAlphaNum c || c == '_') && go cs
760 Akin to @Prelude.words@, but acts like the Bourne shell, treating
761 quoted strings and escaped characters within the input as solid blocks
762 of characters. Doesn't raise any exceptions on malformed escapes or
766 toArgs :: String -> [String]
769 case dropWhile isSpace s of -- drop initial spacing
770 [] -> [] -- empty, so no more tokens
771 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
773 -- Grab a token off the string, given that the first character exists and
774 -- isn't whitespace. The second argument is an accumulator which has to be
775 -- reversed at the end.
776 token [] acc = (reverse acc,[]) -- out of characters
777 token ('\\':c:aft) acc -- escapes
778 = token aft ((escape c) : acc)
779 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
780 = let (aft',acc') = quote q aft acc in token aft' acc'
781 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
783 token (c:aft) acc -- anything else goes in the token
786 -- Get the appropriate character for a single-character escape.
792 -- Read into accumulator until a quote character is found.
794 let quote' [] acc = ([],acc)
795 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
796 quote' (c:aft) acc | c == qc = (aft,acc)
797 quote' (c:aft) acc = quote' aft (c:acc)
801 -- -----------------------------------------------------------------------------
805 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
806 readRational__ r = do
809 return ((n%1)*10^^(k-d), t)
812 (ds,s) <- lexDecDigits r
813 (ds',t) <- lexDotDigits s
814 return (read (ds++ds'), length ds', t)
816 readExp (e:s) | e `elem` "eE" = readExp' s
817 readExp s = return (0,s)
819 readExp' ('+':s) = readDec s
820 readExp' ('-':s) = do
823 readExp' s = readDec s
826 (ds,r) <- nonnull isDigit s
827 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
830 lexDecDigits = nonnull isDigit
832 lexDotDigits ('.':s) = return (span isDigit s)
833 lexDotDigits s = return ("",s)
835 nonnull p s = do (cs@(_:_),t) <- return (span p s)
838 readRational :: String -> Rational -- NB: *does* handle a leading "-"
841 '-' : xs -> - (read_me xs)
845 = case (do { (x,"") <- readRational__ s ; return x }) of
847 [] -> error ("readRational: no parse:" ++ top_s)
848 _ -> error ("readRational: ambiguous parse:" ++ top_s)
851 -----------------------------------------------------------------------------
852 -- Create a hierarchy of directories
854 createDirectoryHierarchy :: FilePath -> IO ()
855 createDirectoryHierarchy dir = do
856 b <- doesDirectoryExist dir
858 createDirectoryHierarchy (directoryOf dir)
861 -----------------------------------------------------------------------------
862 -- Verify that the 'dirname' portion of a FilePath exists.
864 doesDirNameExist :: FilePath -> IO Bool
865 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
867 -- -----------------------------------------------------------------------------
872 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
873 handleDyn = flip catchDyn
875 handle :: (Exception -> IO a) -> IO a -> IO a
876 #if __GLASGOW_HASKELL__ < 501
877 handle = flip Exception.catchAllIO
879 handle h f = f `Exception.catch` \e -> case e of
880 ExitException _ -> throw e
884 -- --------------------------------------------------------------
885 -- check existence & modification time at the same time
887 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
888 modificationTimeIfExists f = do
889 (do t <- getModificationTime f; return (Just t))
890 `IO.catch` \e -> if isDoesNotExistError e
894 -- --------------------------------------------------------------
895 -- Filename manipulation
897 -- Filenames are kept "normalised" inside GHC, using '/' as the path
898 -- separator. On Windows these functions will also recognise '\\' as
899 -- the path separator, but will generally construct paths using '/'.
903 splitFilename :: String -> (String,Suffix)
904 splitFilename f = splitLongestPrefix f (=='.')
906 basenameOf :: FilePath -> String
907 basenameOf = fst . splitFilename
909 suffixOf :: FilePath -> Suffix
910 suffixOf = snd . splitFilename
912 joinFileExt :: String -> String -> FilePath
913 joinFileExt path "" = path
914 joinFileExt path ext = path ++ '.':ext
916 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
917 splitFilenameDir :: String -> (String,String)
919 = let (dir, rest) = splitLongestPrefix str isPathSeparator
920 (dir', rest') | null rest = (".", dir)
921 | otherwise = (dir, rest)
924 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
925 splitFilename3 :: String -> (String,String,Suffix)
927 = let (dir, rest) = splitFilenameDir str
928 (name, ext) = splitFilename rest
931 joinFileName :: String -> String -> FilePath
932 joinFileName "" fname = fname
933 joinFileName "." fname = fname
934 joinFileName dir "" = dir
935 joinFileName dir fname = dir ++ '/':fname
937 -- split a string at the last character where 'pred' is True,
938 -- returning a pair of strings. The first component holds the string
939 -- up (but not including) the last character for which 'pred' returned
940 -- True, the second whatever comes after (but also not including the
943 -- If 'pred' returns False for all characters in the string, the original
944 -- string is returned in the first component (and the second one is just
946 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
947 splitLongestPrefix str pred
948 | null r_pre = (str, [])
949 | otherwise = (reverse (tail r_pre), reverse r_suf)
950 -- 'tail' drops the char satisfying 'pred'
952 (r_suf, r_pre) = break pred (reverse str)
954 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
955 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
957 -- directoryOf strips the filename off the input string, returning
959 directoryOf :: FilePath -> String
960 directoryOf = fst . splitFilenameDir
962 -- filenameOf strips the directory off the input string, returning
964 filenameOf :: FilePath -> String
965 filenameOf = snd . splitFilenameDir
967 replaceFilenameDirectory :: FilePath -> String -> FilePath
968 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
970 escapeSpaces :: String -> String
971 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
973 isPathSeparator :: Char -> Bool
975 #ifdef mingw32_TARGET_OS
976 ch == '/' || ch == '\\'
981 --------------------------------------------------------------
983 --------------------------------------------------------------
985 -- | The function splits the given string to substrings
986 -- using the 'searchPathSeparator'.
987 parseSearchPath :: String -> [FilePath]
988 parseSearchPath path = split path
990 split :: String -> [String]
994 _:rest -> chunk : split rest
998 #ifdef mingw32_HOST_OS
999 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1003 (chunk', rest') = break (==searchPathSeparator) s
1005 -- | A platform-specific character used to separate search path strings in
1006 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
1007 -- and a semicolon (\";\") on the Windows operating system.
1008 searchPathSeparator :: Char
1009 #if mingw32_HOST_OS || mingw32_TARGET_OS
1010 searchPathSeparator = ';'
1012 searchPathSeparator = ':'
1015 -----------------------------------------------------------------------------
1016 -- Convert filepath into platform / MSDOS form.
1018 -- We maintain path names in Unix form ('/'-separated) right until
1019 -- the last moment. On Windows we dos-ify them just before passing them
1020 -- to the Windows command.
1022 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1023 -- proved quite awkward. There were a lot more calls to platformPath,
1024 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1025 -- interpreted a command line 'foo\baz' as 'foobaz'.
1027 normalisePath :: String -> String
1028 -- Just changes '\' to '/'
1030 pgmPath :: String -- Directory string in Unix format
1031 -> String -- Program name with no directory separators
1033 -> String -- Program invocation string in native format
1035 #if defined(mingw32_HOST_OS)
1036 --------------------- Windows version ------------------
1037 normalisePath xs = subst '\\' '/' xs
1038 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
1039 platformPath p = subst '/' '\\' p
1041 subst a b ls = map (\ x -> if x == a then b else x) ls
1043 --------------------- Non-Windows version --------------
1044 normalisePath xs = xs
1045 pgmPath dir pgm = dir ++ '/' : pgm
1046 platformPath stuff = stuff
1047 --------------------------------------------------------