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,
25 lengthExceeds, lengthIs, lengthAtLeast,
26 listLengthCmp, atLength, equalLength, compareLength,
28 isSingleton, only, singleton,
39 -- transitive closures
45 takeList, dropList, splitAtList, split,
49 thenCmp, cmpList, maybePrefixMatch,
65 -- Floating point stuff
69 createDirectoryHierarchy,
71 modificationTimeIfExists,
73 later, handleDyn, handle,
77 splitFilename, suffixOf, basenameOf, joinFileExt,
78 splitFilenameDir, joinFileName,
81 replaceFilenameSuffix, directoryOf, filenameOf,
82 replaceFilenameDirectory,
83 escapeSpaces, isPathSeparator,
85 normalisePath, platformPath, pgmPath,
88 #include "HsVersions.h"
92 #if defined(DEBUG) || __GLASGOW_HASKELL__ < 604
96 import Control.Exception ( Exception(..), finally, catchDyn, throw )
97 import qualified Control.Exception as Exception
98 import Data.Dynamic ( Typeable )
99 import Data.IORef ( IORef, newIORef )
100 import System.IO.Unsafe ( unsafePerformIO )
101 import Data.IORef ( readIORef, writeIORef )
102 import Data.List hiding (group)
104 import qualified Data.List as List ( elem )
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 foldl1' was added in GHC 6.4
369 #if __GLASGOW_HASKELL__ < 604
370 foldl1' :: (a -> a -> a) -> [a] -> a
371 foldl1' f (x:xs) = foldl' f x xs
372 foldl1' _ [] = panic "foldl1'"
376 %************************************************************************
378 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
380 %************************************************************************
383 Date: Mon, 3 May 93 20:45:23 +0200
384 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
385 To: partain@dcs.gla.ac.uk
386 Subject: natural merge sort beats quick sort [ and it is prettier ]
388 Here is a piece of Haskell code that I'm rather fond of. See it as an
389 attempt to get rid of the ridiculous quick-sort routine. group is
390 quite useful by itself I think it was John's idea originally though I
391 believe the lazy version is due to me [surprisingly complicated].
392 gamma [used to be called] is called gamma because I got inspired by
393 the Gamma calculus. It is not very close to the calculus but does
394 behave less sequentially than both foldr and foldl. One could imagine
395 a version of gamma that took a unit element as well thereby avoiding
396 the problem with empty lists.
398 I've tried this code against
400 1) insertion sort - as provided by haskell
401 2) the normal implementation of quick sort
402 3) a deforested version of quick sort due to Jan Sparud
403 4) a super-optimized-quick-sort of Lennart's
405 If the list is partially sorted both merge sort and in particular
406 natural merge sort wins. If the list is random [ average length of
407 rising subsequences = approx 2 ] mergesort still wins and natural
408 merge sort is marginally beaten by Lennart's soqs. The space
409 consumption of merge sort is a bit worse than Lennart's quick sort
410 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
411 fpca article ] isn't used because of group.
418 group :: (a -> a -> Bool) -> [a] -> [[a]]
419 -- Given a <= function, group finds maximal contiguous up-runs
420 -- or down-runs in the input list.
421 -- It's stable, in the sense that it never re-orders equal elements
423 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
424 -- From: Andy Gill <andy@dcs.gla.ac.uk>
425 -- Here is a `better' definition of group.
428 group p (x:xs) = group' xs x x (x :)
430 group' [] _ _ s = [s []]
431 group' (x:xs) x_min x_max s
432 | x_max `p` x = group' xs x_min x (s . (x :))
433 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
434 | otherwise = s [] : group' xs x x (x :)
435 -- NB: the 'not' is essential for stablity
436 -- x `p` x_min would reverse equal elements
438 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
439 generalMerge p xs [] = xs
440 generalMerge p [] ys = ys
441 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
442 | otherwise = y : generalMerge p (x:xs) ys
444 -- gamma is now called balancedFold
446 balancedFold :: (a -> a -> a) -> [a] -> a
447 balancedFold f [] = error "can't reduce an empty list using balancedFold"
448 balancedFold f [x] = x
449 balancedFold f l = balancedFold f (balancedFold' f l)
451 balancedFold' :: (a -> a -> a) -> [a] -> [a]
452 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
453 balancedFold' f xs = xs
455 generalNaturalMergeSort p [] = []
456 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
459 generalMergeSort p [] = []
460 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
462 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
464 mergeSort = generalMergeSort (<=)
465 naturalMergeSort = generalNaturalMergeSort (<=)
467 mergeSortLe le = generalMergeSort le
470 sortLe :: (a->a->Bool) -> [a] -> [a]
471 sortLe le = generalNaturalMergeSort le
473 sortWith :: Ord b => (a->b) -> [a] -> [a]
474 sortWith get_key xs = sortLe le xs
476 x `le` y = get_key x < get_key y
478 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
479 on cmp sel = \x y -> sel x `cmp` sel y
483 %************************************************************************
485 \subsection[Utils-transitive-closure]{Transitive closure}
487 %************************************************************************
489 This algorithm for transitive closure is straightforward, albeit quadratic.
492 transitiveClosure :: (a -> [a]) -- Successor function
493 -> (a -> a -> Bool) -- Equality predicate
495 -> [a] -- The transitive closure
497 transitiveClosure succ eq xs
501 go done (x:xs) | x `is_in` done = go done xs
502 | otherwise = go (x:done) (succ x ++ xs)
505 x `is_in` (y:ys) | eq x y = True
506 | otherwise = x `is_in` ys
509 %************************************************************************
511 \subsection[Utils-accum]{Accumulating}
513 %************************************************************************
515 A combination of foldl with zip. It works with equal length lists.
518 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
520 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
522 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
523 -- True if the lists are the same length, and
524 -- all corresponding elements satisfy the predicate
526 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
530 Count the number of times a predicate is true
533 count :: (a -> Bool) -> [a] -> Int
535 count p (x:xs) | p x = 1 + count p xs
536 | otherwise = count p xs
539 @splitAt@, @take@, and @drop@ but with length of another
540 list giving the break-off point:
543 takeList :: [b] -> [a] -> [a]
548 (y:ys) -> y : takeList xs ys
550 dropList :: [b] -> [a] -> [a]
552 dropList _ xs@[] = xs
553 dropList (_:xs) (_:ys) = dropList xs ys
556 splitAtList :: [b] -> [a] -> ([a], [a])
557 splitAtList [] xs = ([], xs)
558 splitAtList _ xs@[] = (xs, xs)
559 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
561 (ys', ys'') = splitAtList xs ys
563 snocView :: [a] -> Maybe ([a],a)
564 -- Split off the last element
565 snocView [] = Nothing
566 snocView xs = go [] xs
568 -- Invariant: second arg is non-empty
569 go acc [x] = Just (reverse acc, x)
570 go acc (x:xs) = go (x:acc) xs
572 split :: Char -> String -> [String]
573 split c s = case rest of
575 _:rest -> chunk : split c rest
576 where (chunk, rest) = break (==c) s
580 %************************************************************************
582 \subsection[Utils-comparison]{Comparisons}
584 %************************************************************************
587 isEqual :: Ordering -> Bool
588 -- Often used in (isEqual (a `compare` b))
593 thenCmp :: Ordering -> Ordering -> Ordering
594 {-# INLINE thenCmp #-}
596 thenCmp other any = other
598 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
599 eqListBy eq [] [] = True
600 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
601 eqListBy eq xs ys = False
603 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
604 -- `cmpList' uses a user-specified comparer
606 cmpList cmp [] [] = EQ
607 cmpList cmp [] _ = LT
608 cmpList cmp _ [] = GT
609 cmpList cmp (a:as) (b:bs)
610 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
614 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
615 -- This definition can be removed once we require at least 6.8 to build.
616 maybePrefixMatch :: String -> String -> Maybe String
617 maybePrefixMatch [] rest = Just rest
618 maybePrefixMatch (_:_) [] = Nothing
619 maybePrefixMatch (p:pat) (r:rest)
620 | p == r = maybePrefixMatch pat rest
621 | otherwise = Nothing
623 removeSpaces :: String -> String
624 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
627 %************************************************************************
629 \subsection[Utils-pairs]{Pairs}
631 %************************************************************************
634 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
635 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
639 seqList :: [a] -> b -> b
641 seqList (x:xs) b = x `seq` seqList xs b
647 global :: a -> IORef a
648 global a = unsafePerformIO (newIORef a)
652 consIORef :: IORef [a] -> a -> IO ()
655 writeIORef var (x:xs)
661 looksLikeModuleName :: String -> Bool
662 looksLikeModuleName [] = False
663 looksLikeModuleName (c:cs) = isUpper c && go cs
665 go ('.':cs) = looksLikeModuleName cs
666 go (c:cs) = (isAlphaNum c || c == '_') && go cs
669 Akin to @Prelude.words@, but acts like the Bourne shell, treating
670 quoted strings and escaped characters within the input as solid blocks
671 of characters. Doesn't raise any exceptions on malformed escapes or
675 toArgs :: String -> [String]
678 case dropWhile isSpace s of -- drop initial spacing
679 [] -> [] -- empty, so no more tokens
680 rem -> let (tok,aft) = token rem [] in tok : toArgs aft
682 -- Grab a token off the string, given that the first character exists and
683 -- isn't whitespace. The second argument is an accumulator which has to be
684 -- reversed at the end.
685 token [] acc = (reverse acc,[]) -- out of characters
686 token ('\\':c:aft) acc -- escapes
687 = token aft ((escape c) : acc)
688 token (q:aft) acc | q == '"' || q == '\'' -- open quotes
689 = let (aft',acc') = quote q aft acc in token aft' acc'
690 token (c:aft) acc | isSpace c -- unescaped, unquoted spacing
692 token (c:aft) acc -- anything else goes in the token
695 -- Get the appropriate character for a single-character escape.
701 -- Read into accumulator until a quote character is found.
703 let quote' [] acc = ([],acc)
704 quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc)
705 quote' (c:aft) acc | c == qc = (aft,acc)
706 quote' (c:aft) acc = quote' aft (c:acc)
710 -- -----------------------------------------------------------------------------
714 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
715 readRational__ r = do
718 return ((n%1)*10^^(k-d), t)
721 (ds,s) <- lexDecDigits r
722 (ds',t) <- lexDotDigits s
723 return (read (ds++ds'), length ds', t)
725 readExp (e:s) | e `elem` "eE" = readExp' s
726 readExp s = return (0,s)
728 readExp' ('+':s) = readDec s
729 readExp' ('-':s) = do
732 readExp' s = readDec s
735 (ds,r) <- nonnull isDigit s
736 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
739 lexDecDigits = nonnull isDigit
741 lexDotDigits ('.':s) = return (span isDigit s)
742 lexDotDigits s = return ("",s)
744 nonnull p s = do (cs@(_:_),t) <- return (span p s)
747 readRational :: String -> Rational -- NB: *does* handle a leading "-"
750 '-' : xs -> - (read_me xs)
754 = case (do { (x,"") <- readRational__ s ; return x }) of
756 [] -> error ("readRational: no parse:" ++ top_s)
757 _ -> error ("readRational: ambiguous parse:" ++ top_s)
760 -----------------------------------------------------------------------------
761 -- Create a hierarchy of directories
763 createDirectoryHierarchy :: FilePath -> IO ()
764 createDirectoryHierarchy dir = do
765 b <- doesDirectoryExist dir
767 createDirectoryHierarchy (directoryOf dir)
770 -----------------------------------------------------------------------------
771 -- Verify that the 'dirname' portion of a FilePath exists.
773 doesDirNameExist :: FilePath -> IO Bool
774 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
776 -- -----------------------------------------------------------------------------
781 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
782 handleDyn = flip catchDyn
784 handle :: (Exception -> IO a) -> IO a -> IO a
785 handle h f = f `Exception.catch` \e -> case e of
786 ExitException _ -> throw e
789 -- --------------------------------------------------------------
790 -- check existence & modification time at the same time
792 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
793 modificationTimeIfExists f = do
794 (do t <- getModificationTime f; return (Just t))
795 `IO.catch` \e -> if isDoesNotExistError e
799 -- --------------------------------------------------------------
800 -- Filename manipulation
802 -- Filenames are kept "normalised" inside GHC, using '/' as the path
803 -- separator. On Windows these functions will also recognise '\\' as
804 -- the path separator, but will generally construct paths using '/'.
808 splitFilename :: String -> (String,Suffix)
809 splitFilename f = splitLongestPrefix f (=='.')
811 basenameOf :: FilePath -> String
812 basenameOf = fst . splitFilename
814 suffixOf :: FilePath -> Suffix
815 suffixOf = snd . splitFilename
817 joinFileExt :: String -> String -> FilePath
818 joinFileExt path "" = path
819 joinFileExt path ext = path ++ '.':ext
821 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
822 splitFilenameDir :: String -> (String,String)
824 = let (dir, rest) = splitLongestPrefix str isPathSeparator
825 (dir', rest') | null rest = (".", dir)
826 | otherwise = (dir, rest)
829 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
830 splitFilename3 :: String -> (String,String,Suffix)
832 = let (dir, rest) = splitFilenameDir str
833 (name, ext) = splitFilename rest
836 joinFileName :: String -> String -> FilePath
837 joinFileName "" fname = fname
838 joinFileName "." fname = fname
839 joinFileName dir "" = dir
840 joinFileName dir fname = dir ++ '/':fname
842 -- split a string at the last character where 'pred' is True,
843 -- returning a pair of strings. The first component holds the string
844 -- up (but not including) the last character for which 'pred' returned
845 -- True, the second whatever comes after (but also not including the
848 -- If 'pred' returns False for all characters in the string, the original
849 -- string is returned in the first component (and the second one is just
851 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
852 splitLongestPrefix str pred
853 | null r_pre = (str, [])
854 | otherwise = (reverse (tail r_pre), reverse r_suf)
855 -- 'tail' drops the char satisfying 'pred'
857 (r_suf, r_pre) = break pred (reverse str)
859 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
860 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
862 -- directoryOf strips the filename off the input string, returning
864 directoryOf :: FilePath -> String
865 directoryOf = fst . splitFilenameDir
867 -- filenameOf strips the directory off the input string, returning
869 filenameOf :: FilePath -> String
870 filenameOf = snd . splitFilenameDir
872 replaceFilenameDirectory :: FilePath -> String -> FilePath
873 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
875 escapeSpaces :: String -> String
876 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
878 isPathSeparator :: Char -> Bool
880 #ifdef mingw32_TARGET_OS
881 ch == '/' || ch == '\\'
886 --------------------------------------------------------------
888 --------------------------------------------------------------
890 -- | The function splits the given string to substrings
891 -- using the 'searchPathSeparator'.
892 parseSearchPath :: String -> [FilePath]
893 parseSearchPath path = split path
895 split :: String -> [String]
899 _:rest -> chunk : split rest
903 #ifdef mingw32_HOST_OS
904 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
908 (chunk', rest') = break (==searchPathSeparator) s
910 -- | A platform-specific character used to separate search path strings in
911 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
912 -- and a semicolon (\";\") on the Windows operating system.
913 searchPathSeparator :: Char
914 #if mingw32_HOST_OS || mingw32_TARGET_OS
915 searchPathSeparator = ';'
917 searchPathSeparator = ':'
920 -----------------------------------------------------------------------------
921 -- Convert filepath into platform / MSDOS form.
923 -- We maintain path names in Unix form ('/'-separated) right until
924 -- the last moment. On Windows we dos-ify them just before passing them
925 -- to the Windows command.
927 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
928 -- proved quite awkward. There were a lot more calls to platformPath,
929 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
930 -- interpreted a command line 'foo\baz' as 'foobaz'.
932 normalisePath :: String -> String
933 -- Just changes '\' to '/'
935 pgmPath :: String -- Directory string in Unix format
936 -> String -- Program name with no directory separators
938 -> String -- Program invocation string in native format
940 #if defined(mingw32_HOST_OS)
941 --------------------- Windows version ------------------
942 normalisePath xs = subst '\\' '/' xs
943 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
944 platformPath p = subst '/' '\\' p
946 subst a b ls = map (\ x -> if x == a then b else x) ls
948 --------------------- Non-Windows version --------------
949 normalisePath xs = xs
950 pgmPath dir pgm = dir ++ '/' : pgm
951 platformPath stuff = stuff
952 --------------------------------------------------------