X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=11d1b5e545700e1552773d0870de7ecd96aa603c;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=058431c0cb083f3869162f56c5771286f3852565;hpb=d3b10fea875a34da69463839ba8071d82eb568c6;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 058431c..11d1b5e 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -10,7 +10,7 @@ module Util ( zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, mapAndUnzip, mapAndUnzip3, - nOfThem, + nOfThem, filterOut, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, isSingleton, only, notNull, snocView, @@ -21,7 +21,7 @@ module Util ( nTimes, -- sorting - sortLt, naturalMergeSortLe, + sortLe, sortWith, -- transitive closures transitiveClosure, @@ -33,8 +33,8 @@ module Util ( takeList, dropList, splitAtList, -- comparisons - eqListBy, equalLength, compareLength, - thenCmp, cmpList, prefixMatch, suffixMatch, + isEqual, eqListBy, equalLength, compareLength, + thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, -- strictness foldl', seqList, @@ -47,10 +47,12 @@ module Util ( -- module names looksLikeModuleName, - toArgs + toArgs, + + -- Floating point stuff + readRational, ) where -#include "../includes/config.h" #include "HsVersions.h" import Panic ( panic, trace ) @@ -68,7 +70,8 @@ import qualified List ( elem, notElem ) import List ( zipWith4 ) #endif -import Char ( isUpper, isAlphaNum, isSpace ) +import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Ratio ( (%) ) infixr 9 `thenCmp` \end{code} @@ -128,6 +131,14 @@ nTimes n f = f . nTimes (n-1) f %* * %************************************************************************ +\begin{code} +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} + 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? @@ -297,7 +308,7 @@ 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 @@ -315,127 +326,7 @@ isn'tIn msg x ys | 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} - -%************************************************************************ -%* * -\subsection[Utils-sorting]{Sorting} -%* * -%************************************************************************ - -%************************************************************************ -%* * -\subsubsection[Utils-quicksorting]{Quicksorts} -%* * -%************************************************************************ - -\begin{code} -#if NOT_USED - --- tail-recursive, etc., "quicker sort" [as per Meira thesis] -quicksort :: (a -> a -> Bool) -- Less-than predicate - -> [a] -- Input list - -> [a] -- Result list in increasing order - -quicksort lt [] = [] -quicksort lt [x] = [x] -quicksort lt (x:xs) = split x [] [] xs - where - split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi) - split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys - | True = split x lo (y:hi) ys -#endif -\end{code} - -Quicksort variant from Lennart's Haskell-library contribution. This -is a {\em stable} sort. - -\begin{code} -sortLt :: (a -> a -> Bool) -- Less-than predicate - -> [a] -- Input list - -> [a] -- Result list - -sortLt lt l = qsort lt l [] - --- qsort is stable and does not concatenate. -qsort :: (a -> a -> Bool) -- Less-than predicate - -> [a] -- xs, Input list - -> [a] -- r, Concatenate this list to the sorted input list - -> [a] -- Result = sort xs ++ r - -qsort lt [] r = r -qsort lt [x] r = x:r -qsort lt (x:xs) r = qpart lt x xs [] [] r - --- qpart partitions and sorts the sublists --- rlt contains things less than x, --- rge contains the ones greater than or equal to x. --- Both have equal elements reversed with respect to the original list. - -qpart lt x [] rlt rge r = - -- rlt and rge are in reverse order and must be sorted with an - -- anti-stable sorting - rqsort lt rlt (x : rqsort lt rge r) - -qpart lt x (y:ys) rlt rge r = - if lt y x then - -- y < x - qpart lt x ys (y:rlt) rge r - else - -- y >= x - qpart lt x ys rlt (y:rge) r - --- rqsort is as qsort but anti-stable, i.e. reverses equal elements -rqsort lt [] r = r -rqsort lt [x] r = x:r -rqsort lt (x:xs) r = rqpart lt x xs [] [] r - -rqpart lt x [] rle rgt r = - qsort lt rle (x : qsort lt rgt r) - -rqpart lt x (y:ys) rle rgt r = - if lt x y then - -- y > x - rqpart lt x ys rle (y:rgt) r - else - -- y <= x - rqpart lt x ys (y:rle) rgt r -\end{code} - -%************************************************************************ -%* * -\subsubsection[Utils-dull-mergesort]{A rather dull mergesort} -%* * -%************************************************************************ - -\begin{code} -#if NOT_USED -mergesort :: (a -> a -> Ordering) -> [a] -> [a] - -mergesort cmp xs = merge_lists (split_into_runs [] xs) - where - a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False } - a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True } - - split_into_runs [] [] = [] - split_into_runs run [] = [run] - split_into_runs [] (x:xs) = split_into_runs [x] xs - split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs - split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs - | True = rl : (split_into_runs [x] xs) - - merge_lists [] = [] - merge_lists (x:xs) = merge x (merge_lists xs) - - merge [] ys = ys - merge xs [] = xs - merge xl@(x:xs) yl@(y:ys) - = case cmp x y of - EQ -> x : y : (merge xs ys) - LT -> x : (merge xs yl) - GT -> y : (merge xl ys) -#endif +# endif /* DEBUG */ \end{code} %************************************************************************ @@ -481,34 +372,24 @@ Carsten \begin{code} group :: (a -> a -> Bool) -> [a] -> [[a]] +-- Given a <= function, group finds maximal contiguous up-runs +-- or down-runs in the input list. +-- It's stable, in the sense that it never re-orders equal elements +-- +-- Date: Mon, 12 Feb 1996 15:09:41 +0000 +-- From: Andy Gill +-- Here is a `better' definition of group. -{- -Date: Mon, 12 Feb 1996 15:09:41 +0000 -From: Andy Gill - -Here is a `better' definition of group. --} group p [] = [] group p (x:xs) = group' xs x x (x :) where group' [] _ _ s = [s []] group' (x:xs) x_min x_max s - | not (x `p` x_max) = group' xs x_min x (s . (x :)) - | x `p` x_min = group' xs x x_max ((x :) . s) + | x_max `p` x = group' xs x_min x (s . (x :)) + | not (x_min `p` x) = group' xs x x_max ((x :) . s) | otherwise = s [] : group' xs x x (x :) - --- This one works forwards *and* backwards, as well as also being --- faster that the one in Util.lhs. - -{- ORIG: -group p [] = [[]] -group p (x:xs) = - let ((h1:t1):tt1) = group p xs - (t,tt) = if null xs then ([],[]) else - if x `p` h1 then (h1:t1,tt1) else - ([], (h1:t1):tt1) - in ((x:t):tt) --} + -- NB: the 'not' is essential for stablity + -- x `p` x_min would reverse equal elements generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] generalMerge p xs [] = xs @@ -527,13 +408,13 @@ 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 (<=) @@ -542,7 +423,13 @@ naturalMergeSort = generalNaturalMergeSort (<=) mergeSortLe le = generalMergeSort le #endif -naturalMergeSortLe le = generalNaturalMergeSort le +sortLe :: (a->a->Bool) -> [a] -> [a] +sortLe le = generalNaturalMergeSort le + +sortWith :: Ord b => (a->b) -> [a] -> [a] +sortWith get_key xs = sortLe le xs + where + x `le` y = get_key x < get_key y \end{code} %************************************************************************ @@ -694,6 +581,17 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'') %************************************************************************ \begin{code} +isEqual :: Ordering -> Bool +-- Often used in (isEqual (a `compare` b)) +isEqual GT = False +isEqual EQ = True +isEqual LT = False + +thenCmp :: Ordering -> Ordering -> Ordering +{-# INLINE thenCmp #-} +thenCmp EQ any = any +thenCmp other any = other + eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool eqListBy eq [] [] = True eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys @@ -710,11 +608,6 @@ compareLength (_:xs) (_:ys) = compareLength xs ys compareLength [] _ys = LT compareLength _xs [] = GT -thenCmp :: Ordering -> Ordering -> Ordering -{-# INLINE thenCmp #-} -thenCmp EQ any = any -thenCmp other any = other - cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- `cmpList' uses a user-specified comparer @@ -732,6 +625,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} @@ -765,11 +665,6 @@ applyToFst f (x,y) = (f x,y) applyToSnd :: (b -> d) -> (a,b) -> (a,d) applyToSnd f (x,y) = (x,f y) #endif - -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 \end{code} \begin{code} @@ -824,3 +719,53 @@ toArgs s = 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}