X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=0911dba84137a6c89acb40690a51be95ed35e426;hb=a7ecdf96844404b7bc8273d4ff6d85759278427c;hp=54066f6c6308344c46c499b74145a06b2d054774;hpb=c67bf292d43066b96cdcb1e71e122b9bdcaeca58;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 54066f6..0911dba 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -1,78 +1,104 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The University of Glasgow 1992-2002 % \section[Util]{Highly random utility functions} \begin{code} --- IF_NOT_GHC is meant to make this module useful outside the context of GHC -#define IF_NOT_GHC(a) - module Util ( -#if NOT_USED - -- The Eager monad - Eager, thenEager, returnEager, mapEager, appEager, runEager, -#endif -- general list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, + mapFst, mapSnd, mapAndUnzip, mapAndUnzip3, - nOfThem, lengthExceeds, isSingleton, only, - snocView, + nOfThem, filterOut, + lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, + isSingleton, only, singleton, + notNull, snocView, + isIn, isn'tIn, -- for-loop nTimes, -- sorting - IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) - sortLt, - IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten - IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA) + sortLe, sortWith, -- transitive closures transitiveClosure, -- accumulating - mapAccumL, mapAccumR, mapAccumB, foldl2, count, + mapAccumL, mapAccumR, mapAccumB, + foldl2, count, + + takeList, dropList, splitAtList, split, -- comparisons - thenCmp, cmpList, prefixMatch, postfixMatch, + isEqual, eqListBy, equalLength, compareLength, + thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, + removeSpaces, -- strictness - seqList, ($!), + foldl', seqList, -- pairs - IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA) - IF_NOT_GHC(applyToSnd COMMA foldPair COMMA) - unzipWith - - -- I/O -#if __GLASGOW_HASKELL__ < 402 - , bracket -#endif + unzipWith, + + global, consIORef, + + -- module names + looksLikeModuleName, + + toArgs, + + -- Floating point stuff + readRational, + + -- IO-ish utilities + createDirectoryHierarchy, + doesDirNameExist, + modificationTimeIfExists, + + later, handleDyn, handle, + + -- Filename utils + Suffix, + splitFilename, suffixOf, basenameOf, joinFileExt, + splitFilenameDir, joinFileName, + splitFilename3, + splitLongestPrefix, + replaceFilenameSuffix, directoryOf, filenameOf, + replaceFilenameDirectory, + escapeSpaces, isPathSeparator, + normalisePath, platformPath, pgmPath, + ) where - , global - , myProcessID +#include "HsVersions.h" -#if __GLASGOW_HASKELL__ <= 408 - , catchJust - , ioErrors - , throwTo -#endif +import Panic ( panic, trace ) +import FastTypes - ) where +import EXCEPTION ( Exception(..), finally, throwDyn, catchDyn, throw ) +import qualified EXCEPTION as Exception +import DYNAMIC ( Typeable ) +import DATA_IOREF ( IORef, newIORef ) +import UNSAFE_IO ( unsafePerformIO ) +import DATA_IOREF ( readIORef, writeIORef ) -#include "HsVersions.h" +import qualified List ( elem, notElem ) -import IO ( hPutStrLn, stderr ) +#ifndef DEBUG import List ( zipWith4 ) -import Panic ( panic ) -import IOExts ( IORef, newIORef, unsafePerformIO ) -import FastTypes -#if __GLASGOW_HASKELL__ <= 408 -import Exception ( catchIO, justIoErrors, raiseInThread ) #endif + +import Monad ( when ) +import IO ( catch, isDoesNotExistError ) +import Directory ( doesDirectoryExist, createDirectory ) +import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Ratio ( (%) ) +import Time ( ClockTime ) +import Directory ( getModificationTime ) + infixr 9 `thenCmp` \end{code} @@ -125,13 +151,20 @@ nTimes 1 f = f nTimes n f = f . nTimes (n-1) f \end{code} - %************************************************************************ %* * \subsection[Utils-lists]{General list processing} %* * %************************************************************************ +\begin{code} +filterOut :: (a->Bool) -> [a] -> [a] +-- Like filter, only reverses the sense of the test +filterOut p [] = [] +filterOut p (x:xs) | p x = filterOut p xs + | otherwise = x : filterOut p xs +\end{code} + A paranoid @zip@ (and some @zipWith@ friends) that checks the lists are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? @@ -192,6 +225,12 @@ stretchZipWith p z f (x:xs) ys \begin{code} +mapFst :: (a->c) -> [(a,b)] -> [(c,b)] +mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] + +mapFst f xys = [(f x, y) | (x,y) <- xys] +mapSnd f xys = [(x, f y) | (x,y) <- xys] + mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip f [] = ([],[]) @@ -217,15 +256,69 @@ mapAndUnzip3 f (x:xs) nOfThem :: Int -> a -> [a] nOfThem n thing = replicate n thing +-- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n'; +-- specification: +-- +-- atLength atLenPred atEndPred ls n +-- | n < 0 = atLenPred n +-- | length ls < n = atEndPred (n - length ls) +-- | otherwise = atLenPred (drop n ls) +-- +atLength :: ([a] -> b) + -> (Int -> b) + -> [a] + -> Int + -> b +atLength atLenPred atEndPred ls n + | n < 0 = atEndPred n + | otherwise = go n ls + where + go n [] = atEndPred n + go 0 ls = atLenPred ls + go n (_:xs) = go (n-1) xs + +-- special cases. lengthExceeds :: [a] -> Int -> Bool --- (lengthExceeds xs n) is True if length xs > n -(x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1) -[] `lengthExceeds` n = n < 0 +-- (lengthExceeds xs n) = (length xs > n) +lengthExceeds = atLength notNull (const False) + +lengthAtLeast :: [a] -> Int -> Bool +lengthAtLeast = atLength notNull (== 0) + +lengthIs :: [a] -> Int -> Bool +lengthIs = atLength null (==0) + +listLengthCmp :: [a] -> Int -> Ordering +listLengthCmp = atLength atLen atEnd + where + atEnd 0 = EQ + atEnd x + | x > 0 = LT -- not yet seen 'n' elts, so list length is < n. + | otherwise = GT + + atLen [] = EQ + atLen _ = GT + +singleton :: a -> [a] +singleton x = [x] isSingleton :: [a] -> Bool isSingleton [x] = True isSingleton _ = False +notNull :: [a] -> Bool +notNull [] = False +notNull _ = True + +snocView :: [a] -> Maybe ([a],a) + -- Split off the last element +snocView [] = Nothing +snocView xs = go [] xs + where + -- Invariant: second arg is non-empty + go acc [x] = Just (reverse acc, x) + go acc (x:xs) = go (x:acc) xs + only :: [a] -> a #ifdef DEBUG only [a] = a @@ -234,14 +327,6 @@ only (a:_) = a #endif \end{code} -\begin{code} -snocView :: [a] -> ([a], a) -- Split off the last element -snocView xs = go xs [] - where - go [x] acc = (reverse acc, x) - go (x:xs) acc = go xs (x:acc) -\end{code} - Debugging/specialising versions of \tr{elem} and \tr{notElem} \begin{code} @@ -258,147 +343,25 @@ elem__ x (y:ys) = x==y || elem__ x ys notElem__ x [] = True notElem__ x (y:ys) = x /= y && notElem__ x ys -# else {- DEBUG -} +# else /* DEBUG */ isIn msg x ys = elem (_ILIT 0) x ys where elem i _ [] = False elem i x (y:ys) - | i ># _ILIT 100 = panic ("Over-long elem in: " ++ msg) - | otherwise = x == y || elem (i +# _ILIT(1)) x ys + | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $ + x `List.elem` (y:ys) + | otherwise = x == y || elem (i +# _ILIT(1)) x ys isn'tIn msg x ys = notElem (_ILIT 0) x ys where notElem i x [] = True notElem i x (y:ys) - | i ># _ILIT 100 = panic ("Over-long notElem in: " ++ msg) - | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys - -# endif {- DEBUG -} - -\end{code} - -%************************************************************************ -%* * -\subsection[Utils-sorting]{Sorting} -%* * -%************************************************************************ - -%************************************************************************ -%* * -\subsubsection[Utils-quicksorting]{Quicksorts} -%* * -%************************************************************************ - -\begin{code} -#if NOT_USED - --- tail-recursive, etc., "quicker sort" [as per Meira thesis] -quicksort :: (a -> a -> Bool) -- Less-than predicate - -> [a] -- Input list - -> [a] -- Result list in increasing order - -quicksort lt [] = [] -quicksort lt [x] = [x] -quicksort lt (x:xs) = split x [] [] xs - where - split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi) - split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys - | True = split x lo (y:hi) ys -#endif -\end{code} - -Quicksort variant from Lennart's Haskell-library contribution. This -is a {\em stable} sort. - -\begin{code} -stableSortLt = sortLt -- synonym; when we want to highlight stable-ness - -sortLt :: (a -> a -> Bool) -- Less-than predicate - -> [a] -- Input list - -> [a] -- Result list - -sortLt lt l = qsort lt l [] - --- qsort is stable and does not concatenate. -qsort :: (a -> a -> Bool) -- Less-than predicate - -> [a] -- xs, Input list - -> [a] -- r, Concatenate this list to the sorted input list - -> [a] -- Result = sort xs ++ r - -qsort lt [] r = r -qsort lt [x] r = x:r -qsort lt (x:xs) r = qpart lt x xs [] [] r - --- qpart partitions and sorts the sublists --- rlt contains things less than x, --- rge contains the ones greater than or equal to x. --- Both have equal elements reversed with respect to the original list. - -qpart lt x [] rlt rge r = - -- rlt and rge are in reverse order and must be sorted with an - -- anti-stable sorting - rqsort lt rlt (x : rqsort lt rge r) - -qpart lt x (y:ys) rlt rge r = - if lt y x then - -- y < x - qpart lt x ys (y:rlt) rge r - else - -- y >= x - qpart lt x ys rlt (y:rge) r - --- rqsort is as qsort but anti-stable, i.e. reverses equal elements -rqsort lt [] r = r -rqsort lt [x] r = x:r -rqsort lt (x:xs) r = rqpart lt x xs [] [] r - -rqpart lt x [] rle rgt r = - qsort lt rle (x : qsort lt rgt r) - -rqpart lt x (y:ys) rle rgt r = - if lt x y then - -- y > x - rqpart lt x ys rle (y:rgt) r - else - -- y <= x - rqpart lt x ys (y:rle) rgt r -\end{code} - -%************************************************************************ -%* * -\subsubsection[Utils-dull-mergesort]{A rather dull mergesort} -%* * -%************************************************************************ - -\begin{code} -#if NOT_USED -mergesort :: (a -> a -> Ordering) -> [a] -> [a] - -mergesort cmp xs = merge_lists (split_into_runs [] xs) - where - a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False } - a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True } - - split_into_runs [] [] = [] - split_into_runs run [] = [run] - split_into_runs [] (x:xs) = split_into_runs [x] xs - split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs - split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs - | True = rl : (split_into_runs [x] xs) - - merge_lists [] = [] - merge_lists (x:xs) = merge x (merge_lists xs) - - merge [] ys = ys - merge xs [] = xs - merge xl@(x:xs) yl@(y:ys) - = case cmp x y of - EQ -> x : y : (merge xs ys) - LT -> x : (merge xs yl) - GT -> y : (merge xl ys) -#endif + | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $ + x `List.notElem` (y:ys) + | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys +# endif /* DEBUG */ \end{code} %************************************************************************ @@ -444,34 +407,24 @@ Carsten \begin{code} group :: (a -> a -> Bool) -> [a] -> [[a]] +-- Given a <= function, group finds maximal contiguous up-runs +-- or down-runs in the input list. +-- It's stable, in the sense that it never re-orders equal elements +-- +-- Date: Mon, 12 Feb 1996 15:09:41 +0000 +-- From: Andy Gill +-- Here is a `better' definition of group. -{- -Date: Mon, 12 Feb 1996 15:09:41 +0000 -From: Andy Gill - -Here is a `better' definition of group. --} group p [] = [] group p (x:xs) = group' xs x x (x :) where group' [] _ _ s = [s []] group' (x:xs) x_min x_max s - | not (x `p` x_max) = group' xs x_min x (s . (x :)) - | x `p` x_min = group' xs x x_max ((x :) . s) + | x_max `p` x = group' xs x_min x (s . (x :)) + | not (x_min `p` x) = group' xs x x_max ((x :) . s) | otherwise = s [] : group' xs x x (x :) - --- This one works forwards *and* backwards, as well as also being --- faster that the one in Util.lhs. - -{- ORIG: -group p [] = [[]] -group p (x:xs) = - let ((h1:t1):tt1) = group p xs - (t,tt) = if null xs then ([],[]) else - if x `p` h1 then (h1:t1,tt1) else - ([], (h1:t1):tt1) - in ((x:t):tt) --} + -- NB: the 'not' is essential for stablity + -- x `p` x_min would reverse equal elements generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] generalMerge p xs [] = xs @@ -490,19 +443,28 @@ balancedFold' :: (a -> a -> a) -> [a] -> [a] balancedFold' f (x:y:xs) = f x y : balancedFold' f xs balancedFold' f xs = xs -generalMergeSort p [] = [] -generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs - generalNaturalMergeSort p [] = [] generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs +#if NOT_USED +generalMergeSort p [] = [] +generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs + mergeSort, naturalMergeSort :: Ord a => [a] -> [a] mergeSort = generalMergeSort (<=) naturalMergeSort = generalNaturalMergeSort (<=) mergeSortLe le = generalMergeSort le -naturalMergeSortLe le = generalNaturalMergeSort le +#endif + +sortLe :: (a->a->Bool) -> [a] -> [a] +sortLe le = generalNaturalMergeSort le + +sortWith :: Ord b => (a->b) -> [a] -> [a] +sortWith get_key xs = sortLe le xs + where + x `le` y = get_key x < get_key y \end{code} %************************************************************************ @@ -593,6 +555,16 @@ mapAccumB f a b (x:xs) = (a'',b'',y:ys) (a'',b',ys) = mapAccumB f a' b xs \end{code} +A strict version of foldl. + +\begin{code} +foldl' :: (a -> b -> a) -> a -> [b] -> a +foldl' f z xs = lgo z xs + where + lgo z [] = z + lgo z (x:xs) = (lgo $! (f z x)) xs +\end{code} + A combination of foldl with zip. It works with equal length lists. \begin{code} @@ -610,6 +582,37 @@ count p (x:xs) | p x = 1 + count p xs | otherwise = count p xs \end{code} +@splitAt@, @take@, and @drop@ but with length of another +list giving the break-off point: + +\begin{code} +takeList :: [b] -> [a] -> [a] +takeList [] _ = [] +takeList (_:xs) ls = + case ls of + [] -> [] + (y:ys) -> y : takeList xs ys + +dropList :: [b] -> [a] -> [a] +dropList [] xs = xs +dropList _ xs@[] = xs +dropList (_:xs) (_:ys) = dropList xs ys + + +splitAtList :: [b] -> [a] -> ([a], [a]) +splitAtList [] xs = ([], xs) +splitAtList _ xs@[] = (xs, xs) +splitAtList (_:xs) (y:ys) = (y:ys', ys'') + where + (ys', ys'') = splitAtList xs ys + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s +\end{code} + %************************************************************************ %* * @@ -618,11 +621,33 @@ count p (x:xs) | p x = 1 + count p xs %************************************************************************ \begin{code} +isEqual :: Ordering -> Bool +-- Often used in (isEqual (a `compare` b)) +isEqual GT = False +isEqual EQ = True +isEqual LT = False + thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} thenCmp EQ any = any thenCmp other any = other +eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool +eqListBy eq [] [] = True +eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys +eqListBy eq xs ys = False + +equalLength :: [a] -> [b] -> Bool +equalLength [] [] = True +equalLength (_:xs) (_:ys) = equalLength xs ys +equalLength xs ys = False + +compareLength :: [a] -> [b] -> Ordering +compareLength [] [] = EQ +compareLength (_:xs) (_:ys) = compareLength xs ys +compareLength [] _ys = LT +compareLength _xs [] = GT + cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- `cmpList' uses a user-specified comparer @@ -640,8 +665,18 @@ prefixMatch _pat [] = False prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss | otherwise = False -postfixMatch :: Eq a => [a] -> [a] -> Bool -postfixMatch pat str = prefixMatch (reverse pat) (reverse str) +maybePrefixMatch :: String -> String -> Maybe String +maybePrefixMatch [] rest = Just rest +maybePrefixMatch (_:_) [] = Nothing +maybePrefixMatch (p:pat) (r:rest) + | p == r = maybePrefixMatch pat rest + | otherwise = Nothing + +suffixMatch :: Eq a => [a] -> [a] -> Bool +suffixMatch pat str = prefixMatch (reverse pat) (reverse str) + +removeSpaces :: String -> String +removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace \end{code} %************************************************************************ @@ -653,14 +688,17 @@ postfixMatch pat str = prefixMatch (reverse pat) (reverse str) The following are curried versions of @fst@ and @snd@. \begin{code} +#if NOT_USED cfst :: a -> b -> a -- stranal-sem only (Note) cfst x y = x +#endif \end{code} The following provide us higher order functions that, when applied to a function, operate on pairs. \begin{code} +#if NOT_USED applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d) applyToPair (f,g) (x,y) = (f x, g y) @@ -669,11 +707,7 @@ applyToFst f (x,y) = (f x,y) applyToSnd :: (b -> d) -> (a,b) -> (a,d) applyToSnd f (x,y) = (x,f y) - -foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) -foldPair fg ab [] = ab -foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) - where (u,v) = foldPair fg ab abs +#endif \end{code} \begin{code} @@ -682,52 +716,272 @@ unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs \end{code} \begin{code} -#if __HASKELL1__ > 4 seqList :: [a] -> b -> b -#else -seqList :: (Eval a) => [a] -> b -> b -#endif seqList [] b = b seqList (x:xs) b = x `seq` seqList xs b +\end{code} -#if __HASKELL1__ <= 4 -($!) :: (Eval a) => (a -> b) -> a -> b -f $! x = x `seq` f x -#endif +Global variables: + +\begin{code} +global :: a -> IORef a +global a = unsafePerformIO (newIORef a) \end{code} \begin{code} -#if __GLASGOW_HASKELL__ < 402 -bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c -bracket before after thing = do - a <- before - r <- (thing a) `catch` (\err -> after a >> fail err) - after a - return r -#endif +consIORef :: IORef [a] -> a -> IO () +consIORef var x = do + xs <- readIORef var + writeIORef var (x:xs) \end{code} -Global variables: +Module names: \begin{code} -global :: a -> IORef a -global a = unsafePerformIO (newIORef a) +looksLikeModuleName [] = False +looksLikeModuleName (c:cs) = isUpper c && go cs + where go [] = True + go ('.':cs) = looksLikeModuleName cs + go (c:cs) = (isAlphaNum c || c == '_') && go cs +\end{code} + +Akin to @Prelude.words@, but sensitive to dquoted entities treating +them as single words. + +\begin{code} +toArgs :: String -> [String] +toArgs "" = [] +toArgs s = + case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- " + (w,aft) -> + (\ ws -> if null w then ws else w : ws) $ + case aft of + [] -> [] + (x:xs) + | x /= '"' -> toArgs xs + | otherwise -> + case lex aft of + ((str,rs):_) -> stripQuotes str : toArgs rs + _ -> [aft] + where + -- strip away dquotes; assume first and last chars contain quotes. + stripQuotes :: String -> String + stripQuotes ('"':xs) = init xs + stripQuotes xs = xs \end{code} -Compatibility stuff: +-- ----------------------------------------------------------------------------- +-- Floats \begin{code} -#if __GLASGOW_HASKELL__ <= 408 -catchJust = catchIO -ioErrors = justIoErrors -throwTo = raiseInThread +readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" +readRational__ r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t) + where + readFix r = do + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do + (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + readDec s = do + (ds,r) <- nonnull isDigit s + return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], + r) + + lexDecDigits = nonnull isDigit + + lexDotDigits ('.':s) = return (span isDigit s) + lexDotDigits s = return ("",s) + + nonnull p s = do (cs@(_:_),t) <- return (span p s) + return (cs,t) + +readRational :: String -> Rational -- NB: *does* handle a leading "-" +readRational top_s + = case top_s of + '-' : xs -> - (read_me xs) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readRational__ s ; return x }) of + [x] -> x + [] -> error ("readRational: no parse:" ++ top_s) + _ -> error ("readRational: ambiguous parse:" ++ top_s) + + +----------------------------------------------------------------------------- +-- Create a hierarchy of directories + +createDirectoryHierarchy :: FilePath -> IO () +createDirectoryHierarchy dir = do + b <- doesDirectoryExist dir + when (not b) $ do + createDirectoryHierarchy (directoryOf dir) + createDirectory dir + +----------------------------------------------------------------------------- +-- Verify that the 'dirname' portion of a FilePath exists. +-- +doesDirNameExist :: FilePath -> IO Bool +doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath) + +-- ----------------------------------------------------------------------------- +-- Exception utils + +later = flip finally + +handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a +handleDyn = flip catchDyn + +handle :: (Exception -> IO a) -> IO a -> IO a +#if __GLASGOW_HASKELL__ < 501 +handle = flip Exception.catchAllIO +#else +handle h f = f `Exception.catch` \e -> case e of + ExitException _ -> throw e + _ -> h e #endif +-- -------------------------------------------------------------- +-- check existence & modification time at the same time + +modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) +modificationTimeIfExists f = do + (do t <- getModificationTime f; return (Just t)) + `IO.catch` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- +-- Filename manipulation + +-- Filenames are kept "normalised" inside GHC, using '/' as the path +-- separator. On Windows these functions will also recognise '\\' as +-- the path separator, but will generally construct paths using '/'. + +type Suffix = String + +splitFilename :: String -> (String,Suffix) +splitFilename f = splitLongestPrefix f (=='.') + +basenameOf :: FilePath -> String +basenameOf = fst . splitFilename + +suffixOf :: FilePath -> Suffix +suffixOf = snd . splitFilename + +joinFileExt :: String -> String -> FilePath +joinFileExt path "" = path +joinFileExt path ext = path ++ '.':ext + +-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext") +splitFilenameDir :: String -> (String,String) +splitFilenameDir str + = let (dir, rest) = splitLongestPrefix str isPathSeparator + (dir', rest') | null rest = (".", dir) + | otherwise = (dir, rest) + in (dir', rest') + +-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") +splitFilename3 :: String -> (String,String,Suffix) +splitFilename3 str + = let (dir, rest) = splitFilenameDir str + (name, ext) = splitFilename rest + in (dir, name, ext) + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname = dir ++ '/':fname + +-- split a string at the last character where 'pred' is True, +-- returning a pair of strings. The first component holds the string +-- up (but not including) the last character for which 'pred' returned +-- True, the second whatever comes after (but also not including the +-- last character). +-- +-- If 'pred' returns False for all characters in the string, the original +-- string is returned in the first component (and the second one is just +-- empty). +splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) +splitLongestPrefix str pred + | null r_pre = (str, []) + | otherwise = (reverse (tail r_pre), reverse r_suf) + -- 'tail' drops the char satisfying 'pred' + where + (r_suf, r_pre) = break pred (reverse str) + +replaceFilenameSuffix :: FilePath -> Suffix -> FilePath +replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf + +-- directoryOf strips the filename off the input string, returning +-- the directory. +directoryOf :: FilePath -> String +directoryOf = fst . splitFilenameDir + +-- filenameOf strips the directory off the input string, returning +-- the filename. +filenameOf :: FilePath -> String +filenameOf = snd . splitFilenameDir + +replaceFilenameDirectory :: FilePath -> String -> FilePath +replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path + +escapeSpaces :: String -> String +escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" + +isPathSeparator :: Char -> Bool +isPathSeparator ch = #ifdef mingw32_TARGET_OS -foreign import "_getpid" myProcessID :: IO Int + ch == '/' || ch == '\\' +#else + ch == '/' +#endif + +----------------------------------------------------------------------------- +-- Convert filepath into platform / MSDOS form. + +-- We maintain path names in Unix form ('/'-separated) right until +-- the last moment. On Windows we dos-ify them just before passing them +-- to the Windows command. +-- +-- The alternative, of using '/' consistently on Unix and '\' on Windows, +-- proved quite awkward. There were a lot more calls to platformPath, +-- and even on Windows we might invoke a unix-like utility (eg 'sh'), which +-- interpreted a command line 'foo\baz' as 'foobaz'. + +normalisePath :: String -> String +-- Just changes '\' to '/' + +pgmPath :: String -- Directory string in Unix format + -> String -- Program name with no directory separators + -- (e.g. copy /y) + -> String -- Program invocation string in native format + +#if defined(mingw32_HOST_OS) +--------------------- Windows version ------------------ +normalisePath xs = subst '\\' '/' xs +pgmPath dir pgm = platformPath dir ++ '\\' : pgm +platformPath p = subst '/' '\\' p + +subst a b ls = map (\ x -> if x == a then b else x) ls #else -myProcessID :: IO Int -myProcessID = do hPutStrLn stderr "Warning:myProcessID" - return 12345 +--------------------- Non-Windows version -------------- +normalisePath xs = xs +pgmPath dir pgm = dir ++ '/' : pgm +platformPath stuff = stuff +-------------------------------------------------------- #endif \end{code}