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,
16 isSingleton, only, singleton,
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, joinFileName,
70 replaceFilenameSuffix, directoryOf, filenameOf,
71 replaceFilenameDirectory,
72 escapeSpaces, isPathSeparator,
74 normalisePath, platformPath, pgmPath,
77 #include "HsVersions.h"
79 import Panic ( panic, trace )
82 import EXCEPTION ( Exception(..), finally, throwDyn, catchDyn, throw )
83 import qualified EXCEPTION as Exception
84 import DYNAMIC ( Typeable )
85 import DATA_IOREF ( IORef, newIORef )
86 import UNSAFE_IO ( unsafePerformIO )
87 import DATA_IOREF ( readIORef, writeIORef )
89 import qualified List ( elem, notElem )
92 import List ( zipWith4 )
96 import IO ( catch, isDoesNotExistError )
97 import Directory ( doesDirectoryExist, createDirectory )
98 import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
100 import Time ( ClockTime )
101 import Directory ( getModificationTime )
106 %************************************************************************
108 \subsection{The Eager monad}
110 %************************************************************************
112 The @Eager@ monad is just an encoding of continuation-passing style,
113 used to allow you to express "do this and then that", mainly to avoid
114 space leaks. It's done with a type synonym to save bureaucracy.
119 type Eager ans a = (a -> ans) -> ans
121 runEager :: Eager a a -> a
122 runEager m = m (\x -> x)
124 appEager :: Eager ans a -> (a -> ans) -> ans
125 appEager m cont = m cont
127 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
128 thenEager m k cont = m (\r -> k r cont)
130 returnEager :: a -> Eager ans a
131 returnEager v cont = cont v
133 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
134 mapEager f [] = returnEager []
135 mapEager f (x:xs) = f x `thenEager` \ y ->
136 mapEager f xs `thenEager` \ ys ->
141 %************************************************************************
143 \subsection{A for loop}
145 %************************************************************************
148 -- Compose a function with itself n times. (nth rather than twice)
149 nTimes :: Int -> (a -> a) -> (a -> a)
152 nTimes n f = f . nTimes (n-1) f
155 %************************************************************************
157 \subsection[Utils-lists]{General list processing}
159 %************************************************************************
162 filterOut :: (a->Bool) -> [a] -> [a]
163 -- Like filter, only reverses the sense of the test
165 filterOut p (x:xs) | p x = filterOut p xs
166 | otherwise = x : filterOut p xs
169 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
170 are of equal length. Alastair Reid thinks this should only happen if
171 DEBUGging on; hey, why not?
174 zipEqual :: String -> [a] -> [b] -> [(a,b)]
175 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
176 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
177 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
181 zipWithEqual _ = zipWith
182 zipWith3Equal _ = zipWith3
183 zipWith4Equal _ = zipWith4
185 zipEqual msg [] [] = []
186 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
187 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
189 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
190 zipWithEqual msg _ [] [] = []
191 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
193 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
194 = z a b c : zipWith3Equal msg z as bs cs
195 zipWith3Equal msg _ [] [] [] = []
196 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
198 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
199 = z a b c d : zipWith4Equal msg z as bs cs ds
200 zipWith4Equal msg _ [] [] [] [] = []
201 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
206 -- zipLazy is lazy in the second list (observe the ~)
208 zipLazy :: [a] -> [b] -> [(a,b)]
210 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
215 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
216 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
217 -- the places where p returns *True*
219 stretchZipWith p z f [] ys = []
220 stretchZipWith p z f (x:xs) ys
221 | p x = f x z : stretchZipWith p z f xs ys
222 | otherwise = case ys of
224 (y:ys) -> f x y : stretchZipWith p z f xs ys
229 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
230 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
232 mapFst f xys = [(f x, y) | (x,y) <- xys]
233 mapSnd f xys = [(x, f y) | (x,y) <- xys]
235 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
237 mapAndUnzip f [] = ([],[])
241 (rs1, rs2) = mapAndUnzip f xs
245 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
247 mapAndUnzip3 f [] = ([],[],[])
248 mapAndUnzip3 f (x:xs)
251 (rs1, rs2, rs3) = mapAndUnzip3 f xs
253 (r1:rs1, r2:rs2, r3:rs3)
257 nOfThem :: Int -> a -> [a]
258 nOfThem n thing = replicate n thing
260 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
263 -- atLength atLenPred atEndPred ls n
264 -- | n < 0 = atLenPred n
265 -- | length ls < n = atEndPred (n - length ls)
266 -- | otherwise = atLenPred (drop n ls)
268 atLength :: ([a] -> b)
273 atLength atLenPred atEndPred ls n
274 | n < 0 = atEndPred n
275 | otherwise = go n ls
277 go n [] = atEndPred n
278 go 0 ls = atLenPred ls
279 go n (_:xs) = go (n-1) xs
282 lengthExceeds :: [a] -> Int -> Bool
283 -- (lengthExceeds xs n) = (length xs > n)
284 lengthExceeds = atLength notNull (const False)
286 lengthAtLeast :: [a] -> Int -> Bool
287 lengthAtLeast = atLength notNull (== 0)
289 lengthIs :: [a] -> Int -> Bool
290 lengthIs = atLength null (==0)
292 listLengthCmp :: [a] -> Int -> Ordering
293 listLengthCmp = atLength atLen atEnd
297 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
303 singleton :: a -> [a]
306 isSingleton :: [a] -> Bool
307 isSingleton [x] = True
308 isSingleton _ = False
310 notNull :: [a] -> Bool
314 snocView :: [a] -> Maybe ([a],a)
315 -- Split off the last element
316 snocView [] = Nothing
317 snocView xs = go [] xs
319 -- Invariant: second arg is non-empty
320 go acc [x] = Just (reverse acc, x)
321 go acc (x:xs) = go (x:acc) xs
331 Debugging/specialising versions of \tr{elem} and \tr{notElem}
334 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
337 isIn msg x ys = elem__ x ys
338 isn'tIn msg x ys = notElem__ x ys
340 --these are here to be SPECIALIZEd (automagically)
342 elem__ x (y:ys) = x==y || elem__ x ys
344 notElem__ x [] = True
345 notElem__ x (y:ys) = x /= y && notElem__ x ys
349 = elem (_ILIT 0) x ys
353 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
355 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
358 = notElem (_ILIT 0) x ys
360 notElem i x [] = True
362 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
363 x `List.notElem` (y:ys)
364 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
368 %************************************************************************
370 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
372 %************************************************************************
375 Date: Mon, 3 May 93 20:45:23 +0200
376 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
377 To: partain@dcs.gla.ac.uk
378 Subject: natural merge sort beats quick sort [ and it is prettier ]
380 Here is a piece of Haskell code that I'm rather fond of. See it as an
381 attempt to get rid of the ridiculous quick-sort routine. group is
382 quite useful by itself I think it was John's idea originally though I
383 believe the lazy version is due to me [surprisingly complicated].
384 gamma [used to be called] is called gamma because I got inspired by
385 the Gamma calculus. It is not very close to the calculus but does
386 behave less sequentially than both foldr and foldl. One could imagine
387 a version of gamma that took a unit element as well thereby avoiding
388 the problem with empty lists.
390 I've tried this code against
392 1) insertion sort - as provided by haskell
393 2) the normal implementation of quick sort
394 3) a deforested version of quick sort due to Jan Sparud
395 4) a super-optimized-quick-sort of Lennart's
397 If the list is partially sorted both merge sort and in particular
398 natural merge sort wins. If the list is random [ average length of
399 rising subsequences = approx 2 ] mergesort still wins and natural
400 merge sort is marginally beaten by Lennart's soqs. The space
401 consumption of merge sort is a bit worse than Lennart's quick sort
402 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
403 fpca article ] isn't used because of group.
410 group :: (a -> a -> Bool) -> [a] -> [[a]]
411 -- Given a <= function, group finds maximal contiguous up-runs
412 -- or down-runs in the input list.
413 -- It's stable, in the sense that it never re-orders equal elements
415 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
416 -- From: Andy Gill <andy@dcs.gla.ac.uk>
417 -- Here is a `better' definition of group.
420 group p (x:xs) = group' xs x x (x :)
422 group' [] _ _ s = [s []]
423 group' (x:xs) x_min x_max s
424 | x_max `p` x = group' xs x_min x (s . (x :))
425 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
426 | otherwise = s [] : group' xs x x (x :)
427 -- NB: the 'not' is essential for stablity
428 -- x `p` x_min would reverse equal elements
430 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
431 generalMerge p xs [] = xs
432 generalMerge p [] ys = ys
433 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
434 | otherwise = y : generalMerge p (x:xs) ys
436 -- gamma is now called balancedFold
438 balancedFold :: (a -> a -> a) -> [a] -> a
439 balancedFold f [] = error "can't reduce an empty list using balancedFold"
440 balancedFold f [x] = x
441 balancedFold f l = balancedFold f (balancedFold' f l)
443 balancedFold' :: (a -> a -> a) -> [a] -> [a]
444 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
445 balancedFold' f xs = xs
447 generalNaturalMergeSort p [] = []
448 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
451 generalMergeSort p [] = []
452 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
454 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
456 mergeSort = generalMergeSort (<=)
457 naturalMergeSort = generalNaturalMergeSort (<=)
459 mergeSortLe le = generalMergeSort le
462 sortLe :: (a->a->Bool) -> [a] -> [a]
463 sortLe le = generalNaturalMergeSort le
465 sortWith :: Ord b => (a->b) -> [a] -> [a]
466 sortWith get_key xs = sortLe le xs
468 x `le` y = get_key x < get_key y
471 %************************************************************************
473 \subsection[Utils-transitive-closure]{Transitive closure}
475 %************************************************************************
477 This algorithm for transitive closure is straightforward, albeit quadratic.
480 transitiveClosure :: (a -> [a]) -- Successor function
481 -> (a -> a -> Bool) -- Equality predicate
483 -> [a] -- The transitive closure
485 transitiveClosure succ eq xs
489 go done (x:xs) | x `is_in` done = go done xs
490 | otherwise = go (x:done) (succ x ++ xs)
493 x `is_in` (y:ys) | eq x y = True
494 | otherwise = x `is_in` ys
497 %************************************************************************
499 \subsection[Utils-accum]{Accumulating}
501 %************************************************************************
503 @mapAccumL@ behaves like a combination
504 of @map@ and @foldl@;
505 it applies a function to each element of a list, passing an accumulating
506 parameter from left to right, and returning a final value of this
507 accumulator together with the new list.
510 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
511 -- and accumulator, returning new
512 -- accumulator and elt of result list
513 -> acc -- Initial accumulator
515 -> (acc, [y]) -- Final accumulator and result list
517 mapAccumL f b [] = (b, [])
518 mapAccumL f b (x:xs) = (b'', x':xs') where
520 (b'', xs') = mapAccumL f b' xs
523 @mapAccumR@ does the same, but working from right to left instead. Its type is
524 the same as @mapAccumL@, though.
527 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
528 -- and accumulator, returning new
529 -- accumulator and elt of result list
530 -> acc -- Initial accumulator
532 -> (acc, [y]) -- Final accumulator and result list
534 mapAccumR f b [] = (b, [])
535 mapAccumR f b (x:xs) = (b'', x':xs') where
537 (b', xs') = mapAccumR f b xs
540 Here is the bi-directional version, that works from both left and right.
543 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
544 -- Function of elt of input list
545 -- and accumulator, returning new
546 -- accumulator and elt of result list
547 -> accl -- Initial accumulator from left
548 -> accr -- Initial accumulator from right
550 -> (accl, accr, [y]) -- Final accumulators and result list
552 mapAccumB f a b [] = (a,b,[])
553 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
555 (a',b'',y) = f a b' x
556 (a'',b',ys) = mapAccumB f a' b xs
559 A strict version of foldl.
562 foldl' :: (a -> b -> a) -> a -> [b] -> a
563 foldl' f z xs = lgo z xs
566 lgo z (x:xs) = (lgo $! (f z x)) xs
569 A combination of foldl with zip. It works with equal length lists.
572 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
574 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
576 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
577 -- True if the lists are the same length, and
578 -- all corresponding elements satisfy the predicate
580 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
584 Count the number of times a predicate is true
587 count :: (a -> Bool) -> [a] -> Int
589 count p (x:xs) | p x = 1 + count p xs
590 | otherwise = count p xs
593 @splitAt@, @take@, and @drop@ but with length of another
594 list giving the break-off point:
597 takeList :: [b] -> [a] -> [a]
602 (y:ys) -> y : takeList xs ys
604 dropList :: [b] -> [a] -> [a]
606 dropList _ xs@[] = xs
607 dropList (_:xs) (_:ys) = dropList xs ys
610 splitAtList :: [b] -> [a] -> ([a], [a])
611 splitAtList [] xs = ([], xs)
612 splitAtList _ xs@[] = (xs, xs)
613 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
615 (ys', ys'') = splitAtList xs ys
617 split :: Char -> String -> [String]
618 split c s = case rest of
620 _:rest -> chunk : split c rest
621 where (chunk, rest) = break (==c) s
625 %************************************************************************
627 \subsection[Utils-comparison]{Comparisons}
629 %************************************************************************
632 isEqual :: Ordering -> Bool
633 -- Often used in (isEqual (a `compare` b))
638 thenCmp :: Ordering -> Ordering -> Ordering
639 {-# INLINE thenCmp #-}
641 thenCmp other any = other
643 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
644 eqListBy eq [] [] = True
645 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
646 eqListBy eq xs ys = False
648 equalLength :: [a] -> [b] -> Bool
649 equalLength [] [] = True
650 equalLength (_:xs) (_:ys) = equalLength xs ys
651 equalLength xs ys = False
653 compareLength :: [a] -> [b] -> Ordering
654 compareLength [] [] = EQ
655 compareLength (_:xs) (_:ys) = compareLength xs ys
656 compareLength [] _ys = LT
657 compareLength _xs [] = GT
659 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
660 -- `cmpList' uses a user-specified comparer
662 cmpList cmp [] [] = EQ
663 cmpList cmp [] _ = LT
664 cmpList cmp _ [] = GT
665 cmpList cmp (a:as) (b:bs)
666 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
670 prefixMatch :: Eq a => [a] -> [a] -> Bool
671 prefixMatch [] _str = True
672 prefixMatch _pat [] = False
673 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
676 maybePrefixMatch :: String -> String -> Maybe String
677 maybePrefixMatch [] rest = Just rest
678 maybePrefixMatch (_:_) [] = Nothing
679 maybePrefixMatch (p:pat) (r:rest)
680 | p == r = maybePrefixMatch pat rest
681 | otherwise = Nothing
683 suffixMatch :: Eq a => [a] -> [a] -> Bool
684 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
686 removeSpaces :: String -> String
687 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
690 %************************************************************************
692 \subsection[Utils-pairs]{Pairs}
694 %************************************************************************
696 The following are curried versions of @fst@ and @snd@.
700 cfst :: a -> b -> a -- stranal-sem only (Note)
705 The following provide us higher order functions that, when applied
706 to a function, operate on pairs.
710 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
711 applyToPair (f,g) (x,y) = (f x, g y)
713 applyToFst :: (a -> c) -> (a,b)-> (c,b)
714 applyToFst f (x,y) = (f x,y)
716 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
717 applyToSnd f (x,y) = (x,f y)
722 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
723 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
727 seqList :: [a] -> b -> b
729 seqList (x:xs) b = x `seq` seqList xs b
735 global :: a -> IORef a
736 global a = unsafePerformIO (newIORef a)
740 consIORef :: IORef [a] -> a -> IO ()
743 writeIORef var (x:xs)
749 looksLikeModuleName [] = False
750 looksLikeModuleName (c:cs) = isUpper c && go cs
752 go ('.':cs) = looksLikeModuleName cs
753 go (c:cs) = (isAlphaNum c || c == '_') && go cs
756 Akin to @Prelude.words@, but sensitive to dquoted entities treating
757 them as single words.
760 toArgs :: String -> [String]
763 case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
765 (\ ws -> if null w then ws else w : ws) $
769 | x /= '"' -> toArgs xs
772 ((str,rs):_) -> stripQuotes str : toArgs rs
775 -- strip away dquotes; assume first and last chars contain quotes.
776 stripQuotes :: String -> String
777 stripQuotes ('"':xs) = init xs
781 -- -----------------------------------------------------------------------------
785 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
786 readRational__ r = do
789 return ((n%1)*10^^(k-d), t)
792 (ds,s) <- lexDecDigits r
793 (ds',t) <- lexDotDigits s
794 return (read (ds++ds'), length ds', t)
796 readExp (e:s) | e `elem` "eE" = readExp' s
797 readExp s = return (0,s)
799 readExp' ('+':s) = readDec s
800 readExp' ('-':s) = do
803 readExp' s = readDec s
806 (ds,r) <- nonnull isDigit s
807 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
810 lexDecDigits = nonnull isDigit
812 lexDotDigits ('.':s) = return (span isDigit s)
813 lexDotDigits s = return ("",s)
815 nonnull p s = do (cs@(_:_),t) <- return (span p s)
818 readRational :: String -> Rational -- NB: *does* handle a leading "-"
821 '-' : xs -> - (read_me xs)
825 = case (do { (x,"") <- readRational__ s ; return x }) of
827 [] -> error ("readRational: no parse:" ++ top_s)
828 _ -> error ("readRational: ambiguous parse:" ++ top_s)
831 -----------------------------------------------------------------------------
832 -- Create a hierarchy of directories
834 createDirectoryHierarchy :: FilePath -> IO ()
835 createDirectoryHierarchy dir = do
836 b <- doesDirectoryExist dir
838 createDirectoryHierarchy (directoryOf dir)
841 -----------------------------------------------------------------------------
842 -- Verify that the 'dirname' portion of a FilePath exists.
844 doesDirNameExist :: FilePath -> IO Bool
845 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
847 -- -----------------------------------------------------------------------------
852 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
853 handleDyn = flip catchDyn
855 handle :: (Exception -> IO a) -> IO a -> IO a
856 #if __GLASGOW_HASKELL__ < 501
857 handle = flip Exception.catchAllIO
859 handle h f = f `Exception.catch` \e -> case e of
860 ExitException _ -> throw e
864 -- --------------------------------------------------------------
865 -- check existence & modification time at the same time
867 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
868 modificationTimeIfExists f = do
869 (do t <- getModificationTime f; return (Just t))
870 `IO.catch` \e -> if isDoesNotExistError e
874 -- --------------------------------------------------------------
875 -- Filename manipulation
877 -- Filenames are kept "normalised" inside GHC, using '/' as the path
878 -- separator. On Windows these functions will also recognise '\\' as
879 -- the path separator, but will generally construct paths using '/'.
883 splitFilename :: String -> (String,Suffix)
884 splitFilename f = splitLongestPrefix f (=='.')
886 basenameOf :: FilePath -> String
887 basenameOf = fst . splitFilename
889 suffixOf :: FilePath -> Suffix
890 suffixOf = snd . splitFilename
892 joinFileExt :: String -> String -> FilePath
893 joinFileExt path "" = path
894 joinFileExt path ext = path ++ '.':ext
896 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
897 splitFilenameDir :: String -> (String,String)
899 = let (dir, rest) = splitLongestPrefix str isPathSeparator
900 (dir', rest') | null rest = (".", dir)
901 | otherwise = (dir, rest)
904 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
905 splitFilename3 :: String -> (String,String,Suffix)
907 = let (dir, rest) = splitFilenameDir str
908 (name, ext) = splitFilename rest
911 joinFileName :: String -> String -> FilePath
912 joinFileName "" fname = fname
913 joinFileName "." fname = fname
914 joinFileName dir "" = dir
915 joinFileName dir fname = dir ++ '/':fname
917 -- split a string at the last character where 'pred' is True,
918 -- returning a pair of strings. The first component holds the string
919 -- up (but not including) the last character for which 'pred' returned
920 -- True, the second whatever comes after (but also not including the
923 -- If 'pred' returns False for all characters in the string, the original
924 -- string is returned in the first component (and the second one is just
926 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
927 splitLongestPrefix str pred
928 | null r_pre = (str, [])
929 | otherwise = (reverse (tail r_pre), reverse r_suf)
930 -- 'tail' drops the char satisfying 'pred'
932 (r_suf, r_pre) = break pred (reverse str)
934 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
935 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
937 -- directoryOf strips the filename off the input string, returning
939 directoryOf :: FilePath -> String
940 directoryOf = fst . splitFilenameDir
942 -- filenameOf strips the directory off the input string, returning
944 filenameOf :: FilePath -> String
945 filenameOf = snd . splitFilenameDir
947 replaceFilenameDirectory :: FilePath -> String -> FilePath
948 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
950 escapeSpaces :: String -> String
951 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
953 isPathSeparator :: Char -> Bool
955 #ifdef mingw32_TARGET_OS
956 ch == '/' || ch == '\\'
961 --------------------------------------------------------------
963 --------------------------------------------------------------
965 -- | The function splits the given string to substrings
966 -- using the 'searchPathSeparator'.
967 parseSearchPath :: String -> [FilePath]
968 parseSearchPath path = split path
970 split :: String -> [String]
974 _:rest -> chunk : split rest
978 #ifdef mingw32_HOST_OS
979 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
983 (chunk', rest') = break (==searchPathSeparator) s
985 -- | A platform-specific character used to separate search path strings in
986 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
987 -- and a semicolon (\";\") on the Windows operating system.
988 searchPathSeparator :: Char
989 #if mingw32_HOST_OS || mingw32_TARGET_OS
990 searchPathSeparator = ';'
992 searchPathSeparator = ':'
995 -----------------------------------------------------------------------------
996 -- Convert filepath into platform / MSDOS form.
998 -- We maintain path names in Unix form ('/'-separated) right until
999 -- the last moment. On Windows we dos-ify them just before passing them
1000 -- to the Windows command.
1002 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1003 -- proved quite awkward. There were a lot more calls to platformPath,
1004 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1005 -- interpreted a command line 'foo\baz' as 'foobaz'.
1007 normalisePath :: String -> String
1008 -- Just changes '\' to '/'
1010 pgmPath :: String -- Directory string in Unix format
1011 -> String -- Program name with no directory separators
1013 -> String -- Program invocation string in native format
1015 #if defined(mingw32_HOST_OS)
1016 --------------------- Windows version ------------------
1017 normalisePath xs = subst '\\' '/' xs
1018 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
1019 platformPath p = subst '/' '\\' p
1021 subst a b ls = map (\ x -> if x == a then b else x) ls
1023 --------------------- Non-Windows version --------------
1024 normalisePath xs = xs
1025 pgmPath dir pgm = dir ++ '/' : pgm
1026 platformPath stuff = stuff
1027 --------------------------------------------------------