X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=6463c1ac42f8c1692b1bc77f235ebad13d1d5330;hp=e692ff1aa3afcd868b7deaafcf44f9e9ea5bc39e;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index e692ff1..6463c1a 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,8 +12,11 @@ module Util ( zipLazy, stretchZipWith, mapFst, mapSnd, mapAndUnzip, mapAndUnzip3, - nOfThem, filterOut, - lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, + nOfThem, filterOut, partitionWith, splitEithers, + + lengthExceeds, lengthIs, lengthAtLeast, + listLengthCmp, atLength, equalLength, compareLength, + isSingleton, only, singleton, notNull, snocView, @@ -34,7 +38,7 @@ module Util ( takeList, dropList, splitAtList, split, -- comparisons - isEqual, eqListBy, equalLength, compareLength, + isEqual, eqListBy, thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, removeSpaces, @@ -79,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} @@ -164,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 @@ -300,6 +320,18 @@ listLengthCmp = atLength atLen atEnd atLen [] = EQ atLen _ = GT +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 + +---------------------------- singleton :: a -> [a] singleton x = [x] @@ -311,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 @@ -614,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] @@ -645,17 +677,6 @@ 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 @@ -753,29 +774,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} -- -----------------------------------------------------------------------------