-- general list processing
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith,
+ mapFst, mapSnd,
mapAndUnzip, mapAndUnzip3,
- nOfThem,
+ nOfThem, filterOut,
lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
- isSingleton, only,
+ isSingleton, only, singleton,
notNull, snocView,
isIn, isn'tIn,
nTimes,
-- sorting
- sortLt, naturalMergeSortLe,
+ sortLe, sortWith,
-- transitive closures
transitiveClosure,
-- accumulating
mapAccumL, mapAccumR, mapAccumB,
- foldl2, count,
+ foldl2, count, all2,
- takeList, dropList, splitAtList,
+ takeList, dropList, splitAtList, split,
-- comparisons
- eqListBy, equalLength, compareLength,
- thenCmp, cmpList, prefixMatch, suffixMatch,
+ isEqual, eqListBy, equalLength, compareLength,
+ thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
+ removeSpaces,
-- strictness
foldl', seqList,
-- pairs
unzipWith,
- global,
+ 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,
+ parseSearchPath,
+ normalisePath, platformPath, pgmPath,
) where
-#include "../includes/config.h"
#include "HsVersions.h"
import Panic ( panic, trace )
import FastTypes
-#if __GLASGOW_HASKELL__ <= 408
-import EXCEPTION ( catchIO, justIoErrors, raiseInThread )
-#endif
+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 )
import qualified List ( elem, notElem )
import List ( zipWith4 )
#endif
-import Char ( isUpper, isAlphaNum )
+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}
%* *
%************************************************************************
+\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?
\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 [] = ([],[])
atLen [] = EQ
atLen _ = GT
+singleton :: a -> [a]
+singleton x = [x]
+
isSingleton :: [a] -> Bool
isSingleton [x] = True
isSingleton _ = False
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
| 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}
-
-%************************************************************************
-%* *
-\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}
-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
+# endif /* DEBUG */
\end{code}
%************************************************************************
\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 <andy@dcs.gla.ac.uk>
+-- Here is a `better' definition of group.
-{-
-Date: Mon, 12 Feb 1996 15:09:41 +0000
-From: Andy Gill <andy@dcs.gla.ac.uk>
-
-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
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 (<=)
mergeSortLe le = generalMergeSort le
#endif
-naturalMergeSortLe le = generalNaturalMergeSort le
+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}
%************************************************************************
foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
foldl2 k z [] [] = z
foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
+
+all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+-- True if the lists are the same length, and
+-- all corresponding elements satisfy the predicate
+all2 p [] [] = True
+all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
+all2 p xs ys = False
\end{code}
Count the number of times a predicate is true
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}
%************************************************************************
\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
compareLength [] _ys = LT
compareLength _xs [] = GT
-thenCmp :: Ordering -> Ordering -> Ordering
-{-# INLINE thenCmp #-}
-thenCmp EQ any = any
-thenCmp other any = other
-
cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
-- `cmpList' uses a user-specified comparer
prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
| otherwise = False
+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}
%************************************************************************
applyToSnd :: (b -> d) -> (a,b) -> (a,d)
applyToSnd f (x,y) = (x,f y)
#endif
-
-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
\end{code}
\begin{code}
global a = unsafePerformIO (newIORef a)
\end{code}
+\begin{code}
+consIORef :: IORef [a] -> a -> IO ()
+consIORef var x = do
+ xs <- readIORef var
+ writeIORef var (x:xs)
+\end{code}
+
Module names:
\begin{code}
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}
+
+-- -----------------------------------------------------------------------------
+-- Floats
+
+\begin{code}
+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
+ ch == '/' || ch == '\\'
+#else
+ ch == '/'
+#endif
+
+--------------------------------------------------------------
+-- * Search path
+--------------------------------------------------------------
+
+-- | The function splits the given string to substrings
+-- using the 'searchPathSeparator'.
+parseSearchPath :: String -> [FilePath]
+parseSearchPath path = split path
+ where
+ split :: String -> [String]
+ split s =
+ case rest' of
+ [] -> [chunk]
+ _:rest -> chunk : split rest
+ where
+ chunk =
+ case chunk' of
+#ifdef mingw32_HOST_OS
+ ('\"':xs@(_:_)) | last xs == '\"' -> init xs
+#endif
+ _ -> chunk'
+
+ (chunk', rest') = break (==searchPathSeparator) s
+
+-- | A platform-specific character used to separate search path strings in
+-- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
+-- and a semicolon (\";\") on the Windows operating system.
+searchPathSeparator :: Char
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+searchPathSeparator = ';'
+#else
+searchPathSeparator = ':'
+#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
+--------------------- Non-Windows version --------------
+normalisePath xs = xs
+pgmPath dir pgm = dir ++ '/' : pgm
+platformPath stuff = stuff
+--------------------------------------------------------
+#endif
+\end{code}
projects / ghc-hetmet.git / blobdiff