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 singleton :: a -> [a]
309 isSingleton :: [a] -> Bool
310 isSingleton [x] = True
311 isSingleton _ = False
313 notNull :: [a] -> Bool
317 snocView :: [a] -> Maybe ([a],a)
318 -- Split off the last element
319 snocView [] = Nothing
320 snocView xs = go [] xs
322 -- Invariant: second arg is non-empty
323 go acc [x] = Just (reverse acc, x)
324 go acc (x:xs) = go (x:acc) xs
334 Debugging/specialising versions of \tr{elem} and \tr{notElem}
337 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
340 isIn msg x ys = elem__ x ys
341 isn'tIn msg x ys = notElem__ x ys
343 --these are here to be SPECIALIZEd (automagically)
345 elem__ x (y:ys) = x==y || elem__ x ys
347 notElem__ x [] = True
348 notElem__ x (y:ys) = x /= y && notElem__ x ys
352 = elem (_ILIT 0) x ys
356 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
358 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
361 = notElem (_ILIT 0) x ys
363 notElem i x [] = True
365 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
366 x `List.notElem` (y:ys)
367 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
371 %************************************************************************
373 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
375 %************************************************************************
378 Date: Mon, 3 May 93 20:45:23 +0200
379 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
380 To: partain@dcs.gla.ac.uk
381 Subject: natural merge sort beats quick sort [ and it is prettier ]
383 Here is a piece of Haskell code that I'm rather fond of. See it as an
384 attempt to get rid of the ridiculous quick-sort routine. group is
385 quite useful by itself I think it was John's idea originally though I
386 believe the lazy version is due to me [surprisingly complicated].
387 gamma [used to be called] is called gamma because I got inspired by
388 the Gamma calculus. It is not very close to the calculus but does
389 behave less sequentially than both foldr and foldl. One could imagine
390 a version of gamma that took a unit element as well thereby avoiding
391 the problem with empty lists.
393 I've tried this code against
395 1) insertion sort - as provided by haskell
396 2) the normal implementation of quick sort
397 3) a deforested version of quick sort due to Jan Sparud
398 4) a super-optimized-quick-sort of Lennart's
400 If the list is partially sorted both merge sort and in particular
401 natural merge sort wins. If the list is random [ average length of
402 rising subsequences = approx 2 ] mergesort still wins and natural
403 merge sort is marginally beaten by Lennart's soqs. The space
404 consumption of merge sort is a bit worse than Lennart's quick sort
405 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
406 fpca article ] isn't used because of group.
413 group :: (a -> a -> Bool) -> [a] -> [[a]]
414 -- Given a <= function, group finds maximal contiguous up-runs
415 -- or down-runs in the input list.
416 -- It's stable, in the sense that it never re-orders equal elements
418 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
419 -- From: Andy Gill <andy@dcs.gla.ac.uk>
420 -- Here is a `better' definition of group.
423 group p (x:xs) = group' xs x x (x :)
425 group' [] _ _ s = [s []]
426 group' (x:xs) x_min x_max s
427 | x_max `p` x = group' xs x_min x (s . (x :))
428 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
429 | otherwise = s [] : group' xs x x (x :)
430 -- NB: the 'not' is essential for stablity
431 -- x `p` x_min would reverse equal elements
433 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
434 generalMerge p xs [] = xs
435 generalMerge p [] ys = ys
436 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
437 | otherwise = y : generalMerge p (x:xs) ys
439 -- gamma is now called balancedFold
441 balancedFold :: (a -> a -> a) -> [a] -> a
442 balancedFold f [] = error "can't reduce an empty list using balancedFold"
443 balancedFold f [x] = x
444 balancedFold f l = balancedFold f (balancedFold' f l)
446 balancedFold' :: (a -> a -> a) -> [a] -> [a]
447 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
448 balancedFold' f xs = xs
450 generalNaturalMergeSort p [] = []
451 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
454 generalMergeSort p [] = []
455 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
457 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
459 mergeSort = generalMergeSort (<=)
460 naturalMergeSort = generalNaturalMergeSort (<=)
462 mergeSortLe le = generalMergeSort le
465 sortLe :: (a->a->Bool) -> [a] -> [a]
466 sortLe le = generalNaturalMergeSort le
468 sortWith :: Ord b => (a->b) -> [a] -> [a]
469 sortWith get_key xs = sortLe le xs
471 x `le` y = get_key x < get_key y
474 %************************************************************************
476 \subsection[Utils-transitive-closure]{Transitive closure}
478 %************************************************************************
480 This algorithm for transitive closure is straightforward, albeit quadratic.
483 transitiveClosure :: (a -> [a]) -- Successor function
484 -> (a -> a -> Bool) -- Equality predicate
486 -> [a] -- The transitive closure
488 transitiveClosure succ eq xs
492 go done (x:xs) | x `is_in` done = go done xs
493 | otherwise = go (x:done) (succ x ++ xs)
496 x `is_in` (y:ys) | eq x y = True
497 | otherwise = x `is_in` ys
500 %************************************************************************
502 \subsection[Utils-accum]{Accumulating}
504 %************************************************************************
506 @mapAccumL@ behaves like a combination
507 of @map@ and @foldl@;
508 it applies a function to each element of a list, passing an accumulating
509 parameter from left to right, and returning a final value of this
510 accumulator together with the new list.
513 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
514 -- and accumulator, returning new
515 -- accumulator and elt of result list
516 -> acc -- Initial accumulator
518 -> (acc, [y]) -- Final accumulator and result list
520 mapAccumL f b [] = (b, [])
521 mapAccumL f b (x:xs) = (b'', x':xs') where
523 (b'', xs') = mapAccumL f b' xs
526 @mapAccumR@ does the same, but working from right to left instead. Its type is
527 the same as @mapAccumL@, though.
530 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
531 -- and accumulator, returning new
532 -- accumulator and elt of result list
533 -> acc -- Initial accumulator
535 -> (acc, [y]) -- Final accumulator and result list
537 mapAccumR f b [] = (b, [])
538 mapAccumR f b (x:xs) = (b'', x':xs') where
540 (b', xs') = mapAccumR f b xs
543 Here is the bi-directional version, that works from both left and right.
546 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
547 -- Function of elt of input list
548 -- and accumulator, returning new
549 -- accumulator and elt of result list
550 -> accl -- Initial accumulator from left
551 -> accr -- Initial accumulator from right
553 -> (accl, accr, [y]) -- Final accumulators and result list
555 mapAccumB f a b [] = (a,b,[])
556 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
558 (a',b'',y) = f a b' x
559 (a'',b',ys) = mapAccumB f a' b xs
562 A strict version of foldl.
565 foldl' :: (a -> b -> a) -> a -> [b] -> a
566 foldl' f z xs = lgo z xs
569 lgo z (x:xs) = (lgo $! (f z x)) xs
572 A combination of foldl with zip. It works with equal length lists.
575 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
577 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
579 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
580 -- True if the lists are the same length, and
581 -- all corresponding elements satisfy the predicate
583 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
587 Count the number of times a predicate is true
590 count :: (a -> Bool) -> [a] -> Int
592 count p (x:xs) | p x = 1 + count p xs
593 | otherwise = count p xs
596 @splitAt@, @take@, and @drop@ but with length of another
597 list giving the break-off point:
600 takeList :: [b] -> [a] -> [a]
605 (y:ys) -> y : takeList xs ys
607 dropList :: [b] -> [a] -> [a]
609 dropList _ xs@[] = xs
610 dropList (_:xs) (_:ys) = dropList xs ys
613 splitAtList :: [b] -> [a] -> ([a], [a])
614 splitAtList [] xs = ([], xs)
615 splitAtList _ xs@[] = (xs, xs)
616 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
618 (ys', ys'') = splitAtList xs ys
620 split :: Char -> String -> [String]
621 split c s = case rest of
623 _:rest -> chunk : split c rest
624 where (chunk, rest) = break (==c) s
628 %************************************************************************
630 \subsection[Utils-comparison]{Comparisons}
632 %************************************************************************
635 isEqual :: Ordering -> Bool
636 -- Often used in (isEqual (a `compare` b))
641 thenCmp :: Ordering -> Ordering -> Ordering
642 {-# INLINE thenCmp #-}
644 thenCmp other any = other
646 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
647 eqListBy eq [] [] = True
648 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
649 eqListBy eq xs ys = False
651 equalLength :: [a] -> [b] -> Bool
652 equalLength [] [] = True
653 equalLength (_:xs) (_:ys) = equalLength xs ys
654 equalLength xs ys = False
656 compareLength :: [a] -> [b] -> Ordering
657 compareLength [] [] = EQ
658 compareLength (_:xs) (_:ys) = compareLength xs ys
659 compareLength [] _ys = LT
660 compareLength _xs [] = GT
662 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
663 -- `cmpList' uses a user-specified comparer
665 cmpList cmp [] [] = EQ
666 cmpList cmp [] _ = LT
667 cmpList cmp _ [] = GT
668 cmpList cmp (a:as) (b:bs)
669 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
673 prefixMatch :: Eq a => [a] -> [a] -> Bool
674 prefixMatch [] _str = True
675 prefixMatch _pat [] = False
676 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
679 maybePrefixMatch :: String -> String -> Maybe String
680 maybePrefixMatch [] rest = Just rest
681 maybePrefixMatch (_:_) [] = Nothing
682 maybePrefixMatch (p:pat) (r:rest)
683 | p == r = maybePrefixMatch pat rest
684 | otherwise = Nothing
686 suffixMatch :: Eq a => [a] -> [a] -> Bool
687 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
689 removeSpaces :: String -> String
690 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
693 %************************************************************************
695 \subsection[Utils-pairs]{Pairs}
697 %************************************************************************
699 The following are curried versions of @fst@ and @snd@.
703 cfst :: a -> b -> a -- stranal-sem only (Note)
708 The following provide us higher order functions that, when applied
709 to a function, operate on pairs.
713 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
714 applyToPair (f,g) (x,y) = (f x, g y)
716 applyToFst :: (a -> c) -> (a,b)-> (c,b)
717 applyToFst f (x,y) = (f x,y)
719 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
720 applyToSnd f (x,y) = (x,f y)
725 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
726 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
730 seqList :: [a] -> b -> b
732 seqList (x:xs) b = x `seq` seqList xs b
738 global :: a -> IORef a
739 global a = unsafePerformIO (newIORef a)
743 consIORef :: IORef [a] -> a -> IO ()
746 writeIORef var (x:xs)
752 looksLikeModuleName [] = False
753 looksLikeModuleName (c:cs) = isUpper c && go cs
755 go ('.':cs) = looksLikeModuleName cs
756 go (c:cs) = (isAlphaNum c || c == '_') && go cs
759 Akin to @Prelude.words@, but sensitive to dquoted entities treating
760 them as single words.
763 toArgs :: String -> [String]
766 case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
768 (\ ws -> if null w then ws else w : ws) $
772 | x /= '"' -> toArgs xs
775 ((str,rs):_) -> stripQuotes str : toArgs rs
778 -- strip away dquotes; assume first and last chars contain quotes.
779 stripQuotes :: String -> String
780 stripQuotes ('"':xs) = init xs
784 -- -----------------------------------------------------------------------------
788 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
789 readRational__ r = do
792 return ((n%1)*10^^(k-d), t)
795 (ds,s) <- lexDecDigits r
796 (ds',t) <- lexDotDigits s
797 return (read (ds++ds'), length ds', t)
799 readExp (e:s) | e `elem` "eE" = readExp' s
800 readExp s = return (0,s)
802 readExp' ('+':s) = readDec s
803 readExp' ('-':s) = do
806 readExp' s = readDec s
809 (ds,r) <- nonnull isDigit s
810 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
813 lexDecDigits = nonnull isDigit
815 lexDotDigits ('.':s) = return (span isDigit s)
816 lexDotDigits s = return ("",s)
818 nonnull p s = do (cs@(_:_),t) <- return (span p s)
821 readRational :: String -> Rational -- NB: *does* handle a leading "-"
824 '-' : xs -> - (read_me xs)
828 = case (do { (x,"") <- readRational__ s ; return x }) of
830 [] -> error ("readRational: no parse:" ++ top_s)
831 _ -> error ("readRational: ambiguous parse:" ++ top_s)
834 -----------------------------------------------------------------------------
835 -- Create a hierarchy of directories
837 createDirectoryHierarchy :: FilePath -> IO ()
838 createDirectoryHierarchy dir = do
839 b <- doesDirectoryExist dir
841 createDirectoryHierarchy (directoryOf dir)
844 -----------------------------------------------------------------------------
845 -- Verify that the 'dirname' portion of a FilePath exists.
847 doesDirNameExist :: FilePath -> IO Bool
848 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
850 -- -----------------------------------------------------------------------------
855 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
856 handleDyn = flip catchDyn
858 handle :: (Exception -> IO a) -> IO a -> IO a
859 #if __GLASGOW_HASKELL__ < 501
860 handle = flip Exception.catchAllIO
862 handle h f = f `Exception.catch` \e -> case e of
863 ExitException _ -> throw e
867 -- --------------------------------------------------------------
868 -- check existence & modification time at the same time
870 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
871 modificationTimeIfExists f = do
872 (do t <- getModificationTime f; return (Just t))
873 `IO.catch` \e -> if isDoesNotExistError e
877 -- --------------------------------------------------------------
878 -- Filename manipulation
880 -- Filenames are kept "normalised" inside GHC, using '/' as the path
881 -- separator. On Windows these functions will also recognise '\\' as
882 -- the path separator, but will generally construct paths using '/'.
886 splitFilename :: String -> (String,Suffix)
887 splitFilename f = splitLongestPrefix f (=='.')
889 basenameOf :: FilePath -> String
890 basenameOf = fst . splitFilename
892 suffixOf :: FilePath -> Suffix
893 suffixOf = snd . splitFilename
895 joinFileExt :: String -> String -> FilePath
896 joinFileExt path "" = path
897 joinFileExt path ext = path ++ '.':ext
899 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
900 splitFilenameDir :: String -> (String,String)
902 = let (dir, rest) = splitLongestPrefix str isPathSeparator
903 (dir', rest') | null rest = (".", dir)
904 | otherwise = (dir, rest)
907 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
908 splitFilename3 :: String -> (String,String,Suffix)
910 = let (dir, rest) = splitFilenameDir str
911 (name, ext) = splitFilename rest
914 joinFileName :: String -> String -> FilePath
915 joinFileName "" fname = fname
916 joinFileName "." fname = fname
917 joinFileName dir "" = dir
918 joinFileName dir fname = dir ++ '/':fname
920 -- split a string at the last character where 'pred' is True,
921 -- returning a pair of strings. The first component holds the string
922 -- up (but not including) the last character for which 'pred' returned
923 -- True, the second whatever comes after (but also not including the
926 -- If 'pred' returns False for all characters in the string, the original
927 -- string is returned in the first component (and the second one is just
929 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
930 splitLongestPrefix str pred
931 | null r_pre = (str, [])
932 | otherwise = (reverse (tail r_pre), reverse r_suf)
933 -- 'tail' drops the char satisfying 'pred'
935 (r_suf, r_pre) = break pred (reverse str)
937 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
938 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
940 -- directoryOf strips the filename off the input string, returning
942 directoryOf :: FilePath -> String
943 directoryOf = fst . splitFilenameDir
945 -- filenameOf strips the directory off the input string, returning
947 filenameOf :: FilePath -> String
948 filenameOf = snd . splitFilenameDir
950 replaceFilenameDirectory :: FilePath -> String -> FilePath
951 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
953 escapeSpaces :: String -> String
954 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
956 isPathSeparator :: Char -> Bool
958 #ifdef mingw32_TARGET_OS
959 ch == '/' || ch == '\\'
964 --------------------------------------------------------------
966 --------------------------------------------------------------
968 -- | The function splits the given string to substrings
969 -- using the 'searchPathSeparator'.
970 parseSearchPath :: String -> [FilePath]
971 parseSearchPath path = split path
973 split :: String -> [String]
977 _:rest -> chunk : split rest
981 #ifdef mingw32_HOST_OS
982 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
986 (chunk', rest') = break (==searchPathSeparator) s
988 -- | A platform-specific character used to separate search path strings in
989 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
990 -- and a semicolon (\";\") on the Windows operating system.
991 searchPathSeparator :: Char
992 #if mingw32_HOST_OS || mingw32_TARGET_OS
993 searchPathSeparator = ';'
995 searchPathSeparator = ':'
998 -----------------------------------------------------------------------------
999 -- Convert filepath into platform / MSDOS form.
1001 -- We maintain path names in Unix form ('/'-separated) right until
1002 -- the last moment. On Windows we dos-ify them just before passing them
1003 -- to the Windows command.
1005 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1006 -- proved quite awkward. There were a lot more calls to platformPath,
1007 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1008 -- interpreted a command line 'foo\baz' as 'foobaz'.
1010 normalisePath :: String -> String
1011 -- Just changes '\' to '/'
1013 pgmPath :: String -- Directory string in Unix format
1014 -> String -- Program name with no directory separators
1016 -> String -- Program invocation string in native format
1018 #if defined(mingw32_HOST_OS)
1019 --------------------- Windows version ------------------
1020 normalisePath xs = subst '\\' '/' xs
1021 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
1022 platformPath p = subst '/' '\\' p
1024 subst a b ls = map (\ x -> if x == a then b else x) ls
1026 --------------------- Non-Windows version --------------
1027 normalisePath xs = xs
1028 pgmPath dir pgm = dir ++ '/' : pgm
1029 platformPath stuff = stuff
1030 --------------------------------------------------------