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
329 snocView :: [a] -> Maybe ([a],a)
330 -- Split off the last element
331 snocView [] = Nothing
332 snocView xs = go [] xs
334 -- Invariant: second arg is non-empty
335 go acc [x] = Just (reverse acc, x)
336 go acc (x:xs) = go (x:acc) xs
346 Debugging/specialising versions of \tr{elem} and \tr{notElem}
349 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
352 isIn msg x ys = elem__ x ys
353 isn'tIn msg x ys = notElem__ x ys
355 --these are here to be SPECIALIZEd (automagically)
357 elem__ x (y:ys) = x==y || elem__ x ys
359 notElem__ x [] = True
360 notElem__ x (y:ys) = x /= y && notElem__ x ys
364 = elem (_ILIT 0) x ys
368 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
370 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
373 = notElem (_ILIT 0) x ys
375 notElem i x [] = True
377 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
378 x `List.notElem` (y:ys)
379 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
383 %************************************************************************
385 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
387 %************************************************************************
390 Date: Mon, 3 May 93 20:45:23 +0200
391 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
392 To: partain@dcs.gla.ac.uk
393 Subject: natural merge sort beats quick sort [ and it is prettier ]
395 Here is a piece of Haskell code that I'm rather fond of. See it as an
396 attempt to get rid of the ridiculous quick-sort routine. group is
397 quite useful by itself I think it was John's idea originally though I
398 believe the lazy version is due to me [surprisingly complicated].
399 gamma [used to be called] is called gamma because I got inspired by
400 the Gamma calculus. It is not very close to the calculus but does
401 behave less sequentially than both foldr and foldl. One could imagine
402 a version of gamma that took a unit element as well thereby avoiding
403 the problem with empty lists.
405 I've tried this code against
407 1) insertion sort - as provided by haskell
408 2) the normal implementation of quick sort
409 3) a deforested version of quick sort due to Jan Sparud
410 4) a super-optimized-quick-sort of Lennart's
412 If the list is partially sorted both merge sort and in particular
413 natural merge sort wins. If the list is random [ average length of
414 rising subsequences = approx 2 ] mergesort still wins and natural
415 merge sort is marginally beaten by Lennart's soqs. The space
416 consumption of merge sort is a bit worse than Lennart's quick sort
417 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
418 fpca article ] isn't used because of group.
425 group :: (a -> a -> Bool) -> [a] -> [[a]]
426 -- Given a <= function, group finds maximal contiguous up-runs
427 -- or down-runs in the input list.
428 -- It's stable, in the sense that it never re-orders equal elements
430 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
431 -- From: Andy Gill <andy@dcs.gla.ac.uk>
432 -- Here is a `better' definition of group.
435 group p (x:xs) = group' xs x x (x :)
437 group' [] _ _ s = [s []]
438 group' (x:xs) x_min x_max s
439 | x_max `p` x = group' xs x_min x (s . (x :))
440 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
441 | otherwise = s [] : group' xs x x (x :)
442 -- NB: the 'not' is essential for stablity
443 -- x `p` x_min would reverse equal elements
445 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
446 generalMerge p xs [] = xs
447 generalMerge p [] ys = ys
448 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
449 | otherwise = y : generalMerge p (x:xs) ys
451 -- gamma is now called balancedFold
453 balancedFold :: (a -> a -> a) -> [a] -> a
454 balancedFold f [] = error "can't reduce an empty list using balancedFold"
455 balancedFold f [x] = x
456 balancedFold f l = balancedFold f (balancedFold' f l)
458 balancedFold' :: (a -> a -> a) -> [a] -> [a]
459 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
460 balancedFold' f xs = xs
462 generalNaturalMergeSort p [] = []
463 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
466 generalMergeSort p [] = []
467 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
469 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
471 mergeSort = generalMergeSort (<=)
472 naturalMergeSort = generalNaturalMergeSort (<=)
474 mergeSortLe le = generalMergeSort le
477 sortLe :: (a->a->Bool) -> [a] -> [a]
478 sortLe le = generalNaturalMergeSort le
480 sortWith :: Ord b => (a->b) -> [a] -> [a]
481 sortWith get_key xs = sortLe le xs
483 x `le` y = get_key x < get_key y
486 %************************************************************************
488 \subsection[Utils-transitive-closure]{Transitive closure}
490 %************************************************************************
492 This algorithm for transitive closure is straightforward, albeit quadratic.
495 transitiveClosure :: (a -> [a]) -- Successor function
496 -> (a -> a -> Bool) -- Equality predicate
498 -> [a] -- The transitive closure
500 transitiveClosure succ eq xs
504 go done (x:xs) | x `is_in` done = go done xs
505 | otherwise = go (x:done) (succ x ++ xs)
508 x `is_in` (y:ys) | eq x y = True
509 | otherwise = x `is_in` ys
512 %************************************************************************
514 \subsection[Utils-accum]{Accumulating}
516 %************************************************************************
518 @mapAccumL@ behaves like a combination
519 of @map@ and @foldl@;
520 it applies a function to each element of a list, passing an accumulating
521 parameter from left to right, and returning a final value of this
522 accumulator together with the new list.
525 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
526 -- and accumulator, returning new
527 -- accumulator and elt of result list
528 -> acc -- Initial accumulator
530 -> (acc, [y]) -- Final accumulator and result list
532 mapAccumL f b [] = (b, [])
533 mapAccumL f b (x:xs) = (b'', x':xs') where
535 (b'', xs') = mapAccumL f b' xs
538 @mapAccumR@ does the same, but working from right to left instead. Its type is
539 the same as @mapAccumL@, though.
542 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
543 -- and accumulator, returning new
544 -- accumulator and elt of result list
545 -> acc -- Initial accumulator
547 -> (acc, [y]) -- Final accumulator and result list
549 mapAccumR f b [] = (b, [])
550 mapAccumR f b (x:xs) = (b'', x':xs') where
552 (b', xs') = mapAccumR f b xs
555 Here is the bi-directional version, that works from both left and right.
558 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
559 -- Function of elt of input list
560 -- and accumulator, returning new
561 -- accumulator and elt of result list
562 -> accl -- Initial accumulator from left
563 -> accr -- Initial accumulator from right
565 -> (accl, accr, [y]) -- Final accumulators and result list
567 mapAccumB f a b [] = (a,b,[])
568 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
570 (a',b'',y) = f a b' x
571 (a'',b',ys) = mapAccumB f a' b xs
574 A strict version of foldl.
577 foldl' :: (a -> b -> a) -> a -> [b] -> a
578 foldl' f z xs = lgo z xs
581 lgo z (x:xs) = (lgo $! (f z x)) xs
584 A combination of foldl with zip. It works with equal length lists.
587 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
589 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
591 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
592 -- True if the lists are the same length, and
593 -- all corresponding elements satisfy the predicate
595 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
599 Count the number of times a predicate is true
602 count :: (a -> Bool) -> [a] -> Int
604 count p (x:xs) | p x = 1 + count p xs
605 | otherwise = count p xs
608 @splitAt@, @take@, and @drop@ but with length of another
609 list giving the break-off point:
612 takeList :: [b] -> [a] -> [a]
617 (y:ys) -> y : takeList xs ys
619 dropList :: [b] -> [a] -> [a]
621 dropList _ xs@[] = xs
622 dropList (_:xs) (_:ys) = dropList xs ys
625 splitAtList :: [b] -> [a] -> ([a], [a])
626 splitAtList [] xs = ([], xs)
627 splitAtList _ xs@[] = (xs, xs)
628 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
630 (ys', ys'') = splitAtList xs ys
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 --------------------------------------------------------