X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=058431c0cb083f3869162f56c5771286f3852565;hb=371b4d98a140f98a05633106076b36b993a586cf;hp=b1c93a8a6aa82a2f326df199352789db28e03fbb;hpb=4a1b418e39175d1ee3482a309eb691ce29dc3199;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index b1c93a8..058431c 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -1,37 +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, lengthExceeds, isSingleton, only,
-	snocView,
+	nOfThem, 
+	lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
+	isSingleton, only,
+	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,
@@ -39,40 +29,47 @@ module Util (
 	-- accumulating
 	mapAccumL, mapAccumR, mapAccumB, 
 	foldl2, count,
+	
+	takeList, dropList, splitAtList,
 
 	-- comparisons
-	eqListBy, thenCmp, cmpList, prefixMatch, suffixMatch,
+	eqListBy, equalLength, compareLength,
+	thenCmp, cmpList, prefixMatch, suffixMatch,
 
 	-- strictness
 	foldl', seqList,
 
 	-- pairs
-	IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
-	IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
-	unzipWith
-
-	, global
+	unzipWith,
 
-#if __GLASGOW_HASKELL__ <= 408
-	, catchJust
-	, ioErrors
-	, throwTo
-#endif
+	global,
 
+	-- module names
+	looksLikeModuleName,
+	
+	toArgs
     ) where
 
 #include "../includes/config.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 )
+
 infixr 9 `thenCmp`
 \end{code}
 
@@ -127,18 +124,6 @@ nTimes n f = f . nTimes (n-1) f
 
 %************************************************************************
 %*									*
-\subsection{Maybe-ery}
-%*									*
-%************************************************************************
-
-\begin{code}
-unJust :: String -> Maybe a -> a
-unJust who (Just x) = x
-unJust who Nothing  = panic ("unJust of Nothing, called by " ++ who)
-\end{code}
-
-%************************************************************************
-%*									*
 \subsection[Utils-lists]{General list processing}
 %*									*
 %************************************************************************
@@ -228,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
@@ -245,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}
@@ -275,19 +303,19 @@ isIn msg 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
-
+      | 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}
 
 %************************************************************************
@@ -324,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
@@ -507,12 +533,15 @@ generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 generalNaturalMergeSort p [] = []
 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 
+#if NOT_USED
 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 
 mergeSort = generalMergeSort (<=)
 naturalMergeSort = generalNaturalMergeSort (<=)
 
 mergeSortLe le = generalMergeSort le
+#endif
+
 naturalMergeSortLe le = generalNaturalMergeSort le
 \end{code}
 
@@ -631,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}
+
 
 %************************************************************************
 %*									*
@@ -644,6 +699,17 @@ 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
@@ -679,14 +745,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)
 
@@ -695,6 +764,7 @@ 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
@@ -720,12 +790,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}
+
+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}