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,
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
182 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
183 are of equal length. Alastair Reid thinks this should only happen if
184 DEBUGging on; hey, why not?
187 zipEqual :: String -> [a] -> [b] -> [(a,b)]
188 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
189 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
190 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
194 zipWithEqual _ = zipWith
195 zipWith3Equal _ = zipWith3
196 zipWith4Equal _ = zipWith4
198 zipEqual msg [] [] = []
199 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
200 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
202 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
203 zipWithEqual msg _ [] [] = []
204 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
206 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
207 = z a b c : zipWith3Equal msg z as bs cs
208 zipWith3Equal msg _ [] [] [] = []
209 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
211 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
212 = z a b c d : zipWith4Equal msg z as bs cs ds
213 zipWith4Equal msg _ [] [] [] [] = []
214 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
219 -- zipLazy is lazy in the second list (observe the ~)
221 zipLazy :: [a] -> [b] -> [(a,b)]
223 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
228 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
229 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
230 -- the places where p returns *True*
232 stretchZipWith p z f [] ys = []
233 stretchZipWith p z f (x:xs) ys
234 | p x = f x z : stretchZipWith p z f xs ys
235 | otherwise = case ys of
237 (y:ys) -> f x y : stretchZipWith p z f xs ys
242 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
243 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
245 mapFst f xys = [(f x, y) | (x,y) <- xys]
246 mapSnd f xys = [(x, f y) | (x,y) <- xys]
248 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
250 mapAndUnzip f [] = ([],[])
254 (rs1, rs2) = mapAndUnzip f xs
258 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
260 mapAndUnzip3 f [] = ([],[],[])
261 mapAndUnzip3 f (x:xs)
264 (rs1, rs2, rs3) = mapAndUnzip3 f xs
266 (r1:rs1, r2:rs2, r3:rs3)
270 nOfThem :: Int -> a -> [a]
271 nOfThem n thing = replicate n thing
273 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
276 -- atLength atLenPred atEndPred ls n
277 -- | n < 0 = atLenPred n
278 -- | length ls < n = atEndPred (n - length ls)
279 -- | otherwise = atLenPred (drop n ls)
281 atLength :: ([a] -> b)
286 atLength atLenPred atEndPred ls n
287 | n < 0 = atEndPred n
288 | otherwise = go n ls
290 go n [] = atEndPred n
291 go 0 ls = atLenPred ls
292 go n (_:xs) = go (n-1) xs
295 lengthExceeds :: [a] -> Int -> Bool
296 -- (lengthExceeds xs n) = (length xs > n)
297 lengthExceeds = atLength notNull (const False)
299 lengthAtLeast :: [a] -> Int -> Bool
300 lengthAtLeast = atLength notNull (== 0)
302 lengthIs :: [a] -> Int -> Bool
303 lengthIs = atLength null (==0)
305 listLengthCmp :: [a] -> Int -> Ordering
306 listLengthCmp = atLength atLen atEnd
310 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
316 equalLength :: [a] -> [b] -> Bool
317 equalLength [] [] = True
318 equalLength (_:xs) (_:ys) = equalLength xs ys
319 equalLength xs ys = False
321 compareLength :: [a] -> [b] -> Ordering
322 compareLength [] [] = EQ
323 compareLength (_:xs) (_:ys) = compareLength xs ys
324 compareLength [] _ys = LT
325 compareLength _xs [] = GT
327 ----------------------------
328 singleton :: a -> [a]
331 isSingleton :: [a] -> Bool
332 isSingleton [x] = True
333 isSingleton _ = False
335 notNull :: [a] -> Bool
347 Debugging/specialising versions of \tr{elem} and \tr{notElem}
350 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
353 isIn msg x ys = elem__ x ys
354 isn'tIn msg x ys = notElem__ x ys
356 --these are here to be SPECIALIZEd (automagically)
358 elem__ x (y:ys) = x==y || elem__ x ys
360 notElem__ x [] = True
361 notElem__ x (y:ys) = x /= y && notElem__ x ys
365 = elem (_ILIT 0) x ys
369 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
371 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
374 = notElem (_ILIT 0) x ys
376 notElem i x [] = True
378 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
379 x `List.notElem` (y:ys)
380 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
384 %************************************************************************
386 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
388 %************************************************************************
391 Date: Mon, 3 May 93 20:45:23 +0200
392 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
393 To: partain@dcs.gla.ac.uk
394 Subject: natural merge sort beats quick sort [ and it is prettier ]
396 Here is a piece of Haskell code that I'm rather fond of. See it as an
397 attempt to get rid of the ridiculous quick-sort routine. group is
398 quite useful by itself I think it was John's idea originally though I
399 believe the lazy version is due to me [surprisingly complicated].
400 gamma [used to be called] is called gamma because I got inspired by
401 the Gamma calculus. It is not very close to the calculus but does
402 behave less sequentially than both foldr and foldl. One could imagine
403 a version of gamma that took a unit element as well thereby avoiding
404 the problem with empty lists.
406 I've tried this code against
408 1) insertion sort - as provided by haskell
409 2) the normal implementation of quick sort
410 3) a deforested version of quick sort due to Jan Sparud
411 4) a super-optimized-quick-sort of Lennart's
413 If the list is partially sorted both merge sort and in particular
414 natural merge sort wins. If the list is random [ average length of
415 rising subsequences = approx 2 ] mergesort still wins and natural
416 merge sort is marginally beaten by Lennart's soqs. The space
417 consumption of merge sort is a bit worse than Lennart's quick sort
418 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
419 fpca article ] isn't used because of group.
426 group :: (a -> a -> Bool) -> [a] -> [[a]]
427 -- Given a <= function, group finds maximal contiguous up-runs
428 -- or down-runs in the input list.
429 -- It's stable, in the sense that it never re-orders equal elements
431 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
432 -- From: Andy Gill <andy@dcs.gla.ac.uk>
433 -- Here is a `better' definition of group.
436 group p (x:xs) = group' xs x x (x :)
438 group' [] _ _ s = [s []]
439 group' (x:xs) x_min x_max s
440 | x_max `p` x = group' xs x_min x (s . (x :))
441 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
442 | otherwise = s [] : group' xs x x (x :)
443 -- NB: the 'not' is essential for stablity
444 -- x `p` x_min would reverse equal elements
446 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
447 generalMerge p xs [] = xs
448 generalMerge p [] ys = ys
449 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
450 | otherwise = y : generalMerge p (x:xs) ys
452 -- gamma is now called balancedFold
454 balancedFold :: (a -> a -> a) -> [a] -> a
455 balancedFold f [] = error "can't reduce an empty list using balancedFold"
456 balancedFold f [x] = x
457 balancedFold f l = balancedFold f (balancedFold' f l)
459 balancedFold' :: (a -> a -> a) -> [a] -> [a]
460 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
461 balancedFold' f xs = xs
463 generalNaturalMergeSort p [] = []
464 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
467 generalMergeSort p [] = []
468 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
470 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
472 mergeSort = generalMergeSort (<=)
473 naturalMergeSort = generalNaturalMergeSort (<=)
475 mergeSortLe le = generalMergeSort le
478 sortLe :: (a->a->Bool) -> [a] -> [a]
479 sortLe le = generalNaturalMergeSort le
481 sortWith :: Ord b => (a->b) -> [a] -> [a]
482 sortWith get_key xs = sortLe le xs
484 x `le` y = get_key x < get_key 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 @mapAccumL@ behaves like a combination
520 of @map@ and @foldl@;
521 it applies a function to each element of a list, passing an accumulating
522 parameter from left to right, and returning a final value of this
523 accumulator together with the new list.
526 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
527 -- and accumulator, returning new
528 -- accumulator and elt of result list
529 -> acc -- Initial accumulator
531 -> (acc, [y]) -- Final accumulator and result list
533 mapAccumL f b [] = (b, [])
534 mapAccumL f b (x:xs) = (b'', x':xs') where
536 (b'', xs') = mapAccumL f b' xs
539 @mapAccumR@ does the same, but working from right to left instead. Its type is
540 the same as @mapAccumL@, though.
543 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
544 -- and accumulator, returning new
545 -- accumulator and elt of result list
546 -> acc -- Initial accumulator
548 -> (acc, [y]) -- Final accumulator and result list
550 mapAccumR f b [] = (b, [])
551 mapAccumR f b (x:xs) = (b'', x':xs') where
553 (b', xs') = mapAccumR f b xs
556 Here is the bi-directional version, that works from both left and right.
559 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
560 -- Function of elt of input list
561 -- and accumulator, returning new
562 -- accumulator and elt of result list
563 -> accl -- Initial accumulator from left
564 -> accr -- Initial accumulator from right
566 -> (accl, accr, [y]) -- Final accumulators and result list
568 mapAccumB f a b [] = (a,b,[])
569 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
571 (a',b'',y) = f a b' x
572 (a'',b',ys) = mapAccumB f a' b xs
575 A strict version of foldl.
578 foldl' :: (a -> b -> a) -> a -> [b] -> a
579 foldl' f z xs = lgo z xs
582 lgo z (x:xs) = (lgo $! (f z x)) xs
585 A combination of foldl with zip. It works with equal length lists.
588 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
590 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
592 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
593 -- True if the lists are the same length, and
594 -- all corresponding elements satisfy the predicate
596 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
600 Count the number of times a predicate is true
603 count :: (a -> Bool) -> [a] -> Int
605 count p (x:xs) | p x = 1 + count p xs
606 | otherwise = count p xs
609 @splitAt@, @take@, and @drop@ but with length of another
610 list giving the break-off point:
613 takeList :: [b] -> [a] -> [a]
618 (y:ys) -> y : takeList xs ys
620 dropList :: [b] -> [a] -> [a]
622 dropList _ xs@[] = xs
623 dropList (_:xs) (_:ys) = dropList xs ys
626 splitAtList :: [b] -> [a] -> ([a], [a])
627 splitAtList [] xs = ([], xs)
628 splitAtList _ xs@[] = (xs, xs)
629 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
631 (ys', ys'') = splitAtList xs ys
633 snocView :: [a] -> Maybe ([a],a)
634 -- Split off the last element
635 snocView [] = Nothing
636 snocView xs = go [] xs
638 -- Invariant: second arg is non-empty
639 go acc [x] = Just (reverse acc, x)
640 go acc (x:xs) = go (x:acc) xs
642 split :: Char -> String -> [String]
643 split c s = case rest of
645 _:rest -> chunk : split c rest
646 where (chunk, rest) = break (==c) s
650 %************************************************************************
652 \subsection[Utils-comparison]{Comparisons}
654 %************************************************************************
657 isEqual :: Ordering -> Bool
658 -- Often used in (isEqual (a `compare` b))
663 thenCmp :: Ordering -> Ordering -> Ordering
664 {-# INLINE thenCmp #-}
666 thenCmp other any = other
668 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
669 eqListBy eq [] [] = True
670 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
671 eqListBy eq xs ys = False
673 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
674 -- `cmpList' uses a user-specified comparer
676 cmpList cmp [] [] = EQ
677 cmpList cmp [] _ = LT
678 cmpList cmp _ [] = GT
679 cmpList cmp (a:as) (b:bs)
680 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
684 prefixMatch :: Eq a => [a] -> [a] -> Bool
685 prefixMatch [] _str = True
686 prefixMatch _pat [] = False
687 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
690 maybePrefixMatch :: String -> String -> Maybe String
691 maybePrefixMatch [] rest = Just rest
692 maybePrefixMatch (_:_) [] = Nothing
693 maybePrefixMatch (p:pat) (r:rest)
694 | p == r = maybePrefixMatch pat rest
695 | otherwise = Nothing
697 suffixMatch :: Eq a => [a] -> [a] -> Bool
698 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
700 removeSpaces :: String -> String
701 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
704 %************************************************************************
706 \subsection[Utils-pairs]{Pairs}
708 %************************************************************************
710 The following are curried versions of @fst@ and @snd@.
714 cfst :: a -> b -> a -- stranal-sem only (Note)
719 The following provide us higher order functions that, when applied
720 to a function, operate on pairs.
724 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
725 applyToPair (f,g) (x,y) = (f x, g y)
727 applyToFst :: (a -> c) -> (a,b)-> (c,b)
728 applyToFst f (x,y) = (f x,y)
730 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
731 applyToSnd f (x,y) = (x,f y)
736 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
737 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
741 seqList :: [a] -> b -> b
743 seqList (x:xs) b = x `seq` seqList xs b
749 global :: a -> IORef a
750 global a = unsafePerformIO (newIORef a)
754 consIORef :: IORef [a] -> a -> IO ()
757 writeIORef var (x:xs)
763 looksLikeModuleName [] = False
764 looksLikeModuleName (c:cs) = isUpper c && go cs
766 go ('.':cs) = looksLikeModuleName cs
767 go (c:cs) = (isAlphaNum c || c == '_') && go cs
770 Akin to @Prelude.words@, but acts like the Bourne shell, treating
771 quoted strings and escaped characters within the input as solid blocks
772 of characters. Doesn't raise any exceptions on malformed escapes or
776 toArgs :: String -> [String]
779 case dropWhile isSpace s of -- drop initial spacing
780 [] -> [] -- empty, so no more tokens
781 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
783 -- Grab a token off the string, given that the first character exists and
784 -- isn't whitespace. The second argument is an accumulator which has to be
785 -- reversed at the end.
786 token [] acc = (reverse acc,[]) -- out of characters
787 token ('\\':c:aft) acc -- escapes
788 = token aft ((escape c) : acc)
789 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
790 = let (aft',acc') = quote q aft acc in token aft' acc'
791 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
793 token (c:aft) acc -- anything else goes in the token
796 -- Get the appropriate character for a single-character escape.
802 -- Read into accumulator until a quote character is found.
804 let quote' [] acc = ([],acc)
805 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
806 quote' (c:aft) acc | c == qc = (aft,acc)
807 quote' (c:aft) acc = quote' aft (c:acc)
811 -- -----------------------------------------------------------------------------
815 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
816 readRational__ r = do
819 return ((n%1)*10^^(k-d), t)
822 (ds,s) <- lexDecDigits r
823 (ds',t) <- lexDotDigits s
824 return (read (ds++ds'), length ds', t)
826 readExp (e:s) | e `elem` "eE" = readExp' s
827 readExp s = return (0,s)
829 readExp' ('+':s) = readDec s
830 readExp' ('-':s) = do
833 readExp' s = readDec s
836 (ds,r) <- nonnull isDigit s
837 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
840 lexDecDigits = nonnull isDigit
842 lexDotDigits ('.':s) = return (span isDigit s)
843 lexDotDigits s = return ("",s)
845 nonnull p s = do (cs@(_:_),t) <- return (span p s)
848 readRational :: String -> Rational -- NB: *does* handle a leading "-"
851 '-' : xs -> - (read_me xs)
855 = case (do { (x,"") <- readRational__ s ; return x }) of
857 [] -> error ("readRational: no parse:" ++ top_s)
858 _ -> error ("readRational: ambiguous parse:" ++ top_s)
861 -----------------------------------------------------------------------------
862 -- Create a hierarchy of directories
864 createDirectoryHierarchy :: FilePath -> IO ()
865 createDirectoryHierarchy dir = do
866 b <- doesDirectoryExist dir
868 createDirectoryHierarchy (directoryOf dir)
871 -----------------------------------------------------------------------------
872 -- Verify that the 'dirname' portion of a FilePath exists.
874 doesDirNameExist :: FilePath -> IO Bool
875 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
877 -- -----------------------------------------------------------------------------
882 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
883 handleDyn = flip catchDyn
885 handle :: (Exception -> IO a) -> IO a -> IO a
886 #if __GLASGOW_HASKELL__ < 501
887 handle = flip Exception.catchAllIO
889 handle h f = f `Exception.catch` \e -> case e of
890 ExitException _ -> throw e
894 -- --------------------------------------------------------------
895 -- check existence & modification time at the same time
897 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
898 modificationTimeIfExists f = do
899 (do t <- getModificationTime f; return (Just t))
900 `IO.catch` \e -> if isDoesNotExistError e
904 -- --------------------------------------------------------------
905 -- Filename manipulation
907 -- Filenames are kept "normalised" inside GHC, using '/' as the path
908 -- separator. On Windows these functions will also recognise '\\' as
909 -- the path separator, but will generally construct paths using '/'.
913 splitFilename :: String -> (String,Suffix)
914 splitFilename f = splitLongestPrefix f (=='.')
916 basenameOf :: FilePath -> String
917 basenameOf = fst . splitFilename
919 suffixOf :: FilePath -> Suffix
920 suffixOf = snd . splitFilename
922 joinFileExt :: String -> String -> FilePath
923 joinFileExt path "" = path
924 joinFileExt path ext = path ++ '.':ext
926 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
927 splitFilenameDir :: String -> (String,String)
929 = let (dir, rest) = splitLongestPrefix str isPathSeparator
930 (dir', rest') | null rest = (".", dir)
931 | otherwise = (dir, rest)
934 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
935 splitFilename3 :: String -> (String,String,Suffix)
937 = let (dir, rest) = splitFilenameDir str
938 (name, ext) = splitFilename rest
941 joinFileName :: String -> String -> FilePath
942 joinFileName "" fname = fname
943 joinFileName "." fname = fname
944 joinFileName dir "" = dir
945 joinFileName dir fname = dir ++ '/':fname
947 -- split a string at the last character where 'pred' is True,
948 -- returning a pair of strings. The first component holds the string
949 -- up (but not including) the last character for which 'pred' returned
950 -- True, the second whatever comes after (but also not including the
953 -- If 'pred' returns False for all characters in the string, the original
954 -- string is returned in the first component (and the second one is just
956 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
957 splitLongestPrefix str pred
958 | null r_pre = (str, [])
959 | otherwise = (reverse (tail r_pre), reverse r_suf)
960 -- 'tail' drops the char satisfying 'pred'
962 (r_suf, r_pre) = break pred (reverse str)
964 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
965 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
967 -- directoryOf strips the filename off the input string, returning
969 directoryOf :: FilePath -> String
970 directoryOf = fst . splitFilenameDir
972 -- filenameOf strips the directory off the input string, returning
974 filenameOf :: FilePath -> String
975 filenameOf = snd . splitFilenameDir
977 replaceFilenameDirectory :: FilePath -> String -> FilePath
978 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
980 escapeSpaces :: String -> String
981 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
983 isPathSeparator :: Char -> Bool
985 #ifdef mingw32_TARGET_OS
986 ch == '/' || ch == '\\'
991 --------------------------------------------------------------
993 --------------------------------------------------------------
995 -- | The function splits the given string to substrings
996 -- using the 'searchPathSeparator'.
997 parseSearchPath :: String -> [FilePath]
998 parseSearchPath path = split path
1000 split :: String -> [String]
1004 _:rest -> chunk : split rest
1008 #ifdef mingw32_HOST_OS
1009 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1013 (chunk', rest') = break (==searchPathSeparator) s
1015 -- | A platform-specific character used to separate search path strings in
1016 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
1017 -- and a semicolon (\";\") on the Windows operating system.
1018 searchPathSeparator :: Char
1019 #if mingw32_HOST_OS || mingw32_TARGET_OS
1020 searchPathSeparator = ';'
1022 searchPathSeparator = ':'
1025 -----------------------------------------------------------------------------
1026 -- Convert filepath into platform / MSDOS form.
1028 -- We maintain path names in Unix form ('/'-separated) right until
1029 -- the last moment. On Windows we dos-ify them just before passing them
1030 -- to the Windows command.
1032 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1033 -- proved quite awkward. There were a lot more calls to platformPath,
1034 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1035 -- interpreted a command line 'foo\baz' as 'foobaz'.
1037 normalisePath :: String -> String
1038 -- Just changes '\' to '/'
1040 pgmPath :: String -- Directory string in Unix format
1041 -> String -- Program name with no directory separators
1043 -> String -- Program invocation string in native format
1045 #if defined(mingw32_HOST_OS)
1046 --------------------- Windows version ------------------
1047 normalisePath xs = subst '\\' '/' xs
1048 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
1049 platformPath p = subst '/' '\\' p
1051 subst a b ls = map (\ x -> if x == a then b else x) ls
1053 --------------------- Non-Windows version --------------
1054 normalisePath xs = xs
1055 pgmPath dir pgm = dir ++ '/' : pgm
1056 platformPath stuff = stuff
1057 --------------------------------------------------------