X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=8473faf42eeb94d29641c35e850b2e5d7a9454d7;hp=8cd9e5461695aa7ee6e831f1c4e253cb198da019;hb=8100c58a929d993d2dd7022412ed6113cf97fba7;hpb=8ddba0f1a73eba7b03d27628cb54288e6a8de978 diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 8cd9e54..8473faf 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, @@ -31,18 +32,17 @@ module Util ( transitiveClosure, -- accumulating - mapAccumL, mapAccumR, mapAccumB, foldl2, count, all2, takeList, dropList, splitAtList, split, -- comparisons isEqual, eqListBy, - thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, + thenCmp, cmpList, maybePrefixMatch, removeSpaces, -- strictness - foldl', seqList, + seqList, -- pairs unzipWith, @@ -82,67 +82,32 @@ 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} %************************************************************************ %* * -\subsection{The Eager monad} -%* * -%************************************************************************ - -The @Eager@ monad is just an encoding of continuation-passing style, -used to allow you to express "do this and then that", mainly to avoid -space leaks. It's done with a type synonym to save bureaucracy. - -\begin{code} -#if NOT_USED - -type Eager ans a = (a -> ans) -> ans - -runEager :: Eager a a -> a -runEager m = m (\x -> x) - -appEager :: Eager ans a -> (a -> ans) -> ans -appEager m cont = m cont - -thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b -thenEager m k cont = m (\r -> k r cont) - -returnEager :: a -> Eager ans a -returnEager v cont = cont v - -mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b] -mapEager f [] = returnEager [] -mapEager f (x:xs) = f x `thenEager` \ y -> - mapEager f xs `thenEager` \ ys -> - returnEager (y:ys) -#endif -\end{code} - -%************************************************************************ -%* * \subsection{A for loop} %* * %************************************************************************ @@ -167,6 +132,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 +307,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 @@ -515,72 +487,6 @@ transitiveClosure succ eq xs %* * %************************************************************************ -@mapAccumL@ behaves like a combination -of @map@ and @foldl@; -it applies a function to each element of a list, passing an accumulating -parameter from left to right, and returning a final value of this -accumulator together with the new list. - -\begin{code} -mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list - -mapAccumL f b [] = (b, []) -mapAccumL f b (x:xs) = (b'', x':xs') where - (b', x') = f b x - (b'', xs') = mapAccumL f b' xs -\end{code} - -@mapAccumR@ does the same, but working from right to left instead. Its type is -the same as @mapAccumL@, though. - -\begin{code} -mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list - -mapAccumR f b [] = (b, []) -mapAccumR f b (x:xs) = (b'', x':xs') where - (b'', x') = f b' x - (b', xs') = mapAccumR f b xs -\end{code} - -Here is the bi-directional version, that works from both left and right. - -\begin{code} -mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) - -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> accl -- Initial accumulator from left - -> accr -- Initial accumulator from right - -> [x] -- Input list - -> (accl, accr, [y]) -- Final accumulators and result list - -mapAccumB f a b [] = (a,b,[]) -mapAccumB f a b (x:xs) = (a'',b'',y:ys) - where - (a',b'',y) = f a b' x - (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} @@ -629,6 +535,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 +586,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 +593,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 +603,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 +631,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 +639,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 +755,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