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 combination of foldl with zip. It works with equal length lists.
493 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
495 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
497 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
498 -- True if the lists are the same length, and
499 -- all corresponding elements satisfy the predicate
501 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
505 Count the number of times a predicate is true
508 count :: (a -> Bool) -> [a] -> Int
510 count p (x:xs) | p x = 1 + count p xs
511 | otherwise = count p xs
514 @splitAt@, @take@, and @drop@ but with length of another
515 list giving the break-off point:
518 takeList :: [b] -> [a] -> [a]
523 (y:ys) -> y : takeList xs ys
525 dropList :: [b] -> [a] -> [a]
527 dropList _ xs@[] = xs
528 dropList (_:xs) (_:ys) = dropList xs ys
531 splitAtList :: [b] -> [a] -> ([a], [a])
532 splitAtList [] xs = ([], xs)
533 splitAtList _ xs@[] = (xs, xs)
534 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
536 (ys', ys'') = splitAtList xs ys
538 snocView :: [a] -> Maybe ([a],a)
539 -- Split off the last element
540 snocView [] = Nothing
541 snocView xs = go [] xs
543 -- Invariant: second arg is non-empty
544 go acc [x] = Just (reverse acc, x)
545 go acc (x:xs) = go (x:acc) xs
547 split :: Char -> String -> [String]
548 split c s = case rest of
550 _:rest -> chunk : split c rest
551 where (chunk, rest) = break (==c) s
555 %************************************************************************
557 \subsection[Utils-comparison]{Comparisons}
559 %************************************************************************
562 isEqual :: Ordering -> Bool
563 -- Often used in (isEqual (a `compare` b))
568 thenCmp :: Ordering -> Ordering -> Ordering
569 {-# INLINE thenCmp #-}
571 thenCmp other any = other
573 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
574 eqListBy eq [] [] = True
575 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
576 eqListBy eq xs ys = False
578 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
579 -- `cmpList' uses a user-specified comparer
581 cmpList cmp [] [] = EQ
582 cmpList cmp [] _ = LT
583 cmpList cmp _ [] = GT
584 cmpList cmp (a:as) (b:bs)
585 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
589 maybePrefixMatch :: String -> String -> Maybe String
590 maybePrefixMatch [] rest = Just rest
591 maybePrefixMatch (_:_) [] = Nothing
592 maybePrefixMatch (p:pat) (r:rest)
593 | p == r = maybePrefixMatch pat rest
594 | otherwise = Nothing
596 removeSpaces :: String -> String
597 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
600 %************************************************************************
602 \subsection[Utils-pairs]{Pairs}
604 %************************************************************************
607 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
608 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
612 seqList :: [a] -> b -> b
614 seqList (x:xs) b = x `seq` seqList xs b
620 global :: a -> IORef a
621 global a = unsafePerformIO (newIORef a)
625 consIORef :: IORef [a] -> a -> IO ()
628 writeIORef var (x:xs)
634 looksLikeModuleName :: String -> Bool
635 looksLikeModuleName [] = False
636 looksLikeModuleName (c:cs) = isUpper c && go cs
638 go ('.':cs) = looksLikeModuleName cs
639 go (c:cs) = (isAlphaNum c || c == '_') && go cs
642 Akin to @Prelude.words@, but acts like the Bourne shell, treating
643 quoted strings and escaped characters within the input as solid blocks
644 of characters. Doesn't raise any exceptions on malformed escapes or
648 toArgs :: String -> [String]
651 case dropWhile isSpace s of -- drop initial spacing
652 [] -> [] -- empty, so no more tokens
653 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
655 -- Grab a token off the string, given that the first character exists and
656 -- isn't whitespace. The second argument is an accumulator which has to be
657 -- reversed at the end.
658 token [] acc = (reverse acc,[]) -- out of characters
659 token ('\\':c:aft) acc -- escapes
660 = token aft ((escape c) : acc)
661 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
662 = let (aft',acc') = quote q aft acc in token aft' acc'
663 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
665 token (c:aft) acc -- anything else goes in the token
668 -- Get the appropriate character for a single-character escape.
674 -- Read into accumulator until a quote character is found.
676 let quote' [] acc = ([],acc)
677 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
678 quote' (c:aft) acc | c == qc = (aft,acc)
679 quote' (c:aft) acc = quote' aft (c:acc)
683 -- -----------------------------------------------------------------------------
687 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
688 readRational__ r = do
691 return ((n%1)*10^^(k-d), t)
694 (ds,s) <- lexDecDigits r
695 (ds',t) <- lexDotDigits s
696 return (read (ds++ds'), length ds', t)
698 readExp (e:s) | e `elem` "eE" = readExp' s
699 readExp s = return (0,s)
701 readExp' ('+':s) = readDec s
702 readExp' ('-':s) = do
705 readExp' s = readDec s
708 (ds,r) <- nonnull isDigit s
709 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
712 lexDecDigits = nonnull isDigit
714 lexDotDigits ('.':s) = return (span isDigit s)
715 lexDotDigits s = return ("",s)
717 nonnull p s = do (cs@(_:_),t) <- return (span p s)
720 readRational :: String -> Rational -- NB: *does* handle a leading "-"
723 '-' : xs -> - (read_me xs)
727 = case (do { (x,"") <- readRational__ s ; return x }) of
729 [] -> error ("readRational: no parse:" ++ top_s)
730 _ -> error ("readRational: ambiguous parse:" ++ top_s)
733 -----------------------------------------------------------------------------
734 -- Create a hierarchy of directories
736 createDirectoryHierarchy :: FilePath -> IO ()
737 createDirectoryHierarchy dir = do
738 b <- doesDirectoryExist dir
740 createDirectoryHierarchy (directoryOf dir)
743 -----------------------------------------------------------------------------
744 -- Verify that the 'dirname' portion of a FilePath exists.
746 doesDirNameExist :: FilePath -> IO Bool
747 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
749 -- -----------------------------------------------------------------------------
754 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
755 handleDyn = flip catchDyn
757 handle :: (Exception -> IO a) -> IO a -> IO a
758 handle h f = f `Exception.catch` \e -> case e of
759 ExitException _ -> throw e
762 -- --------------------------------------------------------------
763 -- check existence & modification time at the same time
765 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
766 modificationTimeIfExists f = do
767 (do t <- getModificationTime f; return (Just t))
768 `IO.catch` \e -> if isDoesNotExistError e
772 -- --------------------------------------------------------------
773 -- Filename manipulation
775 -- Filenames are kept "normalised" inside GHC, using '/' as the path
776 -- separator. On Windows these functions will also recognise '\\' as
777 -- the path separator, but will generally construct paths using '/'.
781 splitFilename :: String -> (String,Suffix)
782 splitFilename f = splitLongestPrefix f (=='.')
784 basenameOf :: FilePath -> String
785 basenameOf = fst . splitFilename
787 suffixOf :: FilePath -> Suffix
788 suffixOf = snd . splitFilename
790 joinFileExt :: String -> String -> FilePath
791 joinFileExt path "" = path
792 joinFileExt path ext = path ++ '.':ext
794 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
795 splitFilenameDir :: String -> (String,String)
797 = let (dir, rest) = splitLongestPrefix str isPathSeparator
798 (dir', rest') | null rest = (".", dir)
799 | otherwise = (dir, rest)
802 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
803 splitFilename3 :: String -> (String,String,Suffix)
805 = let (dir, rest) = splitFilenameDir str
806 (name, ext) = splitFilename rest
809 joinFileName :: String -> String -> FilePath
810 joinFileName "" fname = fname
811 joinFileName "." fname = fname
812 joinFileName dir "" = dir
813 joinFileName dir fname = dir ++ '/':fname
815 -- split a string at the last character where 'pred' is True,
816 -- returning a pair of strings. The first component holds the string
817 -- up (but not including) the last character for which 'pred' returned
818 -- True, the second whatever comes after (but also not including the
821 -- If 'pred' returns False for all characters in the string, the original
822 -- string is returned in the first component (and the second one is just
824 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
825 splitLongestPrefix str pred
826 | null r_pre = (str, [])
827 | otherwise = (reverse (tail r_pre), reverse r_suf)
828 -- 'tail' drops the char satisfying 'pred'
830 (r_suf, r_pre) = break pred (reverse str)
832 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
833 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
835 -- directoryOf strips the filename off the input string, returning
837 directoryOf :: FilePath -> String
838 directoryOf = fst . splitFilenameDir
840 -- filenameOf strips the directory off the input string, returning
842 filenameOf :: FilePath -> String
843 filenameOf = snd . splitFilenameDir
845 replaceFilenameDirectory :: FilePath -> String -> FilePath
846 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
848 escapeSpaces :: String -> String
849 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
851 isPathSeparator :: Char -> Bool
853 #ifdef mingw32_TARGET_OS
854 ch == '/' || ch == '\\'
859 --------------------------------------------------------------
861 --------------------------------------------------------------
863 -- | The function splits the given string to substrings
864 -- using the 'searchPathSeparator'.
865 parseSearchPath :: String -> [FilePath]
866 parseSearchPath path = split path
868 split :: String -> [String]
872 _:rest -> chunk : split rest
876 #ifdef mingw32_HOST_OS
877 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
881 (chunk', rest') = break (==searchPathSeparator) s
883 -- | A platform-specific character used to separate search path strings in
884 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
885 -- and a semicolon (\";\") on the Windows operating system.
886 searchPathSeparator :: Char
887 #if mingw32_HOST_OS || mingw32_TARGET_OS
888 searchPathSeparator = ';'
890 searchPathSeparator = ':'
893 -----------------------------------------------------------------------------
894 -- Convert filepath into platform / MSDOS form.
896 -- We maintain path names in Unix form ('/'-separated) right until
897 -- the last moment. On Windows we dos-ify them just before passing them
898 -- to the Windows command.
900 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
901 -- proved quite awkward. There were a lot more calls to platformPath,
902 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
903 -- interpreted a command line 'foo\baz' as 'foobaz'.
905 normalisePath :: String -> String
906 -- Just changes '\' to '/'
908 pgmPath :: String -- Directory string in Unix format
909 -> String -- Program name with no directory separators
911 -> String -- Program invocation string in native format
913 #if defined(mingw32_HOST_OS)
914 --------------------- Windows version ------------------
915 normalisePath xs = subst '\\' '/' xs
916 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
917 platformPath p = subst '/' '\\' p
919 subst a b ls = map (\ x -> if x == a then b else x) ls
921 --------------------- Non-Windows version --------------
922 normalisePath xs = xs
923 pgmPath dir pgm = dir ++ '/' : pgm
924 platformPath stuff = stuff
925 --------------------------------------------------------