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,
15 lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
27 -- transitive closures
31 mapAccumL, mapAccumR, mapAccumB,
34 takeList, dropList, splitAtList, split,
37 isEqual, eqListBy, equalLength, compareLength,
38 thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
54 -- Floating point stuff
58 createDirectoryHierarchy,
60 modificationTimeIfExists,
62 later, handleDyn, handle,
66 splitFilename, suffixOf, basenameOf, joinFileExt,
67 splitFilenameDir, joinFileExt, joinFileName,
70 replaceFilenameSuffix, directoryOf, filenameOf,
71 replaceFilenameDirectory,
72 escapeSpaces, isPathSeparator,
73 normalisePath, platformPath, pgmPath,
76 #include "HsVersions.h"
78 import Panic ( panic, trace )
81 import EXCEPTION ( Exception(..), finally, throwDyn, catchDyn, throw )
82 import qualified EXCEPTION as Exception
83 import DYNAMIC ( Typeable )
84 import DATA_IOREF ( IORef, newIORef )
85 import UNSAFE_IO ( unsafePerformIO )
86 import DATA_IOREF ( readIORef, writeIORef )
88 import qualified List ( elem, notElem )
91 import List ( zipWith4 )
95 import IO ( catch, isDoesNotExistError )
96 import Directory ( doesDirectoryExist, createDirectory )
97 import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
99 import Time ( ClockTime )
100 import Directory ( getModificationTime )
105 %************************************************************************
107 \subsection{The Eager monad}
109 %************************************************************************
111 The @Eager@ monad is just an encoding of continuation-passing style,
112 used to allow you to express "do this and then that", mainly to avoid
113 space leaks. It's done with a type synonym to save bureaucracy.
118 type Eager ans a = (a -> ans) -> ans
120 runEager :: Eager a a -> a
121 runEager m = m (\x -> x)
123 appEager :: Eager ans a -> (a -> ans) -> ans
124 appEager m cont = m cont
126 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
127 thenEager m k cont = m (\r -> k r cont)
129 returnEager :: a -> Eager ans a
130 returnEager v cont = cont v
132 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
133 mapEager f [] = returnEager []
134 mapEager f (x:xs) = f x `thenEager` \ y ->
135 mapEager f xs `thenEager` \ ys ->
140 %************************************************************************
142 \subsection{A for loop}
144 %************************************************************************
147 -- Compose a function with itself n times. (nth rather than twice)
148 nTimes :: Int -> (a -> a) -> (a -> a)
151 nTimes n f = f . nTimes (n-1) f
154 %************************************************************************
156 \subsection[Utils-lists]{General list processing}
158 %************************************************************************
161 filterOut :: (a->Bool) -> [a] -> [a]
162 -- Like filter, only reverses the sense of the test
164 filterOut p (x:xs) | p x = filterOut p xs
165 | otherwise = x : filterOut p xs
168 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
169 are of equal length. Alastair Reid thinks this should only happen if
170 DEBUGging on; hey, why not?
173 zipEqual :: String -> [a] -> [b] -> [(a,b)]
174 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
175 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
176 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
180 zipWithEqual _ = zipWith
181 zipWith3Equal _ = zipWith3
182 zipWith4Equal _ = zipWith4
184 zipEqual msg [] [] = []
185 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
186 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
188 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
189 zipWithEqual msg _ [] [] = []
190 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
192 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
193 = z a b c : zipWith3Equal msg z as bs cs
194 zipWith3Equal msg _ [] [] [] = []
195 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
197 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
198 = z a b c d : zipWith4Equal msg z as bs cs ds
199 zipWith4Equal msg _ [] [] [] [] = []
200 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
205 -- zipLazy is lazy in the second list (observe the ~)
207 zipLazy :: [a] -> [b] -> [(a,b)]
209 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
214 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
215 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
216 -- the places where p returns *True*
218 stretchZipWith p z f [] ys = []
219 stretchZipWith p z f (x:xs) ys
220 | p x = f x z : stretchZipWith p z f xs ys
221 | otherwise = case ys of
223 (y:ys) -> f x y : stretchZipWith p z f xs ys
228 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
229 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
231 mapFst f xys = [(f x, y) | (x,y) <- xys]
232 mapSnd f xys = [(x, f y) | (x,y) <- xys]
234 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
236 mapAndUnzip f [] = ([],[])
240 (rs1, rs2) = mapAndUnzip f xs
244 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
246 mapAndUnzip3 f [] = ([],[],[])
247 mapAndUnzip3 f (x:xs)
250 (rs1, rs2, rs3) = mapAndUnzip3 f xs
252 (r1:rs1, r2:rs2, r3:rs3)
256 nOfThem :: Int -> a -> [a]
257 nOfThem n thing = replicate n thing
259 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
262 -- atLength atLenPred atEndPred ls n
263 -- | n < 0 = atLenPred n
264 -- | length ls < n = atEndPred (n - length ls)
265 -- | otherwise = atLenPred (drop n ls)
267 atLength :: ([a] -> b)
272 atLength atLenPred atEndPred ls n
273 | n < 0 = atEndPred n
274 | otherwise = go n ls
276 go n [] = atEndPred n
277 go 0 ls = atLenPred ls
278 go n (_:xs) = go (n-1) xs
281 lengthExceeds :: [a] -> Int -> Bool
282 -- (lengthExceeds xs n) = (length xs > n)
283 lengthExceeds = atLength notNull (const False)
285 lengthAtLeast :: [a] -> Int -> Bool
286 lengthAtLeast = atLength notNull (== 0)
288 lengthIs :: [a] -> Int -> Bool
289 lengthIs = atLength null (==0)
291 listLengthCmp :: [a] -> Int -> Ordering
292 listLengthCmp = atLength atLen atEnd
296 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
302 isSingleton :: [a] -> Bool
303 isSingleton [x] = True
304 isSingleton _ = False
306 notNull :: [a] -> Bool
310 snocView :: [a] -> Maybe ([a],a)
311 -- Split off the last element
312 snocView [] = Nothing
313 snocView xs = go [] xs
315 -- Invariant: second arg is non-empty
316 go acc [x] = Just (reverse acc, x)
317 go acc (x:xs) = go (x:acc) xs
327 Debugging/specialising versions of \tr{elem} and \tr{notElem}
330 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
333 isIn msg x ys = elem__ x ys
334 isn'tIn msg x ys = notElem__ x ys
336 --these are here to be SPECIALIZEd (automagically)
338 elem__ x (y:ys) = x==y || elem__ x ys
340 notElem__ x [] = True
341 notElem__ x (y:ys) = x /= y && notElem__ x ys
345 = elem (_ILIT 0) x ys
349 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
351 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
354 = notElem (_ILIT 0) x ys
356 notElem i x [] = True
358 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
359 x `List.notElem` (y:ys)
360 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
364 %************************************************************************
366 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
368 %************************************************************************
371 Date: Mon, 3 May 93 20:45:23 +0200
372 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
373 To: partain@dcs.gla.ac.uk
374 Subject: natural merge sort beats quick sort [ and it is prettier ]
376 Here is a piece of Haskell code that I'm rather fond of. See it as an
377 attempt to get rid of the ridiculous quick-sort routine. group is
378 quite useful by itself I think it was John's idea originally though I
379 believe the lazy version is due to me [surprisingly complicated].
380 gamma [used to be called] is called gamma because I got inspired by
381 the Gamma calculus. It is not very close to the calculus but does
382 behave less sequentially than both foldr and foldl. One could imagine
383 a version of gamma that took a unit element as well thereby avoiding
384 the problem with empty lists.
386 I've tried this code against
388 1) insertion sort - as provided by haskell
389 2) the normal implementation of quick sort
390 3) a deforested version of quick sort due to Jan Sparud
391 4) a super-optimized-quick-sort of Lennart's
393 If the list is partially sorted both merge sort and in particular
394 natural merge sort wins. If the list is random [ average length of
395 rising subsequences = approx 2 ] mergesort still wins and natural
396 merge sort is marginally beaten by Lennart's soqs. The space
397 consumption of merge sort is a bit worse than Lennart's quick sort
398 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
399 fpca article ] isn't used because of group.
406 group :: (a -> a -> Bool) -> [a] -> [[a]]
407 -- Given a <= function, group finds maximal contiguous up-runs
408 -- or down-runs in the input list.
409 -- It's stable, in the sense that it never re-orders equal elements
411 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
412 -- From: Andy Gill <andy@dcs.gla.ac.uk>
413 -- Here is a `better' definition of group.
416 group p (x:xs) = group' xs x x (x :)
418 group' [] _ _ s = [s []]
419 group' (x:xs) x_min x_max s
420 | x_max `p` x = group' xs x_min x (s . (x :))
421 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
422 | otherwise = s [] : group' xs x x (x :)
423 -- NB: the 'not' is essential for stablity
424 -- x `p` x_min would reverse equal elements
426 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
427 generalMerge p xs [] = xs
428 generalMerge p [] ys = ys
429 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
430 | otherwise = y : generalMerge p (x:xs) ys
432 -- gamma is now called balancedFold
434 balancedFold :: (a -> a -> a) -> [a] -> a
435 balancedFold f [] = error "can't reduce an empty list using balancedFold"
436 balancedFold f [x] = x
437 balancedFold f l = balancedFold f (balancedFold' f l)
439 balancedFold' :: (a -> a -> a) -> [a] -> [a]
440 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
441 balancedFold' f xs = xs
443 generalNaturalMergeSort p [] = []
444 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
447 generalMergeSort p [] = []
448 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
450 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
452 mergeSort = generalMergeSort (<=)
453 naturalMergeSort = generalNaturalMergeSort (<=)
455 mergeSortLe le = generalMergeSort le
458 sortLe :: (a->a->Bool) -> [a] -> [a]
459 sortLe le = generalNaturalMergeSort le
461 sortWith :: Ord b => (a->b) -> [a] -> [a]
462 sortWith get_key xs = sortLe le xs
464 x `le` y = get_key x < get_key y
467 %************************************************************************
469 \subsection[Utils-transitive-closure]{Transitive closure}
471 %************************************************************************
473 This algorithm for transitive closure is straightforward, albeit quadratic.
476 transitiveClosure :: (a -> [a]) -- Successor function
477 -> (a -> a -> Bool) -- Equality predicate
479 -> [a] -- The transitive closure
481 transitiveClosure succ eq xs
485 go done (x:xs) | x `is_in` done = go done xs
486 | otherwise = go (x:done) (succ x ++ xs)
489 x `is_in` (y:ys) | eq x y = True
490 | otherwise = x `is_in` ys
493 %************************************************************************
495 \subsection[Utils-accum]{Accumulating}
497 %************************************************************************
499 @mapAccumL@ behaves like a combination
500 of @map@ and @foldl@;
501 it applies a function to each element of a list, passing an accumulating
502 parameter from left to right, and returning a final value of this
503 accumulator together with the new list.
506 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
507 -- and accumulator, returning new
508 -- accumulator and elt of result list
509 -> acc -- Initial accumulator
511 -> (acc, [y]) -- Final accumulator and result list
513 mapAccumL f b [] = (b, [])
514 mapAccumL f b (x:xs) = (b'', x':xs') where
516 (b'', xs') = mapAccumL f b' xs
519 @mapAccumR@ does the same, but working from right to left instead. Its type is
520 the same as @mapAccumL@, though.
523 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
524 -- and accumulator, returning new
525 -- accumulator and elt of result list
526 -> acc -- Initial accumulator
528 -> (acc, [y]) -- Final accumulator and result list
530 mapAccumR f b [] = (b, [])
531 mapAccumR f b (x:xs) = (b'', x':xs') where
533 (b', xs') = mapAccumR f b xs
536 Here is the bi-directional version, that works from both left and right.
539 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
540 -- Function of elt of input list
541 -- and accumulator, returning new
542 -- accumulator and elt of result list
543 -> accl -- Initial accumulator from left
544 -> accr -- Initial accumulator from right
546 -> (accl, accr, [y]) -- Final accumulators and result list
548 mapAccumB f a b [] = (a,b,[])
549 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
551 (a',b'',y) = f a b' x
552 (a'',b',ys) = mapAccumB f a' b xs
555 A strict version of foldl.
558 foldl' :: (a -> b -> a) -> a -> [b] -> a
559 foldl' f z xs = lgo z xs
562 lgo z (x:xs) = (lgo $! (f z x)) xs
565 A combination of foldl with zip. It works with equal length lists.
568 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
570 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
573 Count the number of times a predicate is true
576 count :: (a -> Bool) -> [a] -> Int
578 count p (x:xs) | p x = 1 + count p xs
579 | otherwise = count p xs
582 @splitAt@, @take@, and @drop@ but with length of another
583 list giving the break-off point:
586 takeList :: [b] -> [a] -> [a]
591 (y:ys) -> y : takeList xs ys
593 dropList :: [b] -> [a] -> [a]
595 dropList _ xs@[] = xs
596 dropList (_:xs) (_:ys) = dropList xs ys
599 splitAtList :: [b] -> [a] -> ([a], [a])
600 splitAtList [] xs = ([], xs)
601 splitAtList _ xs@[] = (xs, xs)
602 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
604 (ys', ys'') = splitAtList xs ys
606 split :: Char -> String -> [String]
607 split c s = case rest of
609 _:rest -> chunk : split c rest
610 where (chunk, rest) = break (==c) s
614 %************************************************************************
616 \subsection[Utils-comparison]{Comparisons}
618 %************************************************************************
621 isEqual :: Ordering -> Bool
622 -- Often used in (isEqual (a `compare` b))
627 thenCmp :: Ordering -> Ordering -> Ordering
628 {-# INLINE thenCmp #-}
630 thenCmp other any = other
632 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
633 eqListBy eq [] [] = True
634 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
635 eqListBy eq xs ys = False
637 equalLength :: [a] -> [b] -> Bool
638 equalLength [] [] = True
639 equalLength (_:xs) (_:ys) = equalLength xs ys
640 equalLength xs ys = False
642 compareLength :: [a] -> [b] -> Ordering
643 compareLength [] [] = EQ
644 compareLength (_:xs) (_:ys) = compareLength xs ys
645 compareLength [] _ys = LT
646 compareLength _xs [] = GT
648 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
649 -- `cmpList' uses a user-specified comparer
651 cmpList cmp [] [] = EQ
652 cmpList cmp [] _ = LT
653 cmpList cmp _ [] = GT
654 cmpList cmp (a:as) (b:bs)
655 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
659 prefixMatch :: Eq a => [a] -> [a] -> Bool
660 prefixMatch [] _str = True
661 prefixMatch _pat [] = False
662 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
665 maybePrefixMatch :: String -> String -> Maybe String
666 maybePrefixMatch [] rest = Just rest
667 maybePrefixMatch (_:_) [] = Nothing
668 maybePrefixMatch (p:pat) (r:rest)
669 | p == r = maybePrefixMatch pat rest
670 | otherwise = Nothing
672 suffixMatch :: Eq a => [a] -> [a] -> Bool
673 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
675 removeSpaces :: String -> String
676 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
679 %************************************************************************
681 \subsection[Utils-pairs]{Pairs}
683 %************************************************************************
685 The following are curried versions of @fst@ and @snd@.
689 cfst :: a -> b -> a -- stranal-sem only (Note)
694 The following provide us higher order functions that, when applied
695 to a function, operate on pairs.
699 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
700 applyToPair (f,g) (x,y) = (f x, g y)
702 applyToFst :: (a -> c) -> (a,b)-> (c,b)
703 applyToFst f (x,y) = (f x,y)
705 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
706 applyToSnd f (x,y) = (x,f y)
711 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
712 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
716 seqList :: [a] -> b -> b
718 seqList (x:xs) b = x `seq` seqList xs b
724 global :: a -> IORef a
725 global a = unsafePerformIO (newIORef a)
729 consIORef :: IORef [a] -> a -> IO ()
732 writeIORef var (x:xs)
738 looksLikeModuleName [] = False
739 looksLikeModuleName (c:cs) = isUpper c && go cs
741 go ('.':cs) = looksLikeModuleName cs
742 go (c:cs) = (isAlphaNum c || c == '_') && go cs
745 Akin to @Prelude.words@, but sensitive to dquoted entities treating
746 them as single words.
749 toArgs :: String -> [String]
752 case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
754 (\ ws -> if null w then ws else w : ws) $
758 | x /= '"' -> toArgs xs
761 ((str,rs):_) -> stripQuotes str : toArgs rs
764 -- strip away dquotes; assume first and last chars contain quotes.
765 stripQuotes :: String -> String
766 stripQuotes ('"':xs) = init xs
770 -- -----------------------------------------------------------------------------
774 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
775 readRational__ r = do
778 return ((n%1)*10^^(k-d), t)
781 (ds,s) <- lexDecDigits r
782 (ds',t) <- lexDotDigits s
783 return (read (ds++ds'), length ds', t)
785 readExp (e:s) | e `elem` "eE" = readExp' s
786 readExp s = return (0,s)
788 readExp' ('+':s) = readDec s
789 readExp' ('-':s) = do
792 readExp' s = readDec s
795 (ds,r) <- nonnull isDigit s
796 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
799 lexDecDigits = nonnull isDigit
801 lexDotDigits ('.':s) = return (span isDigit s)
802 lexDotDigits s = return ("",s)
804 nonnull p s = do (cs@(_:_),t) <- return (span p s)
807 readRational :: String -> Rational -- NB: *does* handle a leading "-"
810 '-' : xs -> - (read_me xs)
814 = case (do { (x,"") <- readRational__ s ; return x }) of
816 [] -> error ("readRational: no parse:" ++ top_s)
817 _ -> error ("readRational: ambiguous parse:" ++ top_s)
820 -----------------------------------------------------------------------------
821 -- Create a hierarchy of directories
823 createDirectoryHierarchy :: FilePath -> IO ()
824 createDirectoryHierarchy dir = do
825 b <- doesDirectoryExist dir
827 createDirectoryHierarchy (directoryOf dir)
830 -----------------------------------------------------------------------------
831 -- Verify that the 'dirname' portion of a FilePath exists.
833 doesDirNameExist :: FilePath -> IO Bool
834 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
836 -- -----------------------------------------------------------------------------
841 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
842 handleDyn = flip catchDyn
844 handle :: (Exception -> IO a) -> IO a -> IO a
845 #if __GLASGOW_HASKELL__ < 501
846 handle = flip Exception.catchAllIO
848 handle h f = f `Exception.catch` \e -> case e of
849 ExitException _ -> throw e
853 -- --------------------------------------------------------------
854 -- check existence & modification time at the same time
856 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
857 modificationTimeIfExists f = do
858 (do t <- getModificationTime f; return (Just t))
859 `IO.catch` \e -> if isDoesNotExistError e
863 -- --------------------------------------------------------------
864 -- Filename manipulation
866 -- Filenames are kept "normalised" inside GHC, using '/' as the path
867 -- separator. On Windows these functions will also recognise '\\' as
868 -- the path separator, but will generally construct paths using '/'.
872 splitFilename :: String -> (String,Suffix)
873 splitFilename f = splitLongestPrefix f (=='.')
875 basenameOf :: FilePath -> String
876 basenameOf = fst . splitFilename
878 suffixOf :: FilePath -> Suffix
879 suffixOf = snd . splitFilename
881 joinFileExt :: String -> String -> FilePath
882 joinFileExt path "" = path
883 joinFileExt path ext = path ++ '.':ext
885 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
886 splitFilenameDir :: String -> (String,String)
888 = let (dir, rest) = splitLongestPrefix str isPathSeparator
889 (dir', rest') | null rest = (".", dir)
890 | otherwise = (dir, rest)
893 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
894 splitFilename3 :: String -> (String,String,Suffix)
896 = let (dir, rest) = splitFilenameDir str
897 (name, ext) = splitFilename rest
900 joinFileName :: String -> String -> FilePath
901 joinFileName "" fname = fname
902 joinFileName "." fname = fname
903 joinFileName dir "" = dir
904 joinFileName dir fname = dir ++ '/':fname
906 -- split a string at the last character where 'pred' is True,
907 -- returning a pair of strings. The first component holds the string
908 -- up (but not including) the last character for which 'pred' returned
909 -- True, the second whatever comes after (but also not including the
912 -- If 'pred' returns False for all characters in the string, the original
913 -- string is returned in the first component (and the second one is just
915 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
916 splitLongestPrefix s pred
918 [] -> (reverse suf, [])
919 (_:pre) -> (reverse pre, reverse suf)
920 where (suf,pre) = break pred (reverse s)
922 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
923 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
925 -- directoryOf strips the filename off the input string, returning
927 directoryOf :: FilePath -> String
928 directoryOf = fst . splitFilenameDir
930 -- filenameOf strips the directory off the input string, returning
932 filenameOf :: FilePath -> String
933 filenameOf = snd . splitFilenameDir
935 replaceFilenameDirectory :: FilePath -> String -> FilePath
936 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
938 escapeSpaces :: String -> String
939 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
941 isPathSeparator :: Char -> Bool
943 #ifdef mingw32_TARGET_OS
944 ch == '/' || ch == '\\'
949 -----------------------------------------------------------------------------
950 -- Convert filepath into platform / MSDOS form.
952 -- We maintain path names in Unix form ('/'-separated) right until
953 -- the last moment. On Windows we dos-ify them just before passing them
954 -- to the Windows command.
956 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
957 -- proved quite awkward. There were a lot more calls to platformPath,
958 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
959 -- interpreted a command line 'foo\baz' as 'foobaz'.
961 normalisePath :: String -> String
962 -- Just changes '\' to '/'
964 pgmPath :: String -- Directory string in Unix format
965 -> String -- Program name with no directory separators
967 -> String -- Program invocation string in native format
969 #if defined(mingw32_HOST_OS)
970 --------------------- Windows version ------------------
971 normalisePath xs = subst '\\' '/' xs
972 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
973 platformPath p = subst '/' '\\' p
975 subst a b ls = map (\ x -> if x == a then b else x) ls
977 --------------------- Non-Windows version --------------
978 normalisePath xs = xs
979 pgmPath dir pgm = dir ++ '/' : pgm
980 platformPath stuff = stuff
981 --------------------------------------------------------