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"
82 import Panic ( panic, trace )
85 import Control.Exception ( Exception(..), finally, catchDyn, throw )
86 import qualified Control.Exception as Exception
87 import Data.Dynamic ( Typeable )
88 import Data.IORef ( IORef, newIORef )
89 import System.IO.Unsafe ( unsafePerformIO )
90 import Data.IORef ( readIORef, writeIORef )
92 import qualified Data.List as List ( elem, notElem )
95 import Data.List ( zipWith4 )
98 import Control.Monad ( when )
99 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
100 import System.Directory ( doesDirectoryExist, createDirectory,
101 getModificationTime )
102 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
103 import Data.Ratio ( (%) )
104 import System.Time ( ClockTime )
109 %************************************************************************
111 \subsection{A for loop}
113 %************************************************************************
116 -- Compose a function with itself n times. (nth rather than twice)
117 nTimes :: Int -> (a -> a) -> (a -> a)
120 nTimes n f = f . nTimes (n-1) f
123 %************************************************************************
125 \subsection[Utils-lists]{General list processing}
127 %************************************************************************
130 filterOut :: (a->Bool) -> [a] -> [a]
131 -- Like filter, only reverses the sense of the test
133 filterOut p (x:xs) | p x = filterOut p xs
134 | otherwise = x : filterOut p xs
136 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
137 partitionWith f [] = ([],[])
138 partitionWith f (x:xs) = case f x of
140 Right c -> (bs, c:cs)
142 (bs,cs) = partitionWith f xs
144 splitEithers :: [Either a b] -> ([a], [b])
145 splitEithers [] = ([],[])
146 splitEithers (e : es) = case e of
148 Right y -> (xs, y:ys)
150 (xs,ys) = splitEithers es
153 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
154 are of equal length. Alastair Reid thinks this should only happen if
155 DEBUGging on; hey, why not?
158 zipEqual :: String -> [a] -> [b] -> [(a,b)]
159 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
160 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
161 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
165 zipWithEqual _ = zipWith
166 zipWith3Equal _ = zipWith3
167 zipWith4Equal _ = zipWith4
169 zipEqual msg [] [] = []
170 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
171 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
173 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
174 zipWithEqual msg _ [] [] = []
175 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
177 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
178 = z a b c : zipWith3Equal msg z as bs cs
179 zipWith3Equal msg _ [] [] [] = []
180 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
182 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
183 = z a b c d : zipWith4Equal msg z as bs cs ds
184 zipWith4Equal msg _ [] [] [] [] = []
185 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
190 -- zipLazy is lazy in the second list (observe the ~)
192 zipLazy :: [a] -> [b] -> [(a,b)]
194 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
199 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
200 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
201 -- the places where p returns *True*
203 stretchZipWith p z f [] ys = []
204 stretchZipWith p z f (x:xs) ys
205 | p x = f x z : stretchZipWith p z f xs ys
206 | otherwise = case ys of
208 (y:ys) -> f x y : stretchZipWith p z f xs ys
213 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
214 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
216 mapFst f xys = [(f x, y) | (x,y) <- xys]
217 mapSnd f xys = [(x, f y) | (x,y) <- xys]
219 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
221 mapAndUnzip f [] = ([],[])
225 (rs1, rs2) = mapAndUnzip f xs
229 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
231 mapAndUnzip3 f [] = ([],[],[])
232 mapAndUnzip3 f (x:xs)
235 (rs1, rs2, rs3) = mapAndUnzip3 f xs
237 (r1:rs1, r2:rs2, r3:rs3)
241 nOfThem :: Int -> a -> [a]
242 nOfThem n thing = replicate n thing
244 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
247 -- atLength atLenPred atEndPred ls n
248 -- | n < 0 = atLenPred n
249 -- | length ls < n = atEndPred (n - length ls)
250 -- | otherwise = atLenPred (drop n ls)
252 atLength :: ([a] -> b)
257 atLength atLenPred atEndPred ls n
258 | n < 0 = atEndPred n
259 | otherwise = go n ls
261 go n [] = atEndPred n
262 go 0 ls = atLenPred ls
263 go n (_:xs) = go (n-1) xs
266 lengthExceeds :: [a] -> Int -> Bool
267 -- (lengthExceeds xs n) = (length xs > n)
268 lengthExceeds = atLength notNull (const False)
270 lengthAtLeast :: [a] -> Int -> Bool
271 lengthAtLeast = atLength notNull (== 0)
273 lengthIs :: [a] -> Int -> Bool
274 lengthIs = atLength null (==0)
276 listLengthCmp :: [a] -> Int -> Ordering
277 listLengthCmp = atLength atLen atEnd
281 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
287 equalLength :: [a] -> [b] -> Bool
288 equalLength [] [] = True
289 equalLength (_:xs) (_:ys) = equalLength xs ys
290 equalLength xs ys = False
292 compareLength :: [a] -> [b] -> Ordering
293 compareLength [] [] = EQ
294 compareLength (_:xs) (_:ys) = compareLength xs ys
295 compareLength [] _ys = LT
296 compareLength _xs [] = GT
298 ----------------------------
299 singleton :: a -> [a]
302 isSingleton :: [a] -> Bool
303 isSingleton [x] = True
304 isSingleton _ = False
306 notNull :: [a] -> Bool
318 Debugging/specialising versions of \tr{elem} and \tr{notElem}
321 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
324 isIn msg x ys = elem__ x ys
325 isn'tIn msg x ys = notElem__ x ys
327 --these are here to be SPECIALIZEd (automagically)
329 elem__ x (y:ys) = x==y || elem__ x ys
331 notElem__ x [] = True
332 notElem__ x (y:ys) = x /= y && notElem__ x ys
336 = elem (_ILIT 0) x ys
340 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
342 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
345 = notElem (_ILIT 0) x ys
347 notElem i x [] = True
349 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
350 x `List.notElem` (y:ys)
351 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
355 %************************************************************************
357 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
359 %************************************************************************
362 Date: Mon, 3 May 93 20:45:23 +0200
363 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
364 To: partain@dcs.gla.ac.uk
365 Subject: natural merge sort beats quick sort [ and it is prettier ]
367 Here is a piece of Haskell code that I'm rather fond of. See it as an
368 attempt to get rid of the ridiculous quick-sort routine. group is
369 quite useful by itself I think it was John's idea originally though I
370 believe the lazy version is due to me [surprisingly complicated].
371 gamma [used to be called] is called gamma because I got inspired by
372 the Gamma calculus. It is not very close to the calculus but does
373 behave less sequentially than both foldr and foldl. One could imagine
374 a version of gamma that took a unit element as well thereby avoiding
375 the problem with empty lists.
377 I've tried this code against
379 1) insertion sort - as provided by haskell
380 2) the normal implementation of quick sort
381 3) a deforested version of quick sort due to Jan Sparud
382 4) a super-optimized-quick-sort of Lennart's
384 If the list is partially sorted both merge sort and in particular
385 natural merge sort wins. If the list is random [ average length of
386 rising subsequences = approx 2 ] mergesort still wins and natural
387 merge sort is marginally beaten by Lennart's soqs. The space
388 consumption of merge sort is a bit worse than Lennart's quick sort
389 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
390 fpca article ] isn't used because of group.
397 group :: (a -> a -> Bool) -> [a] -> [[a]]
398 -- Given a <= function, group finds maximal contiguous up-runs
399 -- or down-runs in the input list.
400 -- It's stable, in the sense that it never re-orders equal elements
402 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
403 -- From: Andy Gill <andy@dcs.gla.ac.uk>
404 -- Here is a `better' definition of group.
407 group p (x:xs) = group' xs x x (x :)
409 group' [] _ _ s = [s []]
410 group' (x:xs) x_min x_max s
411 | x_max `p` x = group' xs x_min x (s . (x :))
412 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
413 | otherwise = s [] : group' xs x x (x :)
414 -- NB: the 'not' is essential for stablity
415 -- x `p` x_min would reverse equal elements
417 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
418 generalMerge p xs [] = xs
419 generalMerge p [] ys = ys
420 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
421 | otherwise = y : generalMerge p (x:xs) ys
423 -- gamma is now called balancedFold
425 balancedFold :: (a -> a -> a) -> [a] -> a
426 balancedFold f [] = error "can't reduce an empty list using balancedFold"
427 balancedFold f [x] = x
428 balancedFold f l = balancedFold f (balancedFold' f l)
430 balancedFold' :: (a -> a -> a) -> [a] -> [a]
431 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
432 balancedFold' f xs = xs
434 generalNaturalMergeSort p [] = []
435 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
438 generalMergeSort p [] = []
439 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
441 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
443 mergeSort = generalMergeSort (<=)
444 naturalMergeSort = generalNaturalMergeSort (<=)
446 mergeSortLe le = generalMergeSort le
449 sortLe :: (a->a->Bool) -> [a] -> [a]
450 sortLe le = generalNaturalMergeSort le
452 sortWith :: Ord b => (a->b) -> [a] -> [a]
453 sortWith get_key xs = sortLe le xs
455 x `le` y = get_key x < get_key y
458 %************************************************************************
460 \subsection[Utils-transitive-closure]{Transitive closure}
462 %************************************************************************
464 This algorithm for transitive closure is straightforward, albeit quadratic.
467 transitiveClosure :: (a -> [a]) -- Successor function
468 -> (a -> a -> Bool) -- Equality predicate
470 -> [a] -- The transitive closure
472 transitiveClosure succ eq xs
476 go done (x:xs) | x `is_in` done = go done xs
477 | otherwise = go (x:done) (succ x ++ xs)
480 x `is_in` (y:ys) | eq x y = True
481 | otherwise = x `is_in` ys
484 %************************************************************************
486 \subsection[Utils-accum]{Accumulating}
488 %************************************************************************
490 A strict version of foldl.
493 foldl' :: (a -> b -> a) -> a -> [b] -> a
494 foldl' f z xs = lgo z xs
497 lgo z (x:xs) = (lgo $! (f z x)) xs
500 A combination of foldl with zip. It works with equal length lists.
503 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
505 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
507 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
508 -- True if the lists are the same length, and
509 -- all corresponding elements satisfy the predicate
511 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
515 Count the number of times a predicate is true
518 count :: (a -> Bool) -> [a] -> Int
520 count p (x:xs) | p x = 1 + count p xs
521 | otherwise = count p xs
524 @splitAt@, @take@, and @drop@ but with length of another
525 list giving the break-off point:
528 takeList :: [b] -> [a] -> [a]
533 (y:ys) -> y : takeList xs ys
535 dropList :: [b] -> [a] -> [a]
537 dropList _ xs@[] = xs
538 dropList (_:xs) (_:ys) = dropList xs ys
541 splitAtList :: [b] -> [a] -> ([a], [a])
542 splitAtList [] xs = ([], xs)
543 splitAtList _ xs@[] = (xs, xs)
544 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
546 (ys', ys'') = splitAtList xs ys
548 snocView :: [a] -> Maybe ([a],a)
549 -- Split off the last element
550 snocView [] = Nothing
551 snocView xs = go [] xs
553 -- Invariant: second arg is non-empty
554 go acc [x] = Just (reverse acc, x)
555 go acc (x:xs) = go (x:acc) xs
557 split :: Char -> String -> [String]
558 split c s = case rest of
560 _:rest -> chunk : split c rest
561 where (chunk, rest) = break (==c) s
565 %************************************************************************
567 \subsection[Utils-comparison]{Comparisons}
569 %************************************************************************
572 isEqual :: Ordering -> Bool
573 -- Often used in (isEqual (a `compare` b))
578 thenCmp :: Ordering -> Ordering -> Ordering
579 {-# INLINE thenCmp #-}
581 thenCmp other any = other
583 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
584 eqListBy eq [] [] = True
585 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
586 eqListBy eq xs ys = False
588 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
589 -- `cmpList' uses a user-specified comparer
591 cmpList cmp [] [] = EQ
592 cmpList cmp [] _ = LT
593 cmpList cmp _ [] = GT
594 cmpList cmp (a:as) (b:bs)
595 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
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 --------------------------------------------------------