X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=ed7ee9aca6a27aadcc5d4c32a241b65d3e795506;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=51f53f308e599d3fd6c61fe95fb3bf98387c5834;hpb=9e93335020e64a811dbbb223e1727c76933a93ae;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 51f53f3..ed7ee9a 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -1,39 +1,27 @@ % -% (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, + nOfThem, filterOut, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, isSingleton, only, - snocView, + notNull, snocView, + isIn, isn'tIn, -- for-loop nTimes, - -- maybe-ish - unJust, - -- 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, @@ -46,38 +34,46 @@ module Util ( -- comparisons eqListBy, equalLength, compareLength, - thenCmp, cmpList, prefixMatch, suffixMatch, + thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, -- strictness foldl', seqList, -- pairs - IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA) - IF_NOT_GHC(applyToSnd COMMA foldPair COMMA) - unzipWith + unzipWith, - , global + global, -#if __GLASGOW_HASKELL__ <= 408 - , catchJust - , ioErrors - , throwTo -#endif + -- module names + looksLikeModuleName, + + toArgs, + -- Floating point stuff + readRational, ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" -import List ( zipWith4 ) -import Maybe ( Maybe(..) ) -import Panic ( panic ) -import IOExts ( IORef, newIORef, unsafePerformIO ) +import Panic ( panic, trace ) import FastTypes + #if __GLASGOW_HASKELL__ <= 408 -import Exception ( catchIO, justIoErrors, raiseInThread ) +import EXCEPTION ( catchIO, justIoErrors, raiseInThread ) +#endif +import DATA_IOREF ( IORef, newIORef ) +import UNSAFE_IO ( unsafePerformIO ) + +import qualified List ( elem, notElem ) + +#ifndef DEBUG +import List ( zipWith4 ) #endif +import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Ratio ( (%) ) + infixr 9 `thenCmp` \end{code} @@ -132,22 +128,18 @@ nTimes n f = f . nTimes (n-1) f %************************************************************************ %* * -\subsection{Maybe-ery} +\subsection[Utils-lists]{General list processing} %* * %************************************************************************ \begin{code} -unJust :: String -> Maybe a -> a -unJust who (Just x) = x -unJust who Nothing = panic ("unJust of Nothing, called by " ++ who) +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} -%************************************************************************ -%* * -\subsection[Utils-lists]{General list processing} -%* * -%************************************************************************ - 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? @@ -256,10 +248,11 @@ atLength atLenPred atEndPred ls n -- special cases. lengthExceeds :: [a] -> Int -> Bool -lengthExceeds = atLength (not.null) (const False) +-- (lengthExceeds xs n) = (length xs > n) +lengthExceeds = atLength notNull (const False) lengthAtLeast :: [a] -> Int -> Bool -lengthAtLeast = atLength (not.null) (== 0) +lengthAtLeast = atLength notNull (== 0) lengthIs :: [a] -> Int -> Bool lengthIs = atLength null (==0) @@ -279,6 +272,19 @@ 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 @@ -287,14 +293,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} @@ -311,25 +309,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} %************************************************************************ @@ -366,8 +364,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 @@ -543,18 +539,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} @@ -745,6 +744,13 @@ 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 +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} @@ -758,14 +764,17 @@ suffixMatch 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) @@ -774,11 +783,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} @@ -799,12 +804,87 @@ 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} + +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) \end{code}