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
37 takeList, dropList, splitAtList, split,
41 thenCmp, cmpList, 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"
85 import Panic ( panic, trace )
88 import Control.Exception ( Exception(..), finally, catchDyn, throw )
89 import qualified Control.Exception as Exception
90 import Data.Dynamic ( Typeable )
91 import Data.IORef ( IORef, newIORef )
92 import System.IO.Unsafe ( unsafePerformIO )
93 import Data.IORef ( readIORef, writeIORef )
95 import qualified Data.List as List ( elem )
97 import Data.List ( zipWith4 )
99 import qualified Data.List as List ( notElem )
102 import Control.Monad ( when )
103 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
104 import System.Directory ( doesDirectoryExist, createDirectory,
105 getModificationTime )
106 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
107 import Data.Ratio ( (%) )
108 import System.Time ( ClockTime )
113 %************************************************************************
115 \subsection{A for loop}
117 %************************************************************************
120 -- Compose a function with itself n times. (nth rather than twice)
121 nTimes :: Int -> (a -> a) -> (a -> a)
124 nTimes n f = f . nTimes (n-1) f
127 %************************************************************************
129 \subsection[Utils-lists]{General list processing}
131 %************************************************************************
134 filterOut :: (a->Bool) -> [a] -> [a]
135 -- Like filter, only reverses the sense of the test
137 filterOut p (x:xs) | p x = filterOut p xs
138 | otherwise = x : filterOut p xs
140 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
141 partitionWith f [] = ([],[])
142 partitionWith f (x:xs) = case f x of
144 Right c -> (bs, c:cs)
146 (bs,cs) = partitionWith f xs
148 splitEithers :: [Either a b] -> ([a], [b])
149 splitEithers [] = ([],[])
150 splitEithers (e : es) = case e of
152 Right y -> (xs, y:ys)
154 (xs,ys) = splitEithers es
157 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
158 are of equal length. Alastair Reid thinks this should only happen if
159 DEBUGging on; hey, why not?
162 zipEqual :: String -> [a] -> [b] -> [(a,b)]
163 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
164 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
165 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
169 zipWithEqual _ = zipWith
170 zipWith3Equal _ = zipWith3
171 zipWith4Equal _ = zipWith4
173 zipEqual msg [] [] = []
174 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
175 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
177 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
178 zipWithEqual msg _ [] [] = []
179 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
181 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
182 = z a b c : zipWith3Equal msg z as bs cs
183 zipWith3Equal msg _ [] [] [] = []
184 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
186 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
187 = z a b c d : zipWith4Equal msg z as bs cs ds
188 zipWith4Equal msg _ [] [] [] [] = []
189 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
194 -- zipLazy is lazy in the second list (observe the ~)
196 zipLazy :: [a] -> [b] -> [(a,b)]
198 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
203 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
204 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
205 -- the places where p returns *True*
207 stretchZipWith p z f [] ys = []
208 stretchZipWith p z f (x:xs) ys
209 | p x = f x z : stretchZipWith p z f xs ys
210 | otherwise = case ys of
212 (y:ys) -> f x y : stretchZipWith p z f xs ys
217 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
218 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
220 mapFst f xys = [(f x, y) | (x,y) <- xys]
221 mapSnd f xys = [(x, f y) | (x,y) <- xys]
223 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
225 mapAndUnzip f [] = ([],[])
229 (rs1, rs2) = mapAndUnzip f xs
233 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
235 mapAndUnzip3 f [] = ([],[],[])
236 mapAndUnzip3 f (x:xs)
239 (rs1, rs2, rs3) = mapAndUnzip3 f xs
241 (r1:rs1, r2:rs2, r3:rs3)
245 nOfThem :: Int -> a -> [a]
246 nOfThem n thing = replicate n thing
248 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
251 -- atLength atLenPred atEndPred ls n
252 -- | n < 0 = atLenPred n
253 -- | length ls < n = atEndPred (n - length ls)
254 -- | otherwise = atLenPred (drop n ls)
256 atLength :: ([a] -> b)
261 atLength atLenPred atEndPred ls n
262 | n < 0 = atEndPred n
263 | otherwise = go n ls
265 go n [] = atEndPred n
266 go 0 ls = atLenPred ls
267 go n (_:xs) = go (n-1) xs
270 lengthExceeds :: [a] -> Int -> Bool
271 -- (lengthExceeds xs n) = (length xs > n)
272 lengthExceeds = atLength notNull (const False)
274 lengthAtLeast :: [a] -> Int -> Bool
275 lengthAtLeast = atLength notNull (== 0)
277 lengthIs :: [a] -> Int -> Bool
278 lengthIs = atLength null (==0)
280 listLengthCmp :: [a] -> Int -> Ordering
281 listLengthCmp = atLength atLen atEnd
285 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
291 equalLength :: [a] -> [b] -> Bool
292 equalLength [] [] = True
293 equalLength (_:xs) (_:ys) = equalLength xs ys
294 equalLength xs ys = False
296 compareLength :: [a] -> [b] -> Ordering
297 compareLength [] [] = EQ
298 compareLength (_:xs) (_:ys) = compareLength xs ys
299 compareLength [] _ys = LT
300 compareLength _xs [] = GT
302 ----------------------------
303 singleton :: a -> [a]
306 isSingleton :: [a] -> Bool
307 isSingleton [x] = True
308 isSingleton _ = False
310 notNull :: [a] -> Bool
322 Debugging/specialising versions of \tr{elem} and \tr{notElem}
325 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
328 isIn msg x ys = elem__ x ys
329 isn'tIn msg x ys = notElem__ x ys
331 --these are here to be SPECIALIZEd (automagically)
333 elem__ x (y:ys) = x==y || elem__ x ys
335 notElem__ x [] = True
336 notElem__ x (y:ys) = x /= y && notElem__ x ys
340 = elem (_ILIT 0) x ys
344 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
346 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
349 = notElem (_ILIT 0) x ys
351 notElem i x [] = True
353 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
354 x `List.notElem` (y:ys)
355 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
359 %************************************************************************
361 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
363 %************************************************************************
366 Date: Mon, 3 May 93 20:45:23 +0200
367 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
368 To: partain@dcs.gla.ac.uk
369 Subject: natural merge sort beats quick sort [ and it is prettier ]
371 Here is a piece of Haskell code that I'm rather fond of. See it as an
372 attempt to get rid of the ridiculous quick-sort routine. group is
373 quite useful by itself I think it was John's idea originally though I
374 believe the lazy version is due to me [surprisingly complicated].
375 gamma [used to be called] is called gamma because I got inspired by
376 the Gamma calculus. It is not very close to the calculus but does
377 behave less sequentially than both foldr and foldl. One could imagine
378 a version of gamma that took a unit element as well thereby avoiding
379 the problem with empty lists.
381 I've tried this code against
383 1) insertion sort - as provided by haskell
384 2) the normal implementation of quick sort
385 3) a deforested version of quick sort due to Jan Sparud
386 4) a super-optimized-quick-sort of Lennart's
388 If the list is partially sorted both merge sort and in particular
389 natural merge sort wins. If the list is random [ average length of
390 rising subsequences = approx 2 ] mergesort still wins and natural
391 merge sort is marginally beaten by Lennart's soqs. The space
392 consumption of merge sort is a bit worse than Lennart's quick sort
393 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
394 fpca article ] isn't used because of group.
401 group :: (a -> a -> Bool) -> [a] -> [[a]]
402 -- Given a <= function, group finds maximal contiguous up-runs
403 -- or down-runs in the input list.
404 -- It's stable, in the sense that it never re-orders equal elements
406 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
407 -- From: Andy Gill <andy@dcs.gla.ac.uk>
408 -- Here is a `better' definition of group.
411 group p (x:xs) = group' xs x x (x :)
413 group' [] _ _ s = [s []]
414 group' (x:xs) x_min x_max s
415 | x_max `p` x = group' xs x_min x (s . (x :))
416 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
417 | otherwise = s [] : group' xs x x (x :)
418 -- NB: the 'not' is essential for stablity
419 -- x `p` x_min would reverse equal elements
421 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
422 generalMerge p xs [] = xs
423 generalMerge p [] ys = ys
424 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
425 | otherwise = y : generalMerge p (x:xs) ys
427 -- gamma is now called balancedFold
429 balancedFold :: (a -> a -> a) -> [a] -> a
430 balancedFold f [] = error "can't reduce an empty list using balancedFold"
431 balancedFold f [x] = x
432 balancedFold f l = balancedFold f (balancedFold' f l)
434 balancedFold' :: (a -> a -> a) -> [a] -> [a]
435 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
436 balancedFold' f xs = xs
438 generalNaturalMergeSort p [] = []
439 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
442 generalMergeSort p [] = []
443 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
445 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
447 mergeSort = generalMergeSort (<=)
448 naturalMergeSort = generalNaturalMergeSort (<=)
450 mergeSortLe le = generalMergeSort le
453 sortLe :: (a->a->Bool) -> [a] -> [a]
454 sortLe le = generalNaturalMergeSort le
456 sortWith :: Ord b => (a->b) -> [a] -> [a]
457 sortWith get_key xs = sortLe le xs
459 x `le` y = get_key x < get_key y
461 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
462 on cmp sel = \x y -> sel x `cmp` sel y
466 %************************************************************************
468 \subsection[Utils-transitive-closure]{Transitive closure}
470 %************************************************************************
472 This algorithm for transitive closure is straightforward, albeit quadratic.
475 transitiveClosure :: (a -> [a]) -- Successor function
476 -> (a -> a -> Bool) -- Equality predicate
478 -> [a] -- The transitive closure
480 transitiveClosure succ eq xs
484 go done (x:xs) | x `is_in` done = go done xs
485 | otherwise = go (x:done) (succ x ++ xs)
488 x `is_in` (y:ys) | eq x y = True
489 | otherwise = x `is_in` ys
492 %************************************************************************
494 \subsection[Utils-accum]{Accumulating}
496 %************************************************************************
498 A combination of foldl with zip. It works with equal length lists.
501 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
503 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
505 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
506 -- True if the lists are the same length, and
507 -- all corresponding elements satisfy the predicate
509 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
513 Count the number of times a predicate is true
516 count :: (a -> Bool) -> [a] -> Int
518 count p (x:xs) | p x = 1 + count p xs
519 | otherwise = count p xs
522 @splitAt@, @take@, and @drop@ but with length of another
523 list giving the break-off point:
526 takeList :: [b] -> [a] -> [a]
531 (y:ys) -> y : takeList xs ys
533 dropList :: [b] -> [a] -> [a]
535 dropList _ xs@[] = xs
536 dropList (_:xs) (_:ys) = dropList xs ys
539 splitAtList :: [b] -> [a] -> ([a], [a])
540 splitAtList [] xs = ([], xs)
541 splitAtList _ xs@[] = (xs, xs)
542 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
544 (ys', ys'') = splitAtList xs ys
546 snocView :: [a] -> Maybe ([a],a)
547 -- Split off the last element
548 snocView [] = Nothing
549 snocView xs = go [] xs
551 -- Invariant: second arg is non-empty
552 go acc [x] = Just (reverse acc, x)
553 go acc (x:xs) = go (x:acc) xs
555 split :: Char -> String -> [String]
556 split c s = case rest of
558 _:rest -> chunk : split c rest
559 where (chunk, rest) = break (==c) s
563 %************************************************************************
565 \subsection[Utils-comparison]{Comparisons}
567 %************************************************************************
570 isEqual :: Ordering -> Bool
571 -- Often used in (isEqual (a `compare` b))
576 thenCmp :: Ordering -> Ordering -> Ordering
577 {-# INLINE thenCmp #-}
579 thenCmp other any = other
581 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
582 eqListBy eq [] [] = True
583 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
584 eqListBy eq xs ys = False
586 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
587 -- `cmpList' uses a user-specified comparer
589 cmpList cmp [] [] = EQ
590 cmpList cmp [] _ = LT
591 cmpList cmp _ [] = GT
592 cmpList cmp (a:as) (b:bs)
593 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
597 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
598 -- This definition can be removed once we require at least 6.8 to build.
599 maybePrefixMatch :: String -> String -> Maybe String
600 maybePrefixMatch [] rest = Just rest
601 maybePrefixMatch (_:_) [] = Nothing
602 maybePrefixMatch (p:pat) (r:rest)
603 | p == r = maybePrefixMatch pat rest
604 | otherwise = Nothing
606 removeSpaces :: String -> String
607 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
610 %************************************************************************
612 \subsection[Utils-pairs]{Pairs}
614 %************************************************************************
617 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
618 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
622 seqList :: [a] -> b -> b
624 seqList (x:xs) b = x `seq` seqList xs b
630 global :: a -> IORef a
631 global a = unsafePerformIO (newIORef a)
635 consIORef :: IORef [a] -> a -> IO ()
638 writeIORef var (x:xs)
644 looksLikeModuleName :: String -> Bool
645 looksLikeModuleName [] = False
646 looksLikeModuleName (c:cs) = isUpper c && go cs
648 go ('.':cs) = looksLikeModuleName cs
649 go (c:cs) = (isAlphaNum c || c == '_') && go cs
652 Akin to @Prelude.words@, but acts like the Bourne shell, treating
653 quoted strings and escaped characters within the input as solid blocks
654 of characters. Doesn't raise any exceptions on malformed escapes or
658 toArgs :: String -> [String]
661 case dropWhile isSpace s of -- drop initial spacing
662 [] -> [] -- empty, so no more tokens
663 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
665 -- Grab a token off the string, given that the first character exists and
666 -- isn't whitespace. The second argument is an accumulator which has to be
667 -- reversed at the end.
668 token [] acc = (reverse acc,[]) -- out of characters
669 token ('\\':c:aft) acc -- escapes
670 = token aft ((escape c) : acc)
671 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
672 = let (aft',acc') = quote q aft acc in token aft' acc'
673 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
675 token (c:aft) acc -- anything else goes in the token
678 -- Get the appropriate character for a single-character escape.
684 -- Read into accumulator until a quote character is found.
686 let quote' [] acc = ([],acc)
687 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
688 quote' (c:aft) acc | c == qc = (aft,acc)
689 quote' (c:aft) acc = quote' aft (c:acc)
693 -- -----------------------------------------------------------------------------
697 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
698 readRational__ r = do
701 return ((n%1)*10^^(k-d), t)
704 (ds,s) <- lexDecDigits r
705 (ds',t) <- lexDotDigits s
706 return (read (ds++ds'), length ds', t)
708 readExp (e:s) | e `elem` "eE" = readExp' s
709 readExp s = return (0,s)
711 readExp' ('+':s) = readDec s
712 readExp' ('-':s) = do
715 readExp' s = readDec s
718 (ds,r) <- nonnull isDigit s
719 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
722 lexDecDigits = nonnull isDigit
724 lexDotDigits ('.':s) = return (span isDigit s)
725 lexDotDigits s = return ("",s)
727 nonnull p s = do (cs@(_:_),t) <- return (span p s)
730 readRational :: String -> Rational -- NB: *does* handle a leading "-"
733 '-' : xs -> - (read_me xs)
737 = case (do { (x,"") <- readRational__ s ; return x }) of
739 [] -> error ("readRational: no parse:" ++ top_s)
740 _ -> error ("readRational: ambiguous parse:" ++ top_s)
743 -----------------------------------------------------------------------------
744 -- Create a hierarchy of directories
746 createDirectoryHierarchy :: FilePath -> IO ()
747 createDirectoryHierarchy dir = do
748 b <- doesDirectoryExist dir
750 createDirectoryHierarchy (directoryOf dir)
753 -----------------------------------------------------------------------------
754 -- Verify that the 'dirname' portion of a FilePath exists.
756 doesDirNameExist :: FilePath -> IO Bool
757 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
759 -- -----------------------------------------------------------------------------
764 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
765 handleDyn = flip catchDyn
767 handle :: (Exception -> IO a) -> IO a -> IO a
768 handle h f = f `Exception.catch` \e -> case e of
769 ExitException _ -> throw e
772 -- --------------------------------------------------------------
773 -- check existence & modification time at the same time
775 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
776 modificationTimeIfExists f = do
777 (do t <- getModificationTime f; return (Just t))
778 `IO.catch` \e -> if isDoesNotExistError e
782 -- --------------------------------------------------------------
783 -- Filename manipulation
785 -- Filenames are kept "normalised" inside GHC, using '/' as the path
786 -- separator. On Windows these functions will also recognise '\\' as
787 -- the path separator, but will generally construct paths using '/'.
791 splitFilename :: String -> (String,Suffix)
792 splitFilename f = splitLongestPrefix f (=='.')
794 basenameOf :: FilePath -> String
795 basenameOf = fst . splitFilename
797 suffixOf :: FilePath -> Suffix
798 suffixOf = snd . splitFilename
800 joinFileExt :: String -> String -> FilePath
801 joinFileExt path "" = path
802 joinFileExt path ext = path ++ '.':ext
804 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
805 splitFilenameDir :: String -> (String,String)
807 = let (dir, rest) = splitLongestPrefix str isPathSeparator
808 (dir', rest') | null rest = (".", dir)
809 | otherwise = (dir, rest)
812 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
813 splitFilename3 :: String -> (String,String,Suffix)
815 = let (dir, rest) = splitFilenameDir str
816 (name, ext) = splitFilename rest
819 joinFileName :: String -> String -> FilePath
820 joinFileName "" fname = fname
821 joinFileName "." fname = fname
822 joinFileName dir "" = dir
823 joinFileName dir fname = dir ++ '/':fname
825 -- split a string at the last character where 'pred' is True,
826 -- returning a pair of strings. The first component holds the string
827 -- up (but not including) the last character for which 'pred' returned
828 -- True, the second whatever comes after (but also not including the
831 -- If 'pred' returns False for all characters in the string, the original
832 -- string is returned in the first component (and the second one is just
834 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
835 splitLongestPrefix str pred
836 | null r_pre = (str, [])
837 | otherwise = (reverse (tail r_pre), reverse r_suf)
838 -- 'tail' drops the char satisfying 'pred'
840 (r_suf, r_pre) = break pred (reverse str)
842 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
843 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
845 -- directoryOf strips the filename off the input string, returning
847 directoryOf :: FilePath -> String
848 directoryOf = fst . splitFilenameDir
850 -- filenameOf strips the directory off the input string, returning
852 filenameOf :: FilePath -> String
853 filenameOf = snd . splitFilenameDir
855 replaceFilenameDirectory :: FilePath -> String -> FilePath
856 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
858 escapeSpaces :: String -> String
859 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
861 isPathSeparator :: Char -> Bool
863 #ifdef mingw32_TARGET_OS
864 ch == '/' || ch == '\\'
869 --------------------------------------------------------------
871 --------------------------------------------------------------
873 -- | The function splits the given string to substrings
874 -- using the 'searchPathSeparator'.
875 parseSearchPath :: String -> [FilePath]
876 parseSearchPath path = split path
878 split :: String -> [String]
882 _:rest -> chunk : split rest
886 #ifdef mingw32_HOST_OS
887 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
891 (chunk', rest') = break (==searchPathSeparator) s
893 -- | A platform-specific character used to separate search path strings in
894 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
895 -- and a semicolon (\";\") on the Windows operating system.
896 searchPathSeparator :: Char
897 #if mingw32_HOST_OS || mingw32_TARGET_OS
898 searchPathSeparator = ';'
900 searchPathSeparator = ':'
903 -----------------------------------------------------------------------------
904 -- Convert filepath into platform / MSDOS form.
906 -- We maintain path names in Unix form ('/'-separated) right until
907 -- the last moment. On Windows we dos-ify them just before passing them
908 -- to the Windows command.
910 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
911 -- proved quite awkward. There were a lot more calls to platformPath,
912 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
913 -- interpreted a command line 'foo\baz' as 'foobaz'.
915 normalisePath :: String -> String
916 -- Just changes '\' to '/'
918 pgmPath :: String -- Directory string in Unix format
919 -> String -- Program name with no directory separators
921 -> String -- Program invocation string in native format
923 #if defined(mingw32_HOST_OS)
924 --------------------- Windows version ------------------
925 normalisePath xs = subst '\\' '/' xs
926 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
927 platformPath p = subst '/' '\\' p
929 subst a b ls = map (\ x -> if x == a then b else x) ls
931 --------------------- Non-Windows version --------------
932 normalisePath xs = xs
933 pgmPath dir pgm = dir ++ '/' : pgm
934 platformPath stuff = stuff
935 --------------------------------------------------------