2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow 1992-2002
5 \section[Util]{Highly random utility functions}
10 -- general list processing
11 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
12 zipLazy, stretchZipWith,
14 mapAndUnzip, mapAndUnzip3,
15 nOfThem, filterOut, partitionWith, splitEithers,
17 lengthExceeds, lengthIs, lengthAtLeast,
18 listLengthCmp, atLength, equalLength, compareLength,
20 isSingleton, only, singleton,
31 -- transitive closures
35 mapAccumL, mapAccumR, mapAccumB,
38 takeList, dropList, splitAtList, split,
42 thenCmp, cmpList, maybePrefixMatch,
58 -- Floating point stuff
62 createDirectoryHierarchy,
64 modificationTimeIfExists,
66 later, handleDyn, handle,
70 splitFilename, suffixOf, basenameOf, joinFileExt,
71 splitFilenameDir, joinFileName,
74 replaceFilenameSuffix, directoryOf, filenameOf,
75 replaceFilenameDirectory,
76 escapeSpaces, isPathSeparator,
78 normalisePath, platformPath, pgmPath,
81 #include "HsVersions.h"
83 import Panic ( panic, trace )
86 import Control.Exception ( Exception(..), finally, catchDyn, throw )
87 import qualified Control.Exception as Exception
88 import Data.Dynamic ( Typeable )
89 import Data.IORef ( IORef, newIORef )
90 import System.IO.Unsafe ( unsafePerformIO )
91 import Data.IORef ( readIORef, writeIORef )
93 import qualified Data.List as List ( elem, notElem )
96 import Data.List ( zipWith4 )
99 import Control.Monad ( when )
100 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
101 import System.Directory ( doesDirectoryExist, createDirectory,
102 getModificationTime )
103 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
104 import Data.Ratio ( (%) )
105 import System.Time ( ClockTime )
110 %************************************************************************
112 \subsection{A for loop}
114 %************************************************************************
117 -- Compose a function with itself n times. (nth rather than twice)
118 nTimes :: Int -> (a -> a) -> (a -> a)
121 nTimes n f = f . nTimes (n-1) f
124 %************************************************************************
126 \subsection[Utils-lists]{General list processing}
128 %************************************************************************
131 filterOut :: (a->Bool) -> [a] -> [a]
132 -- Like filter, only reverses the sense of the test
134 filterOut p (x:xs) | p x = filterOut p xs
135 | otherwise = x : filterOut p xs
137 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
138 partitionWith f [] = ([],[])
139 partitionWith f (x:xs) = case f x of
141 Right c -> (bs, c:cs)
143 (bs,cs) = partitionWith f xs
145 splitEithers :: [Either a b] -> ([a], [b])
146 splitEithers [] = ([],[])
147 splitEithers (e : es) = case e of
149 Right y -> (xs, y:ys)
151 (xs,ys) = splitEithers es
154 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
155 are of equal length. Alastair Reid thinks this should only happen if
156 DEBUGging on; hey, why not?
159 zipEqual :: String -> [a] -> [b] -> [(a,b)]
160 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
161 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
162 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
166 zipWithEqual _ = zipWith
167 zipWith3Equal _ = zipWith3
168 zipWith4Equal _ = zipWith4
170 zipEqual msg [] [] = []
171 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
172 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
174 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
175 zipWithEqual msg _ [] [] = []
176 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
178 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
179 = z a b c : zipWith3Equal msg z as bs cs
180 zipWith3Equal msg _ [] [] [] = []
181 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
183 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
184 = z a b c d : zipWith4Equal msg z as bs cs ds
185 zipWith4Equal msg _ [] [] [] [] = []
186 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
191 -- zipLazy is lazy in the second list (observe the ~)
193 zipLazy :: [a] -> [b] -> [(a,b)]
195 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
200 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
201 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
202 -- the places where p returns *True*
204 stretchZipWith p z f [] ys = []
205 stretchZipWith p z f (x:xs) ys
206 | p x = f x z : stretchZipWith p z f xs ys
207 | otherwise = case ys of
209 (y:ys) -> f x y : stretchZipWith p z f xs ys
214 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
215 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
217 mapFst f xys = [(f x, y) | (x,y) <- xys]
218 mapSnd f xys = [(x, f y) | (x,y) <- xys]
220 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
222 mapAndUnzip f [] = ([],[])
226 (rs1, rs2) = mapAndUnzip f xs
230 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
232 mapAndUnzip3 f [] = ([],[],[])
233 mapAndUnzip3 f (x:xs)
236 (rs1, rs2, rs3) = mapAndUnzip3 f xs
238 (r1:rs1, r2:rs2, r3:rs3)
242 nOfThem :: Int -> a -> [a]
243 nOfThem n thing = replicate n thing
245 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
248 -- atLength atLenPred atEndPred ls n
249 -- | n < 0 = atLenPred n
250 -- | length ls < n = atEndPred (n - length ls)
251 -- | otherwise = atLenPred (drop n ls)
253 atLength :: ([a] -> b)
258 atLength atLenPred atEndPred ls n
259 | n < 0 = atEndPred n
260 | otherwise = go n ls
262 go n [] = atEndPred n
263 go 0 ls = atLenPred ls
264 go n (_:xs) = go (n-1) xs
267 lengthExceeds :: [a] -> Int -> Bool
268 -- (lengthExceeds xs n) = (length xs > n)
269 lengthExceeds = atLength notNull (const False)
271 lengthAtLeast :: [a] -> Int -> Bool
272 lengthAtLeast = atLength notNull (== 0)
274 lengthIs :: [a] -> Int -> Bool
275 lengthIs = atLength null (==0)
277 listLengthCmp :: [a] -> Int -> Ordering
278 listLengthCmp = atLength atLen atEnd
282 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
288 equalLength :: [a] -> [b] -> Bool
289 equalLength [] [] = True
290 equalLength (_:xs) (_:ys) = equalLength xs ys
291 equalLength xs ys = False
293 compareLength :: [a] -> [b] -> Ordering
294 compareLength [] [] = EQ
295 compareLength (_:xs) (_:ys) = compareLength xs ys
296 compareLength [] _ys = LT
297 compareLength _xs [] = GT
299 ----------------------------
300 singleton :: a -> [a]
303 isSingleton :: [a] -> Bool
304 isSingleton [x] = True
305 isSingleton _ = False
307 notNull :: [a] -> Bool
319 Debugging/specialising versions of \tr{elem} and \tr{notElem}
322 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
325 isIn msg x ys = elem__ x ys
326 isn'tIn msg x ys = notElem__ x ys
328 --these are here to be SPECIALIZEd (automagically)
330 elem__ x (y:ys) = x==y || elem__ x ys
332 notElem__ x [] = True
333 notElem__ x (y:ys) = x /= y && notElem__ x ys
337 = elem (_ILIT 0) x ys
341 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
343 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
346 = notElem (_ILIT 0) x ys
348 notElem i x [] = True
350 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
351 x `List.notElem` (y:ys)
352 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
356 %************************************************************************
358 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
360 %************************************************************************
363 Date: Mon, 3 May 93 20:45:23 +0200
364 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
365 To: partain@dcs.gla.ac.uk
366 Subject: natural merge sort beats quick sort [ and it is prettier ]
368 Here is a piece of Haskell code that I'm rather fond of. See it as an
369 attempt to get rid of the ridiculous quick-sort routine. group is
370 quite useful by itself I think it was John's idea originally though I
371 believe the lazy version is due to me [surprisingly complicated].
372 gamma [used to be called] is called gamma because I got inspired by
373 the Gamma calculus. It is not very close to the calculus but does
374 behave less sequentially than both foldr and foldl. One could imagine
375 a version of gamma that took a unit element as well thereby avoiding
376 the problem with empty lists.
378 I've tried this code against
380 1) insertion sort - as provided by haskell
381 2) the normal implementation of quick sort
382 3) a deforested version of quick sort due to Jan Sparud
383 4) a super-optimized-quick-sort of Lennart's
385 If the list is partially sorted both merge sort and in particular
386 natural merge sort wins. If the list is random [ average length of
387 rising subsequences = approx 2 ] mergesort still wins and natural
388 merge sort is marginally beaten by Lennart's soqs. The space
389 consumption of merge sort is a bit worse than Lennart's quick sort
390 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
391 fpca article ] isn't used because of group.
398 group :: (a -> a -> Bool) -> [a] -> [[a]]
399 -- Given a <= function, group finds maximal contiguous up-runs
400 -- or down-runs in the input list.
401 -- It's stable, in the sense that it never re-orders equal elements
403 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
404 -- From: Andy Gill <andy@dcs.gla.ac.uk>
405 -- Here is a `better' definition of group.
408 group p (x:xs) = group' xs x x (x :)
410 group' [] _ _ s = [s []]
411 group' (x:xs) x_min x_max s
412 | x_max `p` x = group' xs x_min x (s . (x :))
413 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
414 | otherwise = s [] : group' xs x x (x :)
415 -- NB: the 'not' is essential for stablity
416 -- x `p` x_min would reverse equal elements
418 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
419 generalMerge p xs [] = xs
420 generalMerge p [] ys = ys
421 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
422 | otherwise = y : generalMerge p (x:xs) ys
424 -- gamma is now called balancedFold
426 balancedFold :: (a -> a -> a) -> [a] -> a
427 balancedFold f [] = error "can't reduce an empty list using balancedFold"
428 balancedFold f [x] = x
429 balancedFold f l = balancedFold f (balancedFold' f l)
431 balancedFold' :: (a -> a -> a) -> [a] -> [a]
432 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
433 balancedFold' f xs = xs
435 generalNaturalMergeSort p [] = []
436 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
439 generalMergeSort p [] = []
440 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
442 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
444 mergeSort = generalMergeSort (<=)
445 naturalMergeSort = generalNaturalMergeSort (<=)
447 mergeSortLe le = generalMergeSort le
450 sortLe :: (a->a->Bool) -> [a] -> [a]
451 sortLe le = generalNaturalMergeSort le
453 sortWith :: Ord b => (a->b) -> [a] -> [a]
454 sortWith get_key xs = sortLe le xs
456 x `le` y = get_key x < get_key y
459 %************************************************************************
461 \subsection[Utils-transitive-closure]{Transitive closure}
463 %************************************************************************
465 This algorithm for transitive closure is straightforward, albeit quadratic.
468 transitiveClosure :: (a -> [a]) -- Successor function
469 -> (a -> a -> Bool) -- Equality predicate
471 -> [a] -- The transitive closure
473 transitiveClosure succ eq xs
477 go done (x:xs) | x `is_in` done = go done xs
478 | otherwise = go (x:done) (succ x ++ xs)
481 x `is_in` (y:ys) | eq x y = True
482 | otherwise = x `is_in` ys
485 %************************************************************************
487 \subsection[Utils-accum]{Accumulating}
489 %************************************************************************
491 @mapAccumL@ behaves like a combination
492 of @map@ and @foldl@;
493 it applies a function to each element of a list, passing an accumulating
494 parameter from left to right, and returning a final value of this
495 accumulator together with the new list.
498 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
499 -- and accumulator, returning new
500 -- accumulator and elt of result list
501 -> acc -- Initial accumulator
503 -> (acc, [y]) -- Final accumulator and result list
505 mapAccumL f b [] = (b, [])
506 mapAccumL f b (x:xs) = (b'', x':xs') where
508 (b'', xs') = mapAccumL f b' xs
511 @mapAccumR@ does the same, but working from right to left instead. Its type is
512 the same as @mapAccumL@, though.
515 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
516 -- and accumulator, returning new
517 -- accumulator and elt of result list
518 -> acc -- Initial accumulator
520 -> (acc, [y]) -- Final accumulator and result list
522 mapAccumR f b [] = (b, [])
523 mapAccumR f b (x:xs) = (b'', x':xs') where
525 (b', xs') = mapAccumR f b xs
528 Here is the bi-directional version, that works from both left and right.
531 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
532 -- Function of elt of input list
533 -- and accumulator, returning new
534 -- accumulator and elt of result list
535 -> accl -- Initial accumulator from left
536 -> accr -- Initial accumulator from right
538 -> (accl, accr, [y]) -- Final accumulators and result list
540 mapAccumB f a b [] = (a,b,[])
541 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
543 (a',b'',y) = f a b' x
544 (a'',b',ys) = mapAccumB f a' b xs
547 A strict version of foldl.
550 foldl' :: (a -> b -> a) -> a -> [b] -> a
551 foldl' f z xs = lgo z xs
554 lgo z (x:xs) = (lgo $! (f z x)) xs
557 A combination of foldl with zip. It works with equal length lists.
560 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
562 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
564 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
565 -- True if the lists are the same length, and
566 -- all corresponding elements satisfy the predicate
568 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
572 Count the number of times a predicate is true
575 count :: (a -> Bool) -> [a] -> Int
577 count p (x:xs) | p x = 1 + count p xs
578 | otherwise = count p xs
581 @splitAt@, @take@, and @drop@ but with length of another
582 list giving the break-off point:
585 takeList :: [b] -> [a] -> [a]
590 (y:ys) -> y : takeList xs ys
592 dropList :: [b] -> [a] -> [a]
594 dropList _ xs@[] = xs
595 dropList (_:xs) (_:ys) = dropList xs ys
598 splitAtList :: [b] -> [a] -> ([a], [a])
599 splitAtList [] xs = ([], xs)
600 splitAtList _ xs@[] = (xs, xs)
601 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
603 (ys', ys'') = splitAtList xs ys
605 snocView :: [a] -> Maybe ([a],a)
606 -- Split off the last element
607 snocView [] = Nothing
608 snocView xs = go [] xs
610 -- Invariant: second arg is non-empty
611 go acc [x] = Just (reverse acc, x)
612 go acc (x:xs) = go (x:acc) xs
614 split :: Char -> String -> [String]
615 split c s = case rest of
617 _:rest -> chunk : split c rest
618 where (chunk, rest) = break (==c) s
622 %************************************************************************
624 \subsection[Utils-comparison]{Comparisons}
626 %************************************************************************
629 isEqual :: Ordering -> Bool
630 -- Often used in (isEqual (a `compare` b))
635 thenCmp :: Ordering -> Ordering -> Ordering
636 {-# INLINE thenCmp #-}
638 thenCmp other any = other
640 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
641 eqListBy eq [] [] = True
642 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
643 eqListBy eq xs ys = False
645 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
646 -- `cmpList' uses a user-specified comparer
648 cmpList cmp [] [] = EQ
649 cmpList cmp [] _ = LT
650 cmpList cmp _ [] = GT
651 cmpList cmp (a:as) (b:bs)
652 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
656 maybePrefixMatch :: String -> String -> Maybe String
657 maybePrefixMatch [] rest = Just rest
658 maybePrefixMatch (_:_) [] = Nothing
659 maybePrefixMatch (p:pat) (r:rest)
660 | p == r = maybePrefixMatch pat rest
661 | otherwise = Nothing
663 removeSpaces :: String -> String
664 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
667 %************************************************************************
669 \subsection[Utils-pairs]{Pairs}
671 %************************************************************************
674 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
675 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
679 seqList :: [a] -> b -> b
681 seqList (x:xs) b = x `seq` seqList xs b
687 global :: a -> IORef a
688 global a = unsafePerformIO (newIORef a)
692 consIORef :: IORef [a] -> a -> IO ()
695 writeIORef var (x:xs)
701 looksLikeModuleName :: String -> Bool
702 looksLikeModuleName [] = False
703 looksLikeModuleName (c:cs) = isUpper c && go cs
705 go ('.':cs) = looksLikeModuleName cs
706 go (c:cs) = (isAlphaNum c || c == '_') && go cs
709 Akin to @Prelude.words@, but acts like the Bourne shell, treating
710 quoted strings and escaped characters within the input as solid blocks
711 of characters. Doesn't raise any exceptions on malformed escapes or
715 toArgs :: String -> [String]
718 case dropWhile isSpace s of -- drop initial spacing
719 [] -> [] -- empty, so no more tokens
720 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
722 -- Grab a token off the string, given that the first character exists and
723 -- isn't whitespace. The second argument is an accumulator which has to be
724 -- reversed at the end.
725 token [] acc = (reverse acc,[]) -- out of characters
726 token ('\\':c:aft) acc -- escapes
727 = token aft ((escape c) : acc)
728 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
729 = let (aft',acc') = quote q aft acc in token aft' acc'
730 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
732 token (c:aft) acc -- anything else goes in the token
735 -- Get the appropriate character for a single-character escape.
741 -- Read into accumulator until a quote character is found.
743 let quote' [] acc = ([],acc)
744 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
745 quote' (c:aft) acc | c == qc = (aft,acc)
746 quote' (c:aft) acc = quote' aft (c:acc)
750 -- -----------------------------------------------------------------------------
754 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
755 readRational__ r = do
758 return ((n%1)*10^^(k-d), t)
761 (ds,s) <- lexDecDigits r
762 (ds',t) <- lexDotDigits s
763 return (read (ds++ds'), length ds', t)
765 readExp (e:s) | e `elem` "eE" = readExp' s
766 readExp s = return (0,s)
768 readExp' ('+':s) = readDec s
769 readExp' ('-':s) = do
772 readExp' s = readDec s
775 (ds,r) <- nonnull isDigit s
776 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
779 lexDecDigits = nonnull isDigit
781 lexDotDigits ('.':s) = return (span isDigit s)
782 lexDotDigits s = return ("",s)
784 nonnull p s = do (cs@(_:_),t) <- return (span p s)
787 readRational :: String -> Rational -- NB: *does* handle a leading "-"
790 '-' : xs -> - (read_me xs)
794 = case (do { (x,"") <- readRational__ s ; return x }) of
796 [] -> error ("readRational: no parse:" ++ top_s)
797 _ -> error ("readRational: ambiguous parse:" ++ top_s)
800 -----------------------------------------------------------------------------
801 -- Create a hierarchy of directories
803 createDirectoryHierarchy :: FilePath -> IO ()
804 createDirectoryHierarchy dir = do
805 b <- doesDirectoryExist dir
807 createDirectoryHierarchy (directoryOf dir)
810 -----------------------------------------------------------------------------
811 -- Verify that the 'dirname' portion of a FilePath exists.
813 doesDirNameExist :: FilePath -> IO Bool
814 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
816 -- -----------------------------------------------------------------------------
821 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
822 handleDyn = flip catchDyn
824 handle :: (Exception -> IO a) -> IO a -> IO a
825 handle h f = f `Exception.catch` \e -> case e of
826 ExitException _ -> throw e
829 -- --------------------------------------------------------------
830 -- check existence & modification time at the same time
832 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
833 modificationTimeIfExists f = do
834 (do t <- getModificationTime f; return (Just t))
835 `IO.catch` \e -> if isDoesNotExistError e
839 -- --------------------------------------------------------------
840 -- Filename manipulation
842 -- Filenames are kept "normalised" inside GHC, using '/' as the path
843 -- separator. On Windows these functions will also recognise '\\' as
844 -- the path separator, but will generally construct paths using '/'.
848 splitFilename :: String -> (String,Suffix)
849 splitFilename f = splitLongestPrefix f (=='.')
851 basenameOf :: FilePath -> String
852 basenameOf = fst . splitFilename
854 suffixOf :: FilePath -> Suffix
855 suffixOf = snd . splitFilename
857 joinFileExt :: String -> String -> FilePath
858 joinFileExt path "" = path
859 joinFileExt path ext = path ++ '.':ext
861 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
862 splitFilenameDir :: String -> (String,String)
864 = let (dir, rest) = splitLongestPrefix str isPathSeparator
865 (dir', rest') | null rest = (".", dir)
866 | otherwise = (dir, rest)
869 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
870 splitFilename3 :: String -> (String,String,Suffix)
872 = let (dir, rest) = splitFilenameDir str
873 (name, ext) = splitFilename rest
876 joinFileName :: String -> String -> FilePath
877 joinFileName "" fname = fname
878 joinFileName "." fname = fname
879 joinFileName dir "" = dir
880 joinFileName dir fname = dir ++ '/':fname
882 -- split a string at the last character where 'pred' is True,
883 -- returning a pair of strings. The first component holds the string
884 -- up (but not including) the last character for which 'pred' returned
885 -- True, the second whatever comes after (but also not including the
888 -- If 'pred' returns False for all characters in the string, the original
889 -- string is returned in the first component (and the second one is just
891 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
892 splitLongestPrefix str pred
893 | null r_pre = (str, [])
894 | otherwise = (reverse (tail r_pre), reverse r_suf)
895 -- 'tail' drops the char satisfying 'pred'
897 (r_suf, r_pre) = break pred (reverse str)
899 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
900 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
902 -- directoryOf strips the filename off the input string, returning
904 directoryOf :: FilePath -> String
905 directoryOf = fst . splitFilenameDir
907 -- filenameOf strips the directory off the input string, returning
909 filenameOf :: FilePath -> String
910 filenameOf = snd . splitFilenameDir
912 replaceFilenameDirectory :: FilePath -> String -> FilePath
913 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
915 escapeSpaces :: String -> String
916 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
918 isPathSeparator :: Char -> Bool
920 #ifdef mingw32_TARGET_OS
921 ch == '/' || ch == '\\'
926 --------------------------------------------------------------
928 --------------------------------------------------------------
930 -- | The function splits the given string to substrings
931 -- using the 'searchPathSeparator'.
932 parseSearchPath :: String -> [FilePath]
933 parseSearchPath path = split path
935 split :: String -> [String]
939 _:rest -> chunk : split rest
943 #ifdef mingw32_HOST_OS
944 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
948 (chunk', rest') = break (==searchPathSeparator) s
950 -- | A platform-specific character used to separate search path strings in
951 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
952 -- and a semicolon (\";\") on the Windows operating system.
953 searchPathSeparator :: Char
954 #if mingw32_HOST_OS || mingw32_TARGET_OS
955 searchPathSeparator = ';'
957 searchPathSeparator = ':'
960 -----------------------------------------------------------------------------
961 -- Convert filepath into platform / MSDOS form.
963 -- We maintain path names in Unix form ('/'-separated) right until
964 -- the last moment. On Windows we dos-ify them just before passing them
965 -- to the Windows command.
967 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
968 -- proved quite awkward. There were a lot more calls to platformPath,
969 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
970 -- interpreted a command line 'foo\baz' as 'foobaz'.
972 normalisePath :: String -> String
973 -- Just changes '\' to '/'
975 pgmPath :: String -- Directory string in Unix format
976 -> String -- Program name with no directory separators
978 -> String -- Program invocation string in native format
980 #if defined(mingw32_HOST_OS)
981 --------------------- Windows version ------------------
982 normalisePath xs = subst '\\' '/' xs
983 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
984 platformPath p = subst '/' '\\' p
986 subst a b ls = map (\ x -> if x == a then b else x) ls
988 --------------------- Non-Windows version --------------
989 normalisePath xs = xs
990 pgmPath dir pgm = dir ++ '/' : pgm
991 platformPath stuff = stuff
992 --------------------------------------------------------