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,
17 lengthExceeds, lengthIs, lengthAtLeast,
18 listLengthCmp, atLength, equalLength, compareLength,
20 isSingleton, only, singleton,
31 -- transitive closures
35 mapAccumL, mapAccumR, mapAccumB,
38 takeList, dropList, splitAtList, split,
42 thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
58 -- Floating point stuff
62 createDirectoryHierarchy,
64 modificationTimeIfExists,
66 later, handleDyn, handle,
70 splitFilename, suffixOf, basenameOf, joinFileExt,
71 splitFilenameDir, joinFileName,
74 replaceFilenameSuffix, directoryOf, filenameOf,
75 replaceFilenameDirectory,
76 escapeSpaces, isPathSeparator,
78 normalisePath, platformPath, pgmPath,
81 #include "HsVersions.h"
83 import Panic ( panic, trace )
86 import Control.Exception ( Exception(..), finally, catchDyn, throw )
87 import qualified Control.Exception as Exception
88 import Data.Dynamic ( Typeable )
89 import Data.IORef ( IORef, newIORef )
90 import System.IO.Unsafe ( unsafePerformIO )
91 import Data.IORef ( readIORef, writeIORef )
93 import qualified Data.List as List ( elem, notElem )
96 import Data.List ( zipWith4 )
99 import Control.Monad ( when )
100 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
101 import System.Directory ( doesDirectoryExist, createDirectory,
102 getModificationTime )
103 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
104 import Data.Ratio ( (%) )
105 import System.Time ( ClockTime )
110 %************************************************************************
112 \subsection{The Eager monad}
114 %************************************************************************
116 The @Eager@ monad is just an encoding of continuation-passing style,
117 used to allow you to express "do this and then that", mainly to avoid
118 space leaks. It's done with a type synonym to save bureaucracy.
123 type Eager ans a = (a -> ans) -> ans
125 runEager :: Eager a a -> a
126 runEager m = m (\x -> x)
128 appEager :: Eager ans a -> (a -> ans) -> ans
129 appEager m cont = m cont
131 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
132 thenEager m k cont = m (\r -> k r cont)
134 returnEager :: a -> Eager ans a
135 returnEager v cont = cont v
137 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
138 mapEager f [] = returnEager []
139 mapEager f (x:xs) = f x `thenEager` \ y ->
140 mapEager f xs `thenEager` \ ys ->
145 %************************************************************************
147 \subsection{A for loop}
149 %************************************************************************
152 -- Compose a function with itself n times. (nth rather than twice)
153 nTimes :: Int -> (a -> a) -> (a -> a)
156 nTimes n f = f . nTimes (n-1) f
159 %************************************************************************
161 \subsection[Utils-lists]{General list processing}
163 %************************************************************************
166 filterOut :: (a->Bool) -> [a] -> [a]
167 -- Like filter, only reverses the sense of the test
169 filterOut p (x:xs) | p x = filterOut p xs
170 | otherwise = x : filterOut p xs
172 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
173 partitionWith f [] = ([],[])
174 partitionWith f (x:xs) = case f x of
176 Right c -> (bs, c:cs)
178 (bs,cs) = partitionWith f xs
180 splitEithers :: [Either a b] -> ([a], [b])
181 splitEithers [] = ([],[])
182 splitEithers (e : es) = case e of
184 Right y -> (xs, y:ys)
186 (xs,ys) = splitEithers es
189 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
190 are of equal length. Alastair Reid thinks this should only happen if
191 DEBUGging on; hey, why not?
194 zipEqual :: String -> [a] -> [b] -> [(a,b)]
195 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
196 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
197 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
201 zipWithEqual _ = zipWith
202 zipWith3Equal _ = zipWith3
203 zipWith4Equal _ = zipWith4
205 zipEqual msg [] [] = []
206 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
207 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
209 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
210 zipWithEqual msg _ [] [] = []
211 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
213 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
214 = z a b c : zipWith3Equal msg z as bs cs
215 zipWith3Equal msg _ [] [] [] = []
216 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
218 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
219 = z a b c d : zipWith4Equal msg z as bs cs ds
220 zipWith4Equal msg _ [] [] [] [] = []
221 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
226 -- zipLazy is lazy in the second list (observe the ~)
228 zipLazy :: [a] -> [b] -> [(a,b)]
230 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
235 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
236 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
237 -- the places where p returns *True*
239 stretchZipWith p z f [] ys = []
240 stretchZipWith p z f (x:xs) ys
241 | p x = f x z : stretchZipWith p z f xs ys
242 | otherwise = case ys of
244 (y:ys) -> f x y : stretchZipWith p z f xs ys
249 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
250 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
252 mapFst f xys = [(f x, y) | (x,y) <- xys]
253 mapSnd f xys = [(x, f y) | (x,y) <- xys]
255 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
257 mapAndUnzip f [] = ([],[])
261 (rs1, rs2) = mapAndUnzip f xs
265 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
267 mapAndUnzip3 f [] = ([],[],[])
268 mapAndUnzip3 f (x:xs)
271 (rs1, rs2, rs3) = mapAndUnzip3 f xs
273 (r1:rs1, r2:rs2, r3:rs3)
277 nOfThem :: Int -> a -> [a]
278 nOfThem n thing = replicate n thing
280 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
283 -- atLength atLenPred atEndPred ls n
284 -- | n < 0 = atLenPred n
285 -- | length ls < n = atEndPred (n - length ls)
286 -- | otherwise = atLenPred (drop n ls)
288 atLength :: ([a] -> b)
293 atLength atLenPred atEndPred ls n
294 | n < 0 = atEndPred n
295 | otherwise = go n ls
297 go n [] = atEndPred n
298 go 0 ls = atLenPred ls
299 go n (_:xs) = go (n-1) xs
302 lengthExceeds :: [a] -> Int -> Bool
303 -- (lengthExceeds xs n) = (length xs > n)
304 lengthExceeds = atLength notNull (const False)
306 lengthAtLeast :: [a] -> Int -> Bool
307 lengthAtLeast = atLength notNull (== 0)
309 lengthIs :: [a] -> Int -> Bool
310 lengthIs = atLength null (==0)
312 listLengthCmp :: [a] -> Int -> Ordering
313 listLengthCmp = atLength atLen atEnd
317 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
323 equalLength :: [a] -> [b] -> Bool
324 equalLength [] [] = True
325 equalLength (_:xs) (_:ys) = equalLength xs ys
326 equalLength xs ys = False
328 compareLength :: [a] -> [b] -> Ordering
329 compareLength [] [] = EQ
330 compareLength (_:xs) (_:ys) = compareLength xs ys
331 compareLength [] _ys = LT
332 compareLength _xs [] = GT
334 ----------------------------
335 singleton :: a -> [a]
338 isSingleton :: [a] -> Bool
339 isSingleton [x] = True
340 isSingleton _ = False
342 notNull :: [a] -> Bool
354 Debugging/specialising versions of \tr{elem} and \tr{notElem}
357 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
360 isIn msg x ys = elem__ x ys
361 isn'tIn msg x ys = notElem__ x ys
363 --these are here to be SPECIALIZEd (automagically)
365 elem__ x (y:ys) = x==y || elem__ x ys
367 notElem__ x [] = True
368 notElem__ x (y:ys) = x /= y && notElem__ x ys
372 = elem (_ILIT 0) x ys
376 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
378 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
381 = notElem (_ILIT 0) x ys
383 notElem i x [] = True
385 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
386 x `List.notElem` (y:ys)
387 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
391 %************************************************************************
393 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
395 %************************************************************************
398 Date: Mon, 3 May 93 20:45:23 +0200
399 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
400 To: partain@dcs.gla.ac.uk
401 Subject: natural merge sort beats quick sort [ and it is prettier ]
403 Here is a piece of Haskell code that I'm rather fond of. See it as an
404 attempt to get rid of the ridiculous quick-sort routine. group is
405 quite useful by itself I think it was John's idea originally though I
406 believe the lazy version is due to me [surprisingly complicated].
407 gamma [used to be called] is called gamma because I got inspired by
408 the Gamma calculus. It is not very close to the calculus but does
409 behave less sequentially than both foldr and foldl. One could imagine
410 a version of gamma that took a unit element as well thereby avoiding
411 the problem with empty lists.
413 I've tried this code against
415 1) insertion sort - as provided by haskell
416 2) the normal implementation of quick sort
417 3) a deforested version of quick sort due to Jan Sparud
418 4) a super-optimized-quick-sort of Lennart's
420 If the list is partially sorted both merge sort and in particular
421 natural merge sort wins. If the list is random [ average length of
422 rising subsequences = approx 2 ] mergesort still wins and natural
423 merge sort is marginally beaten by Lennart's soqs. The space
424 consumption of merge sort is a bit worse than Lennart's quick sort
425 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
426 fpca article ] isn't used because of group.
433 group :: (a -> a -> Bool) -> [a] -> [[a]]
434 -- Given a <= function, group finds maximal contiguous up-runs
435 -- or down-runs in the input list.
436 -- It's stable, in the sense that it never re-orders equal elements
438 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
439 -- From: Andy Gill <andy@dcs.gla.ac.uk>
440 -- Here is a `better' definition of group.
443 group p (x:xs) = group' xs x x (x :)
445 group' [] _ _ s = [s []]
446 group' (x:xs) x_min x_max s
447 | x_max `p` x = group' xs x_min x (s . (x :))
448 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
449 | otherwise = s [] : group' xs x x (x :)
450 -- NB: the 'not' is essential for stablity
451 -- x `p` x_min would reverse equal elements
453 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
454 generalMerge p xs [] = xs
455 generalMerge p [] ys = ys
456 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
457 | otherwise = y : generalMerge p (x:xs) ys
459 -- gamma is now called balancedFold
461 balancedFold :: (a -> a -> a) -> [a] -> a
462 balancedFold f [] = error "can't reduce an empty list using balancedFold"
463 balancedFold f [x] = x
464 balancedFold f l = balancedFold f (balancedFold' f l)
466 balancedFold' :: (a -> a -> a) -> [a] -> [a]
467 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
468 balancedFold' f xs = xs
470 generalNaturalMergeSort p [] = []
471 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
474 generalMergeSort p [] = []
475 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
477 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
479 mergeSort = generalMergeSort (<=)
480 naturalMergeSort = generalNaturalMergeSort (<=)
482 mergeSortLe le = generalMergeSort le
485 sortLe :: (a->a->Bool) -> [a] -> [a]
486 sortLe le = generalNaturalMergeSort le
488 sortWith :: Ord b => (a->b) -> [a] -> [a]
489 sortWith get_key xs = sortLe le xs
491 x `le` y = get_key x < get_key y
494 %************************************************************************
496 \subsection[Utils-transitive-closure]{Transitive closure}
498 %************************************************************************
500 This algorithm for transitive closure is straightforward, albeit quadratic.
503 transitiveClosure :: (a -> [a]) -- Successor function
504 -> (a -> a -> Bool) -- Equality predicate
506 -> [a] -- The transitive closure
508 transitiveClosure succ eq xs
512 go done (x:xs) | x `is_in` done = go done xs
513 | otherwise = go (x:done) (succ x ++ xs)
516 x `is_in` (y:ys) | eq x y = True
517 | otherwise = x `is_in` ys
520 %************************************************************************
522 \subsection[Utils-accum]{Accumulating}
524 %************************************************************************
526 @mapAccumL@ behaves like a combination
527 of @map@ and @foldl@;
528 it applies a function to each element of a list, passing an accumulating
529 parameter from left to right, and returning a final value of this
530 accumulator together with the new list.
533 mapAccumL :: (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 mapAccumL f b [] = (b, [])
541 mapAccumL f b (x:xs) = (b'', x':xs') where
543 (b'', xs') = mapAccumL f b' xs
546 @mapAccumR@ does the same, but working from right to left instead. Its type is
547 the same as @mapAccumL@, though.
550 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
551 -- and accumulator, returning new
552 -- accumulator and elt of result list
553 -> acc -- Initial accumulator
555 -> (acc, [y]) -- Final accumulator and result list
557 mapAccumR f b [] = (b, [])
558 mapAccumR f b (x:xs) = (b'', x':xs') where
560 (b', xs') = mapAccumR f b xs
563 Here is the bi-directional version, that works from both left and right.
566 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
567 -- Function of elt of input list
568 -- and accumulator, returning new
569 -- accumulator and elt of result list
570 -> accl -- Initial accumulator from left
571 -> accr -- Initial accumulator from right
573 -> (accl, accr, [y]) -- Final accumulators and result list
575 mapAccumB f a b [] = (a,b,[])
576 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
578 (a',b'',y) = f a b' x
579 (a'',b',ys) = mapAccumB f a' b xs
582 A strict version of foldl.
585 foldl' :: (a -> b -> a) -> a -> [b] -> a
586 foldl' f z xs = lgo z xs
589 lgo z (x:xs) = (lgo $! (f z x)) xs
592 A combination of foldl with zip. It works with equal length lists.
595 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
597 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
599 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
600 -- True if the lists are the same length, and
601 -- all corresponding elements satisfy the predicate
603 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
607 Count the number of times a predicate is true
610 count :: (a -> Bool) -> [a] -> Int
612 count p (x:xs) | p x = 1 + count p xs
613 | otherwise = count p xs
616 @splitAt@, @take@, and @drop@ but with length of another
617 list giving the break-off point:
620 takeList :: [b] -> [a] -> [a]
625 (y:ys) -> y : takeList xs ys
627 dropList :: [b] -> [a] -> [a]
629 dropList _ xs@[] = xs
630 dropList (_:xs) (_:ys) = dropList xs ys
633 splitAtList :: [b] -> [a] -> ([a], [a])
634 splitAtList [] xs = ([], xs)
635 splitAtList _ xs@[] = (xs, xs)
636 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
638 (ys', ys'') = splitAtList xs ys
640 snocView :: [a] -> Maybe ([a],a)
641 -- Split off the last element
642 snocView [] = Nothing
643 snocView xs = go [] xs
645 -- Invariant: second arg is non-empty
646 go acc [x] = Just (reverse acc, x)
647 go acc (x:xs) = go (x:acc) xs
649 split :: Char -> String -> [String]
650 split c s = case rest of
652 _:rest -> chunk : split c rest
653 where (chunk, rest) = break (==c) s
657 %************************************************************************
659 \subsection[Utils-comparison]{Comparisons}
661 %************************************************************************
664 isEqual :: Ordering -> Bool
665 -- Often used in (isEqual (a `compare` b))
670 thenCmp :: Ordering -> Ordering -> Ordering
671 {-# INLINE thenCmp #-}
673 thenCmp other any = other
675 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
676 eqListBy eq [] [] = True
677 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
678 eqListBy eq xs ys = False
680 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
681 -- `cmpList' uses a user-specified comparer
683 cmpList cmp [] [] = EQ
684 cmpList cmp [] _ = LT
685 cmpList cmp _ [] = GT
686 cmpList cmp (a:as) (b:bs)
687 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
691 prefixMatch :: Eq a => [a] -> [a] -> Bool
692 prefixMatch [] _str = True
693 prefixMatch _pat [] = False
694 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
697 maybePrefixMatch :: String -> String -> Maybe String
698 maybePrefixMatch [] rest = Just rest
699 maybePrefixMatch (_:_) [] = Nothing
700 maybePrefixMatch (p:pat) (r:rest)
701 | p == r = maybePrefixMatch pat rest
702 | otherwise = Nothing
704 suffixMatch :: Eq a => [a] -> [a] -> Bool
705 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
707 removeSpaces :: String -> String
708 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
711 %************************************************************************
713 \subsection[Utils-pairs]{Pairs}
715 %************************************************************************
717 The following are curried versions of @fst@ and @snd@.
721 cfst :: a -> b -> a -- stranal-sem only (Note)
726 The following provide us higher order functions that, when applied
727 to a function, operate on pairs.
731 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
732 applyToPair (f,g) (x,y) = (f x, g y)
734 applyToFst :: (a -> c) -> (a,b)-> (c,b)
735 applyToFst f (x,y) = (f x,y)
737 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
738 applyToSnd f (x,y) = (x,f y)
743 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
744 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
748 seqList :: [a] -> b -> b
750 seqList (x:xs) b = x `seq` seqList xs b
756 global :: a -> IORef a
757 global a = unsafePerformIO (newIORef a)
761 consIORef :: IORef [a] -> a -> IO ()
764 writeIORef var (x:xs)
770 looksLikeModuleName [] = False
771 looksLikeModuleName (c:cs) = isUpper c && go cs
773 go ('.':cs) = looksLikeModuleName cs
774 go (c:cs) = (isAlphaNum c || c == '_') && go cs
777 Akin to @Prelude.words@, but acts like the Bourne shell, treating
778 quoted strings and escaped characters within the input as solid blocks
779 of characters. Doesn't raise any exceptions on malformed escapes or
783 toArgs :: String -> [String]
786 case dropWhile isSpace s of -- drop initial spacing
787 [] -> [] -- empty, so no more tokens
788 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
790 -- Grab a token off the string, given that the first character exists and
791 -- isn't whitespace. The second argument is an accumulator which has to be
792 -- reversed at the end.
793 token [] acc = (reverse acc,[]) -- out of characters
794 token ('\\':c:aft) acc -- escapes
795 = token aft ((escape c) : acc)
796 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
797 = let (aft',acc') = quote q aft acc in token aft' acc'
798 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
800 token (c:aft) acc -- anything else goes in the token
803 -- Get the appropriate character for a single-character escape.
809 -- Read into accumulator until a quote character is found.
811 let quote' [] acc = ([],acc)
812 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
813 quote' (c:aft) acc | c == qc = (aft,acc)
814 quote' (c:aft) acc = quote' aft (c:acc)
818 -- -----------------------------------------------------------------------------
822 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
823 readRational__ r = do
826 return ((n%1)*10^^(k-d), t)
829 (ds,s) <- lexDecDigits r
830 (ds',t) <- lexDotDigits s
831 return (read (ds++ds'), length ds', t)
833 readExp (e:s) | e `elem` "eE" = readExp' s
834 readExp s = return (0,s)
836 readExp' ('+':s) = readDec s
837 readExp' ('-':s) = do
840 readExp' s = readDec s
843 (ds,r) <- nonnull isDigit s
844 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
847 lexDecDigits = nonnull isDigit
849 lexDotDigits ('.':s) = return (span isDigit s)
850 lexDotDigits s = return ("",s)
852 nonnull p s = do (cs@(_:_),t) <- return (span p s)
855 readRational :: String -> Rational -- NB: *does* handle a leading "-"
858 '-' : xs -> - (read_me xs)
862 = case (do { (x,"") <- readRational__ s ; return x }) of
864 [] -> error ("readRational: no parse:" ++ top_s)
865 _ -> error ("readRational: ambiguous parse:" ++ top_s)
868 -----------------------------------------------------------------------------
869 -- Create a hierarchy of directories
871 createDirectoryHierarchy :: FilePath -> IO ()
872 createDirectoryHierarchy dir = do
873 b <- doesDirectoryExist dir
875 createDirectoryHierarchy (directoryOf dir)
878 -----------------------------------------------------------------------------
879 -- Verify that the 'dirname' portion of a FilePath exists.
881 doesDirNameExist :: FilePath -> IO Bool
882 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
884 -- -----------------------------------------------------------------------------
889 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
890 handleDyn = flip catchDyn
892 handle :: (Exception -> IO a) -> IO a -> IO a
893 handle h f = f `Exception.catch` \e -> case e of
894 ExitException _ -> throw e
897 -- --------------------------------------------------------------
898 -- check existence & modification time at the same time
900 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
901 modificationTimeIfExists f = do
902 (do t <- getModificationTime f; return (Just t))
903 `IO.catch` \e -> if isDoesNotExistError e
907 -- --------------------------------------------------------------
908 -- Filename manipulation
910 -- Filenames are kept "normalised" inside GHC, using '/' as the path
911 -- separator. On Windows these functions will also recognise '\\' as
912 -- the path separator, but will generally construct paths using '/'.
916 splitFilename :: String -> (String,Suffix)
917 splitFilename f = splitLongestPrefix f (=='.')
919 basenameOf :: FilePath -> String
920 basenameOf = fst . splitFilename
922 suffixOf :: FilePath -> Suffix
923 suffixOf = snd . splitFilename
925 joinFileExt :: String -> String -> FilePath
926 joinFileExt path "" = path
927 joinFileExt path ext = path ++ '.':ext
929 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
930 splitFilenameDir :: String -> (String,String)
932 = let (dir, rest) = splitLongestPrefix str isPathSeparator
933 (dir', rest') | null rest = (".", dir)
934 | otherwise = (dir, rest)
937 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
938 splitFilename3 :: String -> (String,String,Suffix)
940 = let (dir, rest) = splitFilenameDir str
941 (name, ext) = splitFilename rest
944 joinFileName :: String -> String -> FilePath
945 joinFileName "" fname = fname
946 joinFileName "." fname = fname
947 joinFileName dir "" = dir
948 joinFileName dir fname = dir ++ '/':fname
950 -- split a string at the last character where 'pred' is True,
951 -- returning a pair of strings. The first component holds the string
952 -- up (but not including) the last character for which 'pred' returned
953 -- True, the second whatever comes after (but also not including the
956 -- If 'pred' returns False for all characters in the string, the original
957 -- string is returned in the first component (and the second one is just
959 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
960 splitLongestPrefix str pred
961 | null r_pre = (str, [])
962 | otherwise = (reverse (tail r_pre), reverse r_suf)
963 -- 'tail' drops the char satisfying 'pred'
965 (r_suf, r_pre) = break pred (reverse str)
967 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
968 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
970 -- directoryOf strips the filename off the input string, returning
972 directoryOf :: FilePath -> String
973 directoryOf = fst . splitFilenameDir
975 -- filenameOf strips the directory off the input string, returning
977 filenameOf :: FilePath -> String
978 filenameOf = snd . splitFilenameDir
980 replaceFilenameDirectory :: FilePath -> String -> FilePath
981 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
983 escapeSpaces :: String -> String
984 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
986 isPathSeparator :: Char -> Bool
988 #ifdef mingw32_TARGET_OS
989 ch == '/' || ch == '\\'
994 --------------------------------------------------------------
996 --------------------------------------------------------------
998 -- | The function splits the given string to substrings
999 -- using the 'searchPathSeparator'.
1000 parseSearchPath :: String -> [FilePath]
1001 parseSearchPath path = split path
1003 split :: String -> [String]
1007 _:rest -> chunk : split rest
1011 #ifdef mingw32_HOST_OS
1012 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1016 (chunk', rest') = break (==searchPathSeparator) s
1018 -- | A platform-specific character used to separate search path strings in
1019 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
1020 -- and a semicolon (\";\") on the Windows operating system.
1021 searchPathSeparator :: Char
1022 #if mingw32_HOST_OS || mingw32_TARGET_OS
1023 searchPathSeparator = ';'
1025 searchPathSeparator = ':'
1028 -----------------------------------------------------------------------------
1029 -- Convert filepath into platform / MSDOS form.
1031 -- We maintain path names in Unix form ('/'-separated) right until
1032 -- the last moment. On Windows we dos-ify them just before passing them
1033 -- to the Windows command.
1035 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1036 -- proved quite awkward. There were a lot more calls to platformPath,
1037 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1038 -- interpreted a command line 'foo\baz' as 'foobaz'.
1040 normalisePath :: String -> String
1041 -- Just changes '\' to '/'
1043 pgmPath :: String -- Directory string in Unix format
1044 -> String -- Program name with no directory separators
1046 -> String -- Program invocation string in native format
1048 #if defined(mingw32_HOST_OS)
1049 --------------------- Windows version ------------------
1050 normalisePath xs = subst '\\' '/' xs
1051 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
1052 platformPath p = subst '/' '\\' p
1054 subst a b ls = map (\ x -> if x == a then b else x) ls
1056 --------------------- Non-Windows version --------------
1057 normalisePath xs = xs
1058 pgmPath dir pgm = dir ++ '/' : pgm
1059 platformPath stuff = stuff
1060 --------------------------------------------------------