X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=0a77e4d92a527205da2d639b0a01a76370e688b3;hb=218ca73afa77095237ad960289322e6009563744;hp=8cd9e5461695aa7ee6e831f1c4e253cb198da019;hpb=8ddba0f1a73eba7b03d27628cb54288e6a8de978;p=ghc-hetmet.git diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 8cd9e54..0a77e4d 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The University of Glasgow 1992-2002 % \section[Util]{Highly random utility functions} @@ -11,7 +12,7 @@ module Util ( zipLazy, stretchZipWith, mapFst, mapSnd, mapAndUnzip, mapAndUnzip3, - nOfThem, filterOut, + nOfThem, filterOut, partitionWith, splitEithers, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, equalLength, compareLength, @@ -38,7 +39,7 @@ module Util ( -- comparisons isEqual, eqListBy, - thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, + thenCmp, cmpList, maybePrefixMatch, removeSpaces, -- strictness @@ -82,26 +83,26 @@ module Util ( import Panic ( panic, trace ) import FastTypes -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 Control.Exception ( Exception(..), finally, catchDyn, throw ) +import qualified Control.Exception as Exception +import Data.Dynamic ( Typeable ) +import Data.IORef ( IORef, newIORef ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef ( readIORef, writeIORef ) -import qualified List ( elem, notElem ) +import qualified Data.List as List ( elem, notElem ) #ifndef DEBUG -import List ( zipWith4 ) +import Data.List ( zipWith4 ) #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 ) +import Control.Monad ( when ) +import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError ) +import System.Directory ( doesDirectoryExist, createDirectory, + getModificationTime ) +import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Data.Ratio ( (%) ) +import System.Time ( ClockTime ) infixr 9 `thenCmp` \end{code} @@ -167,6 +168,22 @@ filterOut :: (a->Bool) -> [a] -> [a] filterOut p [] = [] filterOut p (x:xs) | p x = filterOut p xs | otherwise = x : filterOut p xs + +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +partitionWith f [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where + (bs,cs) = partitionWith f xs + +splitEithers :: [Either a b] -> ([a], [b]) +splitEithers [] = ([],[]) +splitEithers (e : es) = case e of + Left x -> (x:xs, ys) + Right y -> (xs, y:ys) + where + (xs,ys) = splitEithers es \end{code} A paranoid @zip@ (and some @zipWith@ friends) that checks the lists @@ -326,15 +343,6 @@ 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 @@ -629,6 +637,15 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'') where (ys', ys'') = splitAtList xs ys +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 + split :: Char -> String -> [String] split c s = case rest of [] -> [chunk] @@ -671,12 +688,6 @@ cmpList cmp (a:as) (b:bs) \end{code} \begin{code} -prefixMatch :: Eq a => [a] -> [a] -> Bool -prefixMatch [] _str = True -prefixMatch _pat [] = False -prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss - | otherwise = False - maybePrefixMatch :: String -> String -> Maybe String maybePrefixMatch [] rest = Just rest maybePrefixMatch (_:_) [] = Nothing @@ -684,9 +695,6 @@ 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} @@ -697,31 +705,6 @@ removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace %* * %************************************************************************ -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) - -applyToFst :: (a -> c) -> (a,b)-> (c,b) -applyToFst f (x,y) = (f x,y) - -applyToSnd :: (b -> d) -> (a,b) -> (a,d) -applyToSnd f (x,y) = (x,f y) -#endif -\end{code} - \begin{code} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs @@ -750,6 +733,7 @@ consIORef var x = do Module names: \begin{code} +looksLikeModuleName :: String -> Bool looksLikeModuleName [] = False looksLikeModuleName (c:cs) = isUpper c && go cs where go [] = True @@ -757,29 +741,45 @@ looksLikeModuleName (c:cs) = isUpper c && go 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. +Akin to @Prelude.words@, but acts like the Bourne shell, treating +quoted strings and escaped characters within the input as solid blocks +of characters. Doesn't raise any exceptions on malformed escapes or +quoting. \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] + case dropWhile isSpace s of -- drop initial spacing + [] -> [] -- empty, so no more tokens + rem -> let (tok,aft) = token rem [] in tok : toArgs aft where - -- strip away dquotes; assume first and last chars contain quotes. - stripQuotes :: String -> String - stripQuotes ('"':xs) = init xs - stripQuotes xs = xs + -- Grab a token off the string, given that the first character exists and + -- isn't whitespace. The second argument is an accumulator which has to be + -- reversed at the end. + token [] acc = (reverse acc,[]) -- out of characters + token ('\\':c:aft) acc -- escapes + = token aft ((escape c) : acc) + token (q:aft) acc | q == '"' || q == '\'' -- open quotes + = let (aft',acc') = quote q aft acc in token aft' acc' + token (c:aft) acc | isSpace c -- unescaped, unquoted spacing + = (reverse acc,aft) + token (c:aft) acc -- anything else goes in the token + = token aft (c:acc) + + -- Get the appropriate character for a single-character escape. + escape 'n' = '\n' + escape 't' = '\t' + escape 'r' = '\r' + escape c = c + + -- Read into accumulator until a quote character is found. + quote qc = + let quote' [] acc = ([],acc) + quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc) + quote' (c:aft) acc | c == qc = (aft,acc) + quote' (c:aft) acc = quote' aft (c:acc) + in quote' \end{code} -- ----------------------------------------------------------------------------- @@ -857,13 +857,9 @@ 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