X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=ed7ee9aca6a27aadcc5d4c32a241b65d3e795506;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=23c6f4edcdfdd561db1410db13900ca51933a043;hpb=78dddbd277d766ec77d22a49867b580a0e19463b;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 23c6f4e..ed7ee9a 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,
@@ -34,7 +34,7 @@ module Util (
 
 	-- comparisons
 	eqListBy, equalLength, compareLength,
-	thenCmp, cmpList, prefixMatch, suffixMatch,
+	thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
 
 	-- strictness
 	foldl', seqList,
@@ -46,9 +46,14 @@ module Util (
 
 	-- module names
 	looksLikeModuleName,
+	
+	toArgs,
+
+	-- Floating point stuff
+	readRational,
     ) where
 
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
 #include "HsVersions.h"
 
 import Panic		( panic, trace )
@@ -66,7 +71,8 @@ import qualified List	( elem, notElem )
 import List		( zipWith4 )
 #endif
 
-import Char		( isUpper, isAlphaNum )
+import Char		( isUpper, isAlphaNum, isSpace, ord, isDigit )
+import Ratio		( (%) )
 
 infixr 9 `thenCmp`
 \end{code}
@@ -126,6 +132,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?
@@ -295,7 +309,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
@@ -313,7 +327,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 -}
+# endif /* DEBUG */
 \end{code}
 
 %************************************************************************
@@ -525,13 +539,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 (<=)
@@ -730,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}
@@ -763,11 +784,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}
@@ -797,3 +813,78 @@ looksLikeModuleName (c:cs) = isUpper c && go cs
 	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}