2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow 1992-2002
5 \section[Util]{Highly random utility functions}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 -- general list processing
18 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
19 zipLazy, stretchZipWith,
21 mapAndUnzip, mapAndUnzip3,
22 nOfThem, filterOut, partitionWith, splitEithers,
24 lengthExceeds, lengthIs, lengthAtLeast,
25 listLengthCmp, atLength, equalLength, compareLength,
27 isSingleton, only, singleton,
38 -- transitive closures
44 takeList, dropList, splitAtList, split,
48 thenCmp, cmpList, maybePrefixMatch,
64 -- Floating point stuff
68 createDirectoryHierarchy,
70 modificationTimeIfExists,
72 later, handleDyn, handle,
76 splitFilename, suffixOf, basenameOf, joinFileExt,
77 splitFilenameDir, joinFileName,
80 replaceFilenameSuffix, directoryOf, filenameOf,
81 replaceFilenameDirectory,
82 escapeSpaces, isPathSeparator,
84 normalisePath, platformPath, pgmPath,
87 #include "HsVersions.h"
92 import Panic ( panic, trace )
95 import Control.Exception ( Exception(..), finally, catchDyn, throw )
96 import qualified Control.Exception as Exception
97 import Data.Dynamic ( Typeable )
98 import Data.IORef ( IORef, newIORef )
99 import System.IO.Unsafe ( unsafePerformIO )
100 import Data.IORef ( readIORef, writeIORef )
102 import qualified Data.List as List ( elem )
104 import Data.List ( zipWith4 )
106 import qualified Data.List as List ( notElem )
109 import Control.Monad ( when )
110 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
111 import System.Directory ( doesDirectoryExist, createDirectory,
112 getModificationTime )
113 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
114 import Data.Ratio ( (%) )
115 import System.Time ( ClockTime )
120 %************************************************************************
122 \subsection{A for loop}
124 %************************************************************************
127 -- Compose a function with itself n times. (nth rather than twice)
128 nTimes :: Int -> (a -> a) -> (a -> a)
131 nTimes n f = f . nTimes (n-1) f
134 %************************************************************************
136 \subsection[Utils-lists]{General list processing}
138 %************************************************************************
141 filterOut :: (a->Bool) -> [a] -> [a]
142 -- Like filter, only reverses the sense of the test
144 filterOut p (x:xs) | p x = filterOut p xs
145 | otherwise = x : filterOut p xs
147 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
148 partitionWith f [] = ([],[])
149 partitionWith f (x:xs) = case f x of
151 Right c -> (bs, c:cs)
153 (bs,cs) = partitionWith f xs
155 splitEithers :: [Either a b] -> ([a], [b])
156 splitEithers [] = ([],[])
157 splitEithers (e : es) = case e of
159 Right y -> (xs, y:ys)
161 (xs,ys) = splitEithers es
164 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
165 are of equal length. Alastair Reid thinks this should only happen if
166 DEBUGging on; hey, why not?
169 zipEqual :: String -> [a] -> [b] -> [(a,b)]
170 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
171 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
172 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
176 zipWithEqual _ = zipWith
177 zipWith3Equal _ = zipWith3
178 zipWith4Equal _ = zipWith4
180 zipEqual msg [] [] = []
181 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
182 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
184 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
185 zipWithEqual msg _ [] [] = []
186 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
188 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
189 = z a b c : zipWith3Equal msg z as bs cs
190 zipWith3Equal msg _ [] [] [] = []
191 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
193 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
194 = z a b c d : zipWith4Equal msg z as bs cs ds
195 zipWith4Equal msg _ [] [] [] [] = []
196 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
201 -- zipLazy is lazy in the second list (observe the ~)
203 zipLazy :: [a] -> [b] -> [(a,b)]
205 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
210 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
211 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
212 -- the places where p returns *True*
214 stretchZipWith p z f [] ys = []
215 stretchZipWith p z f (x:xs) ys
216 | p x = f x z : stretchZipWith p z f xs ys
217 | otherwise = case ys of
219 (y:ys) -> f x y : stretchZipWith p z f xs ys
224 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
225 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
227 mapFst f xys = [(f x, y) | (x,y) <- xys]
228 mapSnd f xys = [(x, f y) | (x,y) <- xys]
230 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
232 mapAndUnzip f [] = ([],[])
236 (rs1, rs2) = mapAndUnzip f xs
240 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
242 mapAndUnzip3 f [] = ([],[],[])
243 mapAndUnzip3 f (x:xs)
246 (rs1, rs2, rs3) = mapAndUnzip3 f xs
248 (r1:rs1, r2:rs2, r3:rs3)
252 nOfThem :: Int -> a -> [a]
253 nOfThem n thing = replicate n thing
255 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
258 -- atLength atLenPred atEndPred ls n
259 -- | n < 0 = atLenPred n
260 -- | length ls < n = atEndPred (n - length ls)
261 -- | otherwise = atLenPred (drop n ls)
263 atLength :: ([a] -> b)
268 atLength atLenPred atEndPred ls n
269 | n < 0 = atEndPred n
270 | otherwise = go n ls
272 go n [] = atEndPred n
273 go 0 ls = atLenPred ls
274 go n (_:xs) = go (n-1) xs
277 lengthExceeds :: [a] -> Int -> Bool
278 -- (lengthExceeds xs n) = (length xs > n)
279 lengthExceeds = atLength notNull (const False)
281 lengthAtLeast :: [a] -> Int -> Bool
282 lengthAtLeast = atLength notNull (== 0)
284 lengthIs :: [a] -> Int -> Bool
285 lengthIs = atLength null (==0)
287 listLengthCmp :: [a] -> Int -> Ordering
288 listLengthCmp = atLength atLen atEnd
292 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
298 equalLength :: [a] -> [b] -> Bool
299 equalLength [] [] = True
300 equalLength (_:xs) (_:ys) = equalLength xs ys
301 equalLength xs ys = False
303 compareLength :: [a] -> [b] -> Ordering
304 compareLength [] [] = EQ
305 compareLength (_:xs) (_:ys) = compareLength xs ys
306 compareLength [] _ys = LT
307 compareLength _xs [] = GT
309 ----------------------------
310 singleton :: a -> [a]
313 isSingleton :: [a] -> Bool
314 isSingleton [x] = True
315 isSingleton _ = False
317 notNull :: [a] -> Bool
329 Debugging/specialising versions of \tr{elem} and \tr{notElem}
332 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
335 isIn msg x ys = elem__ x ys
336 isn'tIn msg x ys = notElem__ x ys
338 --these are here to be SPECIALIZEd (automagically)
340 elem__ x (y:ys) = x==y || elem__ x ys
342 notElem__ x [] = True
343 notElem__ x (y:ys) = x /= y && notElem__ x ys
347 = elem (_ILIT 0) x ys
351 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
353 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
356 = notElem (_ILIT 0) x ys
358 notElem i x [] = True
360 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
361 x `List.notElem` (y:ys)
362 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
366 %************************************************************************
368 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
370 %************************************************************************
373 Date: Mon, 3 May 93 20:45:23 +0200
374 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
375 To: partain@dcs.gla.ac.uk
376 Subject: natural merge sort beats quick sort [ and it is prettier ]
378 Here is a piece of Haskell code that I'm rather fond of. See it as an
379 attempt to get rid of the ridiculous quick-sort routine. group is
380 quite useful by itself I think it was John's idea originally though I
381 believe the lazy version is due to me [surprisingly complicated].
382 gamma [used to be called] is called gamma because I got inspired by
383 the Gamma calculus. It is not very close to the calculus but does
384 behave less sequentially than both foldr and foldl. One could imagine
385 a version of gamma that took a unit element as well thereby avoiding
386 the problem with empty lists.
388 I've tried this code against
390 1) insertion sort - as provided by haskell
391 2) the normal implementation of quick sort
392 3) a deforested version of quick sort due to Jan Sparud
393 4) a super-optimized-quick-sort of Lennart's
395 If the list is partially sorted both merge sort and in particular
396 natural merge sort wins. If the list is random [ average length of
397 rising subsequences = approx 2 ] mergesort still wins and natural
398 merge sort is marginally beaten by Lennart's soqs. The space
399 consumption of merge sort is a bit worse than Lennart's quick sort
400 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
401 fpca article ] isn't used because of group.
408 group :: (a -> a -> Bool) -> [a] -> [[a]]
409 -- Given a <= function, group finds maximal contiguous up-runs
410 -- or down-runs in the input list.
411 -- It's stable, in the sense that it never re-orders equal elements
413 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
414 -- From: Andy Gill <andy@dcs.gla.ac.uk>
415 -- Here is a `better' definition of group.
418 group p (x:xs) = group' xs x x (x :)
420 group' [] _ _ s = [s []]
421 group' (x:xs) x_min x_max s
422 | x_max `p` x = group' xs x_min x (s . (x :))
423 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
424 | otherwise = s [] : group' xs x x (x :)
425 -- NB: the 'not' is essential for stablity
426 -- x `p` x_min would reverse equal elements
428 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
429 generalMerge p xs [] = xs
430 generalMerge p [] ys = ys
431 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
432 | otherwise = y : generalMerge p (x:xs) ys
434 -- gamma is now called balancedFold
436 balancedFold :: (a -> a -> a) -> [a] -> a
437 balancedFold f [] = error "can't reduce an empty list using balancedFold"
438 balancedFold f [x] = x
439 balancedFold f l = balancedFold f (balancedFold' f l)
441 balancedFold' :: (a -> a -> a) -> [a] -> [a]
442 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
443 balancedFold' f xs = xs
445 generalNaturalMergeSort p [] = []
446 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
449 generalMergeSort p [] = []
450 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
452 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
454 mergeSort = generalMergeSort (<=)
455 naturalMergeSort = generalNaturalMergeSort (<=)
457 mergeSortLe le = generalMergeSort le
460 sortLe :: (a->a->Bool) -> [a] -> [a]
461 sortLe le = generalNaturalMergeSort le
463 sortWith :: Ord b => (a->b) -> [a] -> [a]
464 sortWith get_key xs = sortLe le xs
466 x `le` y = get_key x < get_key y
468 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
469 on cmp sel = \x y -> sel x `cmp` sel y
473 %************************************************************************
475 \subsection[Utils-transitive-closure]{Transitive closure}
477 %************************************************************************
479 This algorithm for transitive closure is straightforward, albeit quadratic.
482 transitiveClosure :: (a -> [a]) -- Successor function
483 -> (a -> a -> Bool) -- Equality predicate
485 -> [a] -- The transitive closure
487 transitiveClosure succ eq xs
491 go done (x:xs) | x `is_in` done = go done xs
492 | otherwise = go (x:done) (succ x ++ xs)
495 x `is_in` (y:ys) | eq x y = True
496 | otherwise = x `is_in` ys
499 %************************************************************************
501 \subsection[Utils-accum]{Accumulating}
503 %************************************************************************
505 A combination of foldl with zip. It works with equal length lists.
508 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
510 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
512 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
513 -- True if the lists are the same length, and
514 -- all corresponding elements satisfy the predicate
516 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
520 Count the number of times a predicate is true
523 count :: (a -> Bool) -> [a] -> Int
525 count p (x:xs) | p x = 1 + count p xs
526 | otherwise = count p xs
529 @splitAt@, @take@, and @drop@ but with length of another
530 list giving the break-off point:
533 takeList :: [b] -> [a] -> [a]
538 (y:ys) -> y : takeList xs ys
540 dropList :: [b] -> [a] -> [a]
542 dropList _ xs@[] = xs
543 dropList (_:xs) (_:ys) = dropList xs ys
546 splitAtList :: [b] -> [a] -> ([a], [a])
547 splitAtList [] xs = ([], xs)
548 splitAtList _ xs@[] = (xs, xs)
549 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
551 (ys', ys'') = splitAtList xs ys
553 snocView :: [a] -> Maybe ([a],a)
554 -- Split off the last element
555 snocView [] = Nothing
556 snocView xs = go [] xs
558 -- Invariant: second arg is non-empty
559 go acc [x] = Just (reverse acc, x)
560 go acc (x:xs) = go (x:acc) xs
562 split :: Char -> String -> [String]
563 split c s = case rest of
565 _:rest -> chunk : split c rest
566 where (chunk, rest) = break (==c) s
570 %************************************************************************
572 \subsection[Utils-comparison]{Comparisons}
574 %************************************************************************
577 isEqual :: Ordering -> Bool
578 -- Often used in (isEqual (a `compare` b))
583 thenCmp :: Ordering -> Ordering -> Ordering
584 {-# INLINE thenCmp #-}
586 thenCmp other any = other
588 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
589 eqListBy eq [] [] = True
590 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
591 eqListBy eq xs ys = False
593 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
594 -- `cmpList' uses a user-specified comparer
596 cmpList cmp [] [] = EQ
597 cmpList cmp [] _ = LT
598 cmpList cmp _ [] = GT
599 cmpList cmp (a:as) (b:bs)
600 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
604 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
605 -- This definition can be removed once we require at least 6.8 to build.
606 maybePrefixMatch :: String -> String -> Maybe String
607 maybePrefixMatch [] rest = Just rest
608 maybePrefixMatch (_:_) [] = Nothing
609 maybePrefixMatch (p:pat) (r:rest)
610 | p == r = maybePrefixMatch pat rest
611 | otherwise = Nothing
613 removeSpaces :: String -> String
614 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
617 %************************************************************************
619 \subsection[Utils-pairs]{Pairs}
621 %************************************************************************
624 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
625 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
629 seqList :: [a] -> b -> b
631 seqList (x:xs) b = x `seq` seqList xs b
637 global :: a -> IORef a
638 global a = unsafePerformIO (newIORef a)
642 consIORef :: IORef [a] -> a -> IO ()
645 writeIORef var (x:xs)
651 looksLikeModuleName :: String -> Bool
652 looksLikeModuleName [] = False
653 looksLikeModuleName (c:cs) = isUpper c && go cs
655 go ('.':cs) = looksLikeModuleName cs
656 go (c:cs) = (isAlphaNum c || c == '_') && go cs
659 Akin to @Prelude.words@, but acts like the Bourne shell, treating
660 quoted strings and escaped characters within the input as solid blocks
661 of characters. Doesn't raise any exceptions on malformed escapes or
665 toArgs :: String -> [String]
668 case dropWhile isSpace s of -- drop initial spacing
669 [] -> [] -- empty, so no more tokens
670 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
672 -- Grab a token off the string, given that the first character exists and
673 -- isn't whitespace. The second argument is an accumulator which has to be
674 -- reversed at the end.
675 token [] acc = (reverse acc,[]) -- out of characters
676 token ('\\':c:aft) acc -- escapes
677 = token aft ((escape c) : acc)
678 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
679 = let (aft',acc') = quote q aft acc in token aft' acc'
680 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
682 token (c:aft) acc -- anything else goes in the token
685 -- Get the appropriate character for a single-character escape.
691 -- Read into accumulator until a quote character is found.
693 let quote' [] acc = ([],acc)
694 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
695 quote' (c:aft) acc | c == qc = (aft,acc)
696 quote' (c:aft) acc = quote' aft (c:acc)
700 -- -----------------------------------------------------------------------------
704 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
705 readRational__ r = do
708 return ((n%1)*10^^(k-d), t)
711 (ds,s) <- lexDecDigits r
712 (ds',t) <- lexDotDigits s
713 return (read (ds++ds'), length ds', t)
715 readExp (e:s) | e `elem` "eE" = readExp' s
716 readExp s = return (0,s)
718 readExp' ('+':s) = readDec s
719 readExp' ('-':s) = do
722 readExp' s = readDec s
725 (ds,r) <- nonnull isDigit s
726 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
729 lexDecDigits = nonnull isDigit
731 lexDotDigits ('.':s) = return (span isDigit s)
732 lexDotDigits s = return ("",s)
734 nonnull p s = do (cs@(_:_),t) <- return (span p s)
737 readRational :: String -> Rational -- NB: *does* handle a leading "-"
740 '-' : xs -> - (read_me xs)
744 = case (do { (x,"") <- readRational__ s ; return x }) of
746 [] -> error ("readRational: no parse:" ++ top_s)
747 _ -> error ("readRational: ambiguous parse:" ++ top_s)
750 -----------------------------------------------------------------------------
751 -- Create a hierarchy of directories
753 createDirectoryHierarchy :: FilePath -> IO ()
754 createDirectoryHierarchy dir = do
755 b <- doesDirectoryExist dir
757 createDirectoryHierarchy (directoryOf dir)
760 -----------------------------------------------------------------------------
761 -- Verify that the 'dirname' portion of a FilePath exists.
763 doesDirNameExist :: FilePath -> IO Bool
764 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
766 -- -----------------------------------------------------------------------------
771 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
772 handleDyn = flip catchDyn
774 handle :: (Exception -> IO a) -> IO a -> IO a
775 handle h f = f `Exception.catch` \e -> case e of
776 ExitException _ -> throw e
779 -- --------------------------------------------------------------
780 -- check existence & modification time at the same time
782 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
783 modificationTimeIfExists f = do
784 (do t <- getModificationTime f; return (Just t))
785 `IO.catch` \e -> if isDoesNotExistError e
789 -- --------------------------------------------------------------
790 -- Filename manipulation
792 -- Filenames are kept "normalised" inside GHC, using '/' as the path
793 -- separator. On Windows these functions will also recognise '\\' as
794 -- the path separator, but will generally construct paths using '/'.
798 splitFilename :: String -> (String,Suffix)
799 splitFilename f = splitLongestPrefix f (=='.')
801 basenameOf :: FilePath -> String
802 basenameOf = fst . splitFilename
804 suffixOf :: FilePath -> Suffix
805 suffixOf = snd . splitFilename
807 joinFileExt :: String -> String -> FilePath
808 joinFileExt path "" = path
809 joinFileExt path ext = path ++ '.':ext
811 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
812 splitFilenameDir :: String -> (String,String)
814 = let (dir, rest) = splitLongestPrefix str isPathSeparator
815 (dir', rest') | null rest = (".", dir)
816 | otherwise = (dir, rest)
819 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
820 splitFilename3 :: String -> (String,String,Suffix)
822 = let (dir, rest) = splitFilenameDir str
823 (name, ext) = splitFilename rest
826 joinFileName :: String -> String -> FilePath
827 joinFileName "" fname = fname
828 joinFileName "." fname = fname
829 joinFileName dir "" = dir
830 joinFileName dir fname = dir ++ '/':fname
832 -- split a string at the last character where 'pred' is True,
833 -- returning a pair of strings. The first component holds the string
834 -- up (but not including) the last character for which 'pred' returned
835 -- True, the second whatever comes after (but also not including the
838 -- If 'pred' returns False for all characters in the string, the original
839 -- string is returned in the first component (and the second one is just
841 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
842 splitLongestPrefix str pred
843 | null r_pre = (str, [])
844 | otherwise = (reverse (tail r_pre), reverse r_suf)
845 -- 'tail' drops the char satisfying 'pred'
847 (r_suf, r_pre) = break pred (reverse str)
849 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
850 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
852 -- directoryOf strips the filename off the input string, returning
854 directoryOf :: FilePath -> String
855 directoryOf = fst . splitFilenameDir
857 -- filenameOf strips the directory off the input string, returning
859 filenameOf :: FilePath -> String
860 filenameOf = snd . splitFilenameDir
862 replaceFilenameDirectory :: FilePath -> String -> FilePath
863 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
865 escapeSpaces :: String -> String
866 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
868 isPathSeparator :: Char -> Bool
870 #ifdef mingw32_TARGET_OS
871 ch == '/' || ch == '\\'
876 --------------------------------------------------------------
878 --------------------------------------------------------------
880 -- | The function splits the given string to substrings
881 -- using the 'searchPathSeparator'.
882 parseSearchPath :: String -> [FilePath]
883 parseSearchPath path = split path
885 split :: String -> [String]
889 _:rest -> chunk : split rest
893 #ifdef mingw32_HOST_OS
894 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
898 (chunk', rest') = break (==searchPathSeparator) s
900 -- | A platform-specific character used to separate search path strings in
901 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
902 -- and a semicolon (\";\") on the Windows operating system.
903 searchPathSeparator :: Char
904 #if mingw32_HOST_OS || mingw32_TARGET_OS
905 searchPathSeparator = ';'
907 searchPathSeparator = ':'
910 -----------------------------------------------------------------------------
911 -- Convert filepath into platform / MSDOS form.
913 -- We maintain path names in Unix form ('/'-separated) right until
914 -- the last moment. On Windows we dos-ify them just before passing them
915 -- to the Windows command.
917 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
918 -- proved quite awkward. There were a lot more calls to platformPath,
919 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
920 -- interpreted a command line 'foo\baz' as 'foobaz'.
922 normalisePath :: String -> String
923 -- Just changes '\' to '/'
925 pgmPath :: String -- Directory string in Unix format
926 -> String -- Program name with no directory separators
928 -> String -- Program invocation string in native format
930 #if defined(mingw32_HOST_OS)
931 --------------------- Windows version ------------------
932 normalisePath xs = subst '\\' '/' xs
933 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
934 platformPath p = subst '/' '\\' p
936 subst a b ls = map (\ x -> if x == a then b else x) ls
938 --------------------- Non-Windows version --------------
939 normalisePath xs = xs
940 pgmPath dir pgm = dir ++ '/' : pgm
941 platformPath stuff = stuff
942 --------------------------------------------------------