X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=51f53f308e599d3fd6c61fe95fb3bf98387c5834;hb=907755c2ed39ccf417113d85e0335cc2628f0dfa;hp=52966b88596b38a711d28fbb7233fba393cd69c9;hpb=156d91339295539a2b3461efc1ac8c83f29d83f0;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 52966b8..51f53f3 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -17,7 +17,9 @@ module Util (
 	zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
         zipLazy, stretchZipWith,
 	mapAndUnzip, mapAndUnzip3,
-	nOfThem, lengthExceeds, isSingleton, only,
+	nOfThem, 
+	lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
+	isSingleton, only,
 	snocView,
 	isIn, isn'tIn,
 
@@ -37,26 +39,24 @@ module Util (
 	transitiveClosure,
 
 	-- accumulating
-	mapAccumL, mapAccumR, mapAccumB, foldl2, count,
+	mapAccumL, mapAccumR, mapAccumB, 
+	foldl2, count,
+	
+	takeList, dropList, splitAtList,
 
 	-- comparisons
-	thenCmp, cmpList, prefixMatch, postfixMatch,
+	eqListBy, equalLength, compareLength,
+	thenCmp, cmpList, prefixMatch, suffixMatch,
 
 	-- strictness
-	seqList, ($!),
+	foldl', seqList,
 
 	-- pairs
 	IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
 	IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
 	unzipWith
 
-	-- I/O
-#if __GLASGOW_HASKELL__ < 402
-	, bracket
-#endif
-
 	, global
-	, myGetProcessID
 
 #if __GLASGOW_HASKELL__ <= 408
 	, catchJust
@@ -66,6 +66,7 @@ module Util (
 
     ) where
 
+#include "../includes/config.h"
 #include "HsVersions.h"
 
 import List		( zipWith4 )
@@ -76,9 +77,7 @@ import FastTypes
 #if __GLASGOW_HASKELL__ <= 408
 import Exception	( catchIO, justIoErrors, raiseInThread )
 #endif
-#ifndef mingw32_TARGET_OS
-import Posix
-#endif
+
 infixr 9 `thenCmp`
 \end{code}
 
@@ -138,9 +137,9 @@ nTimes n f = f . nTimes (n-1) f
 %************************************************************************
 
 \begin{code}
-unJust :: Maybe a -> String -> a
-unJust (Just x) who = x
-unJust Nothing  who = panic ("unJust of Nothing, called by " ++ who)
+unJust :: String -> Maybe a -> a
+unJust who (Just x) = x
+unJust who Nothing  = panic ("unJust of Nothing, called by " ++ who)
 \end{code}
 
 %************************************************************************
@@ -234,10 +233,47 @@ 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 = atLength (not.null) (const False)
+
+lengthAtLeast :: [a] -> Int -> Bool
+lengthAtLeast = atLength (not.null) (== 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
@@ -610,6 +646,16 @@ 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}
@@ -627,6 +673,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}
+
 
 %************************************************************************
 %*									*
@@ -635,6 +707,22 @@ count p (x:xs) | p x       = 1 + count p xs
 %************************************************************************
 
 \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
@@ -657,8 +745,8 @@ prefixMatch _pat [] = False
 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 			  | otherwise = False
 
-postfixMatch :: Eq a => [a] -> [a] -> Bool
-postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
+suffixMatch :: Eq a => [a] -> [a] -> Bool
+suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 \end{code}
 
 %************************************************************************
@@ -699,29 +787,9 @@ unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 \end{code}
 
 \begin{code}
-#if __HASKELL1__ > 4
 seqList :: [a] -> b -> b
-#else
-seqList :: (Eval a) => [a] -> b -> b
-#endif
 seqList [] b = b
 seqList (x:xs) b = x `seq` seqList xs b
-
-#if __HASKELL1__ <= 4
-($!)    :: (Eval a) => (a -> b) -> a -> b
-f $! x  = x `seq` f x
-#endif
-\end{code}
-
-\begin{code}
-#if __GLASGOW_HASKELL__ < 402
-bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
-bracket before after thing = do
-  a <- before 
-  r <- (thing a) `catch` (\err -> after a >> fail err)
-  after a
-  return r
-#endif
 \end{code}
 
 Global variables:
@@ -739,11 +807,4 @@ catchJust = catchIO
 ioErrors  = justIoErrors
 throwTo   = raiseInThread
 #endif
-
-#ifdef mingw32_TARGET_OS
-foreign import "_getpid" myGetProcessID :: IO Int 
-#else
-myGetProcessID :: IO Int
-myGetProcessID = Posix.getProcessID
-#endif
 \end{code}