X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=bb22d4e9bec65371bae74b70799f7945f94ec2e1;hb=7c3d4a1f2b2529ce300b8acc1d26ad98312b9e96;hp=feea95ca4a99696d6f301926fd34d59627e460b7;hpb=6ef5df4a1bc630798e0de5e676afe11086b68606;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index feea95c..bb22d4e 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -1,78 +1,75 @@ % -% (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, mapAndUnzip, mapAndUnzip3, - nOfThem, lengthExceeds, isSingleton, only, - snocView, + nOfThem, + lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, + isSingleton, only, + 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) + sortLt, naturalMergeSortLe, -- transitive closures transitiveClosure, -- accumulating - mapAccumL, mapAccumR, mapAccumB, foldl2, count, + mapAccumL, mapAccumR, mapAccumB, + foldl2, count, + + takeList, dropList, splitAtList, -- comparisons - thenCmp, cmpList, prefixMatch, postfixMatch, + eqListBy, equalLength, compareLength, + thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, -- strictness - seqList, ($!), + foldl', seqList, -- pairs - IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA) - IF_NOT_GHC(applyToSnd COMMA foldPair COMMA) - unzipWith + unzipWith, - -- I/O -#if __GLASGOW_HASKELL__ < 402 - , bracket -#endif + global, - , global - , myProcessID + -- module names + looksLikeModuleName, + + toArgs + ) where + +#include "../includes/config.h" +#include "HsVersions.h" + +import Panic ( panic, trace ) +import FastTypes #if __GLASGOW_HASKELL__ <= 408 - , catchJust - , ioErrors - , throwTo +import EXCEPTION ( catchIO, justIoErrors, raiseInThread ) #endif +import DATA_IOREF ( IORef, newIORef ) +import UNSAFE_IO ( unsafePerformIO ) - ) where - -#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 Char ( isUpper, isAlphaNum, isSpace ) + infixr 9 `thenCmp` \end{code} @@ -125,7 +122,6 @@ nTimes 1 f = f nTimes n f = f . nTimes (n-1) f \end{code} - %************************************************************************ %* * \subsection[Utils-lists]{General list processing} @@ -217,15 +213,66 @@ 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 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 +281,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,25 +297,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 -} - + | 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} %************************************************************************ @@ -313,8 +352,6 @@ 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 @@ -490,18 +527,21 @@ 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 +#endif + naturalMergeSortLe le = generalNaturalMergeSort le \end{code} @@ -593,6 +633,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 +660,32 @@ 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 + +\end{code} + %************************************************************************ %* * @@ -618,6 +694,22 @@ count p (x:xs) | p x = 1 + count p xs %************************************************************************ \begin{code} +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 + thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} thenCmp EQ any = any @@ -640,8 +732,15 @@ 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) \end{code} %************************************************************************ @@ -653,14 +752,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 +771,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,29 +780,9 @@ 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 - -#if __HASKELL1__ <= 4 -($!) :: (Eval a) => (a -> b) -> a -> b -f $! x = x `seq` f x -#endif -\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 \end{code} Global variables: @@ -714,20 +792,37 @@ global :: a -> IORef a global a = unsafePerformIO (newIORef a) \end{code} -Compatibility stuff: +Module names: \begin{code} -#if __GLASGOW_HASKELL__ <= 408 -catchJust = catchIO -ioErrors = justIoErrors -throwTo = raiseInThread -#endif +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} -#ifdef mingw32_TARGET_OS -foreign import "_getpid" myProcessID :: IO Int -#else -myProcessID :: IO Int -myProcessID = do hPutStrLn stderr "Warning:myProcessID" - return 12345 -#endif +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}