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 equalLength :: [a] -> [b] -> Bool
307 equalLength [] [] = True
308 equalLength (_:xs) (_:ys) = equalLength xs ys
309 equalLength xs ys = False
311 compareLength :: [a] -> [b] -> Ordering
312 compareLength [] [] = EQ
313 compareLength (_:xs) (_:ys) = compareLength xs ys
314 compareLength [] _ys = LT
315 compareLength _xs [] = GT
317 ----------------------------
318 singleton :: a -> [a]
321 isSingleton :: [a] -> Bool
322 isSingleton [x] = True
323 isSingleton _ = False
325 notNull :: [a] -> Bool
337 Debugging/specialising versions of \tr{elem} and \tr{notElem}
340 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
343 isIn msg x ys = elem__ x ys
344 isn'tIn msg x ys = notElem__ x ys
346 --these are here to be SPECIALIZEd (automagically)
348 elem__ x (y:ys) = x==y || elem__ x ys
350 notElem__ x [] = True
351 notElem__ x (y:ys) = x /= y && notElem__ x ys
355 = elem (_ILIT 0) x ys
359 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
361 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
364 = notElem (_ILIT 0) x ys
366 notElem i x [] = True
368 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
369 x `List.notElem` (y:ys)
370 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
374 %************************************************************************
376 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
378 %************************************************************************
381 Date: Mon, 3 May 93 20:45:23 +0200
382 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
383 To: partain@dcs.gla.ac.uk
384 Subject: natural merge sort beats quick sort [ and it is prettier ]
386 Here is a piece of Haskell code that I'm rather fond of. See it as an
387 attempt to get rid of the ridiculous quick-sort routine. group is
388 quite useful by itself I think it was John's idea originally though I
389 believe the lazy version is due to me [surprisingly complicated].
390 gamma [used to be called] is called gamma because I got inspired by
391 the Gamma calculus. It is not very close to the calculus but does
392 behave less sequentially than both foldr and foldl. One could imagine
393 a version of gamma that took a unit element as well thereby avoiding
394 the problem with empty lists.
396 I've tried this code against
398 1) insertion sort - as provided by haskell
399 2) the normal implementation of quick sort
400 3) a deforested version of quick sort due to Jan Sparud
401 4) a super-optimized-quick-sort of Lennart's
403 If the list is partially sorted both merge sort and in particular
404 natural merge sort wins. If the list is random [ average length of
405 rising subsequences = approx 2 ] mergesort still wins and natural
406 merge sort is marginally beaten by Lennart's soqs. The space
407 consumption of merge sort is a bit worse than Lennart's quick sort
408 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
409 fpca article ] isn't used because of group.
416 group :: (a -> a -> Bool) -> [a] -> [[a]]
417 -- Given a <= function, group finds maximal contiguous up-runs
418 -- or down-runs in the input list.
419 -- It's stable, in the sense that it never re-orders equal elements
421 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
422 -- From: Andy Gill <andy@dcs.gla.ac.uk>
423 -- Here is a `better' definition of group.
426 group p (x:xs) = group' xs x x (x :)
428 group' [] _ _ s = [s []]
429 group' (x:xs) x_min x_max s
430 | x_max `p` x = group' xs x_min x (s . (x :))
431 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
432 | otherwise = s [] : group' xs x x (x :)
433 -- NB: the 'not' is essential for stablity
434 -- x `p` x_min would reverse equal elements
436 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
437 generalMerge p xs [] = xs
438 generalMerge p [] ys = ys
439 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
440 | otherwise = y : generalMerge p (x:xs) ys
442 -- gamma is now called balancedFold
444 balancedFold :: (a -> a -> a) -> [a] -> a
445 balancedFold f [] = error "can't reduce an empty list using balancedFold"
446 balancedFold f [x] = x
447 balancedFold f l = balancedFold f (balancedFold' f l)
449 balancedFold' :: (a -> a -> a) -> [a] -> [a]
450 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
451 balancedFold' f xs = xs
453 generalNaturalMergeSort p [] = []
454 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
457 generalMergeSort p [] = []
458 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
460 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
462 mergeSort = generalMergeSort (<=)
463 naturalMergeSort = generalNaturalMergeSort (<=)
465 mergeSortLe le = generalMergeSort le
468 sortLe :: (a->a->Bool) -> [a] -> [a]
469 sortLe le = generalNaturalMergeSort le
471 sortWith :: Ord b => (a->b) -> [a] -> [a]
472 sortWith get_key xs = sortLe le xs
474 x `le` y = get_key x < get_key y
477 %************************************************************************
479 \subsection[Utils-transitive-closure]{Transitive closure}
481 %************************************************************************
483 This algorithm for transitive closure is straightforward, albeit quadratic.
486 transitiveClosure :: (a -> [a]) -- Successor function
487 -> (a -> a -> Bool) -- Equality predicate
489 -> [a] -- The transitive closure
491 transitiveClosure succ eq xs
495 go done (x:xs) | x `is_in` done = go done xs
496 | otherwise = go (x:done) (succ x ++ xs)
499 x `is_in` (y:ys) | eq x y = True
500 | otherwise = x `is_in` ys
503 %************************************************************************
505 \subsection[Utils-accum]{Accumulating}
507 %************************************************************************
509 @mapAccumL@ behaves like a combination
510 of @map@ and @foldl@;
511 it applies a function to each element of a list, passing an accumulating
512 parameter from left to right, and returning a final value of this
513 accumulator together with the new list.
516 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
517 -- and accumulator, returning new
518 -- accumulator and elt of result list
519 -> acc -- Initial accumulator
521 -> (acc, [y]) -- Final accumulator and result list
523 mapAccumL f b [] = (b, [])
524 mapAccumL f b (x:xs) = (b'', x':xs') where
526 (b'', xs') = mapAccumL f b' xs
529 @mapAccumR@ does the same, but working from right to left instead. Its type is
530 the same as @mapAccumL@, though.
533 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
534 -- and accumulator, returning new
535 -- accumulator and elt of result list
536 -> acc -- Initial accumulator
538 -> (acc, [y]) -- Final accumulator and result list
540 mapAccumR f b [] = (b, [])
541 mapAccumR f b (x:xs) = (b'', x':xs') where
543 (b', xs') = mapAccumR f b xs
546 Here is the bi-directional version, that works from both left and right.
549 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
550 -- Function of elt of input list
551 -- and accumulator, returning new
552 -- accumulator and elt of result list
553 -> accl -- Initial accumulator from left
554 -> accr -- Initial accumulator from right
556 -> (accl, accr, [y]) -- Final accumulators and result list
558 mapAccumB f a b [] = (a,b,[])
559 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
561 (a',b'',y) = f a b' x
562 (a'',b',ys) = mapAccumB f a' b xs
565 A strict version of foldl.
568 foldl' :: (a -> b -> a) -> a -> [b] -> a
569 foldl' f z xs = lgo z xs
572 lgo z (x:xs) = (lgo $! (f z x)) xs
575 A combination of foldl with zip. It works with equal length lists.
578 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
580 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
582 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
583 -- True if the lists are the same length, and
584 -- all corresponding elements satisfy the predicate
586 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
590 Count the number of times a predicate is true
593 count :: (a -> Bool) -> [a] -> Int
595 count p (x:xs) | p x = 1 + count p xs
596 | otherwise = count p xs
599 @splitAt@, @take@, and @drop@ but with length of another
600 list giving the break-off point:
603 takeList :: [b] -> [a] -> [a]
608 (y:ys) -> y : takeList xs ys
610 dropList :: [b] -> [a] -> [a]
612 dropList _ xs@[] = xs
613 dropList (_:xs) (_:ys) = dropList xs ys
616 splitAtList :: [b] -> [a] -> ([a], [a])
617 splitAtList [] xs = ([], xs)
618 splitAtList _ xs@[] = (xs, xs)
619 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
621 (ys', ys'') = splitAtList xs ys
623 snocView :: [a] -> Maybe ([a],a)
624 -- Split off the last element
625 snocView [] = Nothing
626 snocView xs = go [] xs
628 -- Invariant: second arg is non-empty
629 go acc [x] = Just (reverse acc, x)
630 go acc (x:xs) = go (x:acc) xs
632 split :: Char -> String -> [String]
633 split c s = case rest of
635 _:rest -> chunk : split c rest
636 where (chunk, rest) = break (==c) s
640 %************************************************************************
642 \subsection[Utils-comparison]{Comparisons}
644 %************************************************************************
647 isEqual :: Ordering -> Bool
648 -- Often used in (isEqual (a `compare` b))
653 thenCmp :: Ordering -> Ordering -> Ordering
654 {-# INLINE thenCmp #-}
656 thenCmp other any = other
658 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
659 eqListBy eq [] [] = True
660 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
661 eqListBy eq xs ys = False
663 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
664 -- `cmpList' uses a user-specified comparer
666 cmpList cmp [] [] = EQ
667 cmpList cmp [] _ = LT
668 cmpList cmp _ [] = GT
669 cmpList cmp (a:as) (b:bs)
670 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
674 prefixMatch :: Eq a => [a] -> [a] -> Bool
675 prefixMatch [] _str = True
676 prefixMatch _pat [] = False
677 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
680 maybePrefixMatch :: String -> String -> Maybe String
681 maybePrefixMatch [] rest = Just rest
682 maybePrefixMatch (_:_) [] = Nothing
683 maybePrefixMatch (p:pat) (r:rest)
684 | p == r = maybePrefixMatch pat rest
685 | otherwise = Nothing
687 suffixMatch :: Eq a => [a] -> [a] -> Bool
688 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
690 removeSpaces :: String -> String
691 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
694 %************************************************************************
696 \subsection[Utils-pairs]{Pairs}
698 %************************************************************************
700 The following are curried versions of @fst@ and @snd@.
704 cfst :: a -> b -> a -- stranal-sem only (Note)
709 The following provide us higher order functions that, when applied
710 to a function, operate on pairs.
714 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
715 applyToPair (f,g) (x,y) = (f x, g y)
717 applyToFst :: (a -> c) -> (a,b)-> (c,b)
718 applyToFst f (x,y) = (f x,y)
720 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
721 applyToSnd f (x,y) = (x,f y)
726 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
727 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
731 seqList :: [a] -> b -> b
733 seqList (x:xs) b = x `seq` seqList xs b
739 global :: a -> IORef a
740 global a = unsafePerformIO (newIORef a)
744 consIORef :: IORef [a] -> a -> IO ()
747 writeIORef var (x:xs)
753 looksLikeModuleName [] = False
754 looksLikeModuleName (c:cs) = isUpper c && go cs
756 go ('.':cs) = looksLikeModuleName cs
757 go (c:cs) = (isAlphaNum c || c == '_') && go cs
760 Akin to @Prelude.words@, but sensitive to dquoted entities treating
761 them as single words.
764 toArgs :: String -> [String]
767 case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
769 (\ ws -> if null w then ws else w : ws) $
773 | x /= '"' -> toArgs xs
776 ((str,rs):_) -> stripQuotes str : toArgs rs
779 -- strip away dquotes; assume first and last chars contain quotes.
780 stripQuotes :: String -> String
781 stripQuotes ('"':xs) = init xs
785 -- -----------------------------------------------------------------------------
789 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
790 readRational__ r = do
793 return ((n%1)*10^^(k-d), t)
796 (ds,s) <- lexDecDigits r
797 (ds',t) <- lexDotDigits s
798 return (read (ds++ds'), length ds', t)
800 readExp (e:s) | e `elem` "eE" = readExp' s
801 readExp s = return (0,s)
803 readExp' ('+':s) = readDec s
804 readExp' ('-':s) = do
807 readExp' s = readDec s
810 (ds,r) <- nonnull isDigit s
811 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
814 lexDecDigits = nonnull isDigit
816 lexDotDigits ('.':s) = return (span isDigit s)
817 lexDotDigits s = return ("",s)
819 nonnull p s = do (cs@(_:_),t) <- return (span p s)
822 readRational :: String -> Rational -- NB: *does* handle a leading "-"
825 '-' : xs -> - (read_me xs)
829 = case (do { (x,"") <- readRational__ s ; return x }) of
831 [] -> error ("readRational: no parse:" ++ top_s)
832 _ -> error ("readRational: ambiguous parse:" ++ top_s)
835 -----------------------------------------------------------------------------
836 -- Create a hierarchy of directories
838 createDirectoryHierarchy :: FilePath -> IO ()
839 createDirectoryHierarchy dir = do
840 b <- doesDirectoryExist dir
842 createDirectoryHierarchy (directoryOf dir)
845 -----------------------------------------------------------------------------
846 -- Verify that the 'dirname' portion of a FilePath exists.
848 doesDirNameExist :: FilePath -> IO Bool
849 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
851 -- -----------------------------------------------------------------------------
856 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
857 handleDyn = flip catchDyn
859 handle :: (Exception -> IO a) -> IO a -> IO a
860 #if __GLASGOW_HASKELL__ < 501
861 handle = flip Exception.catchAllIO
863 handle h f = f `Exception.catch` \e -> case e of
864 ExitException _ -> throw e
868 -- --------------------------------------------------------------
869 -- check existence & modification time at the same time
871 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
872 modificationTimeIfExists f = do
873 (do t <- getModificationTime f; return (Just t))
874 `IO.catch` \e -> if isDoesNotExistError e
878 -- --------------------------------------------------------------
879 -- Filename manipulation
881 -- Filenames are kept "normalised" inside GHC, using '/' as the path
882 -- separator. On Windows these functions will also recognise '\\' as
883 -- the path separator, but will generally construct paths using '/'.
887 splitFilename :: String -> (String,Suffix)
888 splitFilename f = splitLongestPrefix f (=='.')
890 basenameOf :: FilePath -> String
891 basenameOf = fst . splitFilename
893 suffixOf :: FilePath -> Suffix
894 suffixOf = snd . splitFilename
896 joinFileExt :: String -> String -> FilePath
897 joinFileExt path "" = path
898 joinFileExt path ext = path ++ '.':ext
900 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
901 splitFilenameDir :: String -> (String,String)
903 = let (dir, rest) = splitLongestPrefix str isPathSeparator
904 (dir', rest') | null rest = (".", dir)
905 | otherwise = (dir, rest)
908 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
909 splitFilename3 :: String -> (String,String,Suffix)
911 = let (dir, rest) = splitFilenameDir str
912 (name, ext) = splitFilename rest
915 joinFileName :: String -> String -> FilePath
916 joinFileName "" fname = fname
917 joinFileName "." fname = fname
918 joinFileName dir "" = dir
919 joinFileName dir fname = dir ++ '/':fname
921 -- split a string at the last character where 'pred' is True,
922 -- returning a pair of strings. The first component holds the string
923 -- up (but not including) the last character for which 'pred' returned
924 -- True, the second whatever comes after (but also not including the
927 -- If 'pred' returns False for all characters in the string, the original
928 -- string is returned in the first component (and the second one is just
930 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
931 splitLongestPrefix str pred
932 | null r_pre = (str, [])
933 | otherwise = (reverse (tail r_pre), reverse r_suf)
934 -- 'tail' drops the char satisfying 'pred'
936 (r_suf, r_pre) = break pred (reverse str)
938 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
939 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
941 -- directoryOf strips the filename off the input string, returning
943 directoryOf :: FilePath -> String
944 directoryOf = fst . splitFilenameDir
946 -- filenameOf strips the directory off the input string, returning
948 filenameOf :: FilePath -> String
949 filenameOf = snd . splitFilenameDir
951 replaceFilenameDirectory :: FilePath -> String -> FilePath
952 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
954 escapeSpaces :: String -> String
955 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
957 isPathSeparator :: Char -> Bool
959 #ifdef mingw32_TARGET_OS
960 ch == '/' || ch == '\\'
965 --------------------------------------------------------------
967 --------------------------------------------------------------
969 -- | The function splits the given string to substrings
970 -- using the 'searchPathSeparator'.
971 parseSearchPath :: String -> [FilePath]
972 parseSearchPath path = split path
974 split :: String -> [String]
978 _:rest -> chunk : split rest
982 #ifdef mingw32_HOST_OS
983 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
987 (chunk', rest') = break (==searchPathSeparator) s
989 -- | A platform-specific character used to separate search path strings in
990 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
991 -- and a semicolon (\";\") on the Windows operating system.
992 searchPathSeparator :: Char
993 #if mingw32_HOST_OS || mingw32_TARGET_OS
994 searchPathSeparator = ';'
996 searchPathSeparator = ':'
999 -----------------------------------------------------------------------------
1000 -- Convert filepath into platform / MSDOS form.
1002 -- We maintain path names in Unix form ('/'-separated) right until
1003 -- the last moment. On Windows we dos-ify them just before passing them
1004 -- to the Windows command.
1006 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1007 -- proved quite awkward. There were a lot more calls to platformPath,
1008 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1009 -- interpreted a command line 'foo\baz' as 'foobaz'.
1011 normalisePath :: String -> String
1012 -- Just changes '\' to '/'
1014 pgmPath :: String -- Directory string in Unix format
1015 -> String -- Program name with no directory separators
1017 -> String -- Program invocation string in native format
1019 #if defined(mingw32_HOST_OS)
1020 --------------------- Windows version ------------------
1021 normalisePath xs = subst '\\' '/' xs
1022 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
1023 platformPath p = subst '/' '\\' p
1025 subst a b ls = map (\ x -> if x == a then b else x) ls
1027 --------------------- Non-Windows version --------------
1028 normalisePath xs = xs
1029 pgmPath dir pgm = dir ++ '/' : pgm
1030 platformPath stuff = stuff
1031 --------------------------------------------------------