X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=a8d289de1cfa4488c94d6a9b63b10bc084a6a214;hb=dd9e16729a737dd6dcc44b0ae3c10ba4b2b69b0c;hp=33198560a7ca4e780d20d3acf7ba4c2ea82a5b02;hpb=dba3cb5b1e6270e4f9f663a2b6fce198170a32b2;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 3319856..a8d289d 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[Util]{Highly random utility functions}
 
@@ -8,23 +8,25 @@
 #define IF_NOT_GHC(a)
 
 module Util (
+#if NOT_USED
 	-- The Eager monad
 	Eager, thenEager, returnEager, mapEager, appEager, runEager,
+#endif
 
 	-- general list processing
-	IF_NOT_GHC(forall COMMA exists COMMA)
 	zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
-        zipLazy,
+        zipLazy, stretchZipWith,
 	mapAndUnzip, mapAndUnzip3,
-	nOfThem, lengthExceeds, isSingleton,
-	startsWith, endsWith, snocView,
-	isIn, isn'tIn,
+	nOfThem, 
+	lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
+	isSingleton, only,
+	notNull,
 
-	-- association lists
-	assoc, assocUsing, assocDefault, assocDefaultUsing,
+	snocView,
+	isIn, isn'tIn,
 
-	-- duplicate handling
-	hasNoDups, equivClasses, runs, removeDups,
+	-- for-loop
+	nTimes,
 
 	-- sorting
 	IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
@@ -36,30 +38,45 @@ module Util (
 	transitiveClosure,
 
 	-- accumulating
-	mapAccumL, mapAccumR, mapAccumB,
+	mapAccumL, mapAccumR, mapAccumB, 
+	foldl2, count,
+	
+	takeList, dropList, splitAtList,
 
 	-- comparisons
-	thenCmp, cmpList,
-	FastString,
+	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,
+	unzipWith
 
-	-- tracing (abstract away from lib home)
-	trace,
+	, global
 
-	-- error handling
-	panic, panic#, assertPanic
+#if __GLASGOW_HASKELL__ <= 408
+	, catchJust
+	, ioErrors
+	, throwTo
+#endif
 
     ) where
 
+#include "../includes/config.h"
 #include "HsVersions.h"
 
-import FastString	( FastString )
+import qualified List	( elem, notElem )
 import List		( zipWith4 )
-import GlaExts		( trace )
+import Maybe		( Maybe(..) )
+import Panic		( panic, trace )
+import IOExts		( IORef, newIORef, unsafePerformIO )
+import FastTypes
+#if __GLASGOW_HASKELL__ <= 408
+import Exception	( catchIO, justIoErrors, raiseInThread )
+#endif
 
 infixr 9 `thenCmp`
 \end{code}
@@ -75,6 +92,8 @@ used to allow you to express "do this and then that", mainly to avoid
 space leaks. It's done with a type synonym to save bureaucracy.
 
 \begin{code}
+#if NOT_USED
+
 type Eager ans a = (a -> ans) -> ans
 
 runEager :: Eager a a -> a
@@ -94,26 +113,29 @@ mapEager f [] = returnEager []
 mapEager f (x:xs) = f x			`thenEager` \ y ->
 		    mapEager f xs	`thenEager` \ ys ->
 		    returnEager (y:ys)
+#endif
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[Utils-lists]{General list processing}
+\subsection{A for loop}
 %*									*
 %************************************************************************
 
-Quantifiers are not standard in Haskell. The following fill in the gap.
-
 \begin{code}
-forall :: (a -> Bool) -> [a] -> Bool
-forall pred []     = True
-forall pred (x:xs) = pred x && forall pred xs
-
-exists :: (a -> Bool) -> [a] -> Bool
-exists pred []     = False
-exists pred (x:xs) = pred x || exists pred xs
+-- Compose a function with itself n times.  (nth rather than twice)
+nTimes :: Int -> (a -> a) -> (a -> a)
+nTimes 0 _ = id
+nTimes 1 f = f
+nTimes n f = f . nTimes (n-1) f
 \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?
@@ -158,6 +180,21 @@ zipLazy [] ys = []
 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 \end{code}
 
+
+\begin{code}
+stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
+-- (stretchZipWith p z f xs ys) stretches ys by inserting z in 
+-- the places where p returns *True*
+
+stretchZipWith p z f [] ys = []
+stretchZipWith p z f (x:xs) ys
+  | p x       = f x z : stretchZipWith p z f xs ys
+  | otherwise = case ys of
+		  []     -> []
+		  (y:ys) -> f x y : stretchZipWith p z f xs ys
+\end{code}
+
+
 \begin{code}
 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 
@@ -182,29 +219,65 @@ mapAndUnzip3 f (x:xs)
 
 \begin{code}
 nOfThem :: Int -> a -> [a]
-nOfThem n thing = take n (repeat thing)
+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) = (length xs > n)
+lengthExceeds = atLength notNull (const False)
 
-[]	`lengthExceeds` n =  0 > n
-(x:xs)	`lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
+lengthAtLeast :: [a] -> Int -> Bool
+lengthAtLeast = atLength notNull (== 0)
 
-isSingleton :: [a] -> Bool
+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
 
-startsWith, endsWith :: String -> String -> Maybe String
-
-startsWith []     str = Just str
-startsWith (c:cs) (s:ss)
-  = if c /= s then Nothing else startsWith cs ss
-startsWith  _	  []  = Nothing
+notNull :: [a] -> Bool
+notNull [] = False
+notNull _  = True
 
-endsWith cs ss
-  = case (startsWith (reverse cs) (reverse ss)) of
-      Nothing -> Nothing
-      Just rs -> Just (reverse rs)
+only :: [a] -> a
+#ifdef DEBUG
+only [a] = a
+#else
+only (a:_) = a
+#endif
 \end{code}
 
 \begin{code}
@@ -233,119 +306,25 @@ notElem__ x (y:ys) =  x /= y && notElem__ x ys
 
 # else {- DEBUG -}
 isIn msg x ys
-  = elem ILIT(0) x ys
+  = elem (_ILIT 0) x ys
   where
     elem i _ []	    = False
     elem i x (y:ys)
-      | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
-      | otherwise	 = x == y || elem (i _ADD_ 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
+  = notElem (_ILIT 0) x ys
   where
     notElem i x [] =  True
     notElem i x (y:ys)
-      | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
-      | otherwise	 =  x /= y && notElem (i _ADD_ 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}
-
-%************************************************************************
-%*									*
-\subsection[Utils-assoc]{Association lists}
-%*									*
-%************************************************************************
-
-See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
-
-\begin{code}
-assoc		  :: (Eq a) => String -> [(a, b)] -> a -> b
-assocDefault	  :: (Eq a) => b -> [(a, b)] -> a -> b
-assocUsing	  :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
-assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
-
-assocDefaultUsing eq deflt ((k,v) : rest) key
-  | k `eq` key = v
-  | otherwise  = assocDefaultUsing eq deflt rest key
-
-assocDefaultUsing eq deflt [] key = deflt
-
-assoc crash_msg         list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
-assocDefault deflt      list key = assocDefaultUsing (==) deflt list key
-assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Utils-dups]{Duplicate-handling}
-%*									*
-%************************************************************************
-
-\begin{code}
-hasNoDups :: (Eq a) => [a] -> Bool
-
-hasNoDups xs = f [] xs
-  where
-    f seen_so_far []     = True
-    f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
-				False
-			   else
-				f (x:seen_so_far) xs
-
-    is_elem = isIn "hasNoDups"
-\end{code}
-
-\begin{code}
-equivClasses :: (a -> a -> Ordering) 	-- Comparison
-	     -> [a]
-	     -> [[a]]
-
-equivClasses cmp stuff@[]     = []
-equivClasses cmp stuff@[item] = [stuff]
-equivClasses cmp items
-  = runs eq (sortLt lt items)
-  where
-    eq a b = case cmp a b of { EQ -> True; _ -> False }
-    lt a b = case cmp a b of { LT -> True; _ -> False }
 \end{code}
 
-The first cases in @equivClasses@ above are just to cut to the point
-more quickly...
-
-@runs@ groups a list into a list of lists, each sublist being a run of
-identical elements of the input list. It is passed a predicate @p@ which
-tells when two elements are equal.
-
-\begin{code}
-runs :: (a -> a -> Bool) 	-- Equality
-     -> [a]
-     -> [[a]]
-
-runs p []     = []
-runs p (x:xs) = case (span (p x) xs) of
-		  (first, rest) -> (x:first) : (runs p rest)
-\end{code}
-
-\begin{code}
-removeDups :: (a -> a -> Ordering) 	-- Comparison function
-	   -> [a]
-	   -> ([a], 	-- List with no duplicates
-	       [[a]])	-- List of duplicate groups.  One representative from
-			-- each group appears in the first result
-
-removeDups cmp []  = ([], [])
-removeDups cmp [x] = ([x],[])
-removeDups cmp xs
-  = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
-    (xs', dups) }
-  where
-    collect_dups dups_so_far [x]         = (dups_so_far,      x)
-    collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
-\end{code}
-
-
 %************************************************************************
 %*									*
 \subsection[Utils-sorting]{Sorting}
@@ -359,6 +338,8 @@ removeDups cmp xs
 %************************************************************************
 
 \begin{code}
+#if NOT_USED
+
 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
 quicksort :: (a -> a -> Bool)		-- Less-than predicate
 	  -> [a]			-- Input list
@@ -371,6 +352,7 @@ quicksort lt (x:xs)  = split x [] [] xs
     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
@@ -437,6 +419,7 @@ rqpart lt x (y:ys) rle rgt r =
 %************************************************************************
 
 \begin{code}
+#if NOT_USED
 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
 
 mergesort cmp xs = merge_lists (split_into_runs [] xs)
@@ -461,6 +444,7 @@ mergesort cmp xs = merge_lists (split_into_runs [] xs)
 	  EQ  -> x : y : (merge xs ys)
 	  LT  -> x : (merge xs yl)
 	  GT -> y : (merge xl ys)
+#endif
 \end{code}
 
 %************************************************************************
@@ -655,6 +639,60 @@ 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}
+foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
+foldl2 k z [] [] = z
+foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
+\end{code}
+
+Count the number of times a predicate is true
+
+\begin{code}
+count :: (a -> Bool) -> [a] -> Int
+count p [] = 0
+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}
+
+
 %************************************************************************
 %*									*
 \subsection[Utils-comparison]{Comparisons}
@@ -662,6 +700,22 @@ mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 %************************************************************************
 
 \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
@@ -678,20 +732,16 @@ cmpList cmp (a:as) (b:bs)
 \end{code}
 
 \begin{code}
-cmpString :: String -> String -> Ordering
-
-cmpString []     []	= EQ
-cmpString (x:xs) (y:ys) = if	  x == y then cmpString xs ys
-			  else if x  < y then LT
-			  else		      GT
-cmpString []     ys	= LT
-cmpString xs     []	= GT
-
-cmpString _ _ = panic "cmpString"
+prefixMatch :: Eq a => [a] -> [a] -> Bool
+prefixMatch [] _str = True
+prefixMatch _pat [] = False
+prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
+			  | otherwise = False
+
+suffixMatch :: Eq a => [a] -> [a] -> Bool
+suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 \end{code}
 
-
-y
 %************************************************************************
 %*									*
 \subsection[Utils-pairs]{Pairs}
@@ -729,26 +779,25 @@ unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 \end{code}
 
+\begin{code}
+seqList :: [a] -> b -> b
+seqList [] b = b
+seqList (x:xs) b = x `seq` seqList xs b
+\end{code}
 
-%************************************************************************
-%*									*
-\subsection[Utils-errors]{Error handling}
-%*									*
-%************************************************************************
+Global variables:
 
 \begin{code}
-panic x = error ("panic! (the `impossible' happened):\n\t"
-	      ++ x ++ "\n\n"
-	      ++ "Please report it as a compiler bug "
-	      ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
-
--- #-versions because panic can't return an unboxed int, and that's
--- what TAG_ is with GHC at the moment.  Ugh. (Simon)
--- No, man -- Too Beautiful! (Will)
+global :: a -> IORef a
+global a = unsafePerformIO (newIORef a)
+\end{code}
 
-panic# :: String -> FAST_INT
-panic# s = case (panic s) of () -> ILIT(0)
+Compatibility stuff:
 
-assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)
+\begin{code}
+#if __GLASGOW_HASKELL__ <= 408
+catchJust = catchIO
+ioErrors  = justIoErrors
+throwTo   = raiseInThread
+#endif
 \end{code}