X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=78aec401b67a2629cbc411ab119f1b67b62153bd;hb=562926d74281d08113893e72edcafaf39b52dafe;hp=c4ee1f437f6053e48c8b383c5ab59851253f4f82;hpb=a3b59d6f3abffead146fce06ab09b8da0db270d4;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index c4ee1f4..78aec40 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -8,22 +8,24 @@
 #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, stretchZipEqual,
+        zipLazy, stretchZipWith,
 	mapAndUnzip, mapAndUnzip3,
 	nOfThem, lengthExceeds, isSingleton, only,
 	snocView,
 	isIn, isn'tIn,
 
-	-- association lists
-	assoc, assocUsing, assocDefault, assocDefaultUsing,
+	-- for-loop
+	nTimes,
 
-	-- duplicate handling
-	hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
+	-- maybe-ish
+	unJust,
 
 	-- sorting
 	IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
@@ -38,7 +40,7 @@ module Util (
 	mapAccumL, mapAccumR, mapAccumB, foldl2, count,
 
 	-- comparisons
-	thenCmp, cmpList,
+	thenCmp, cmpList, prefixMatch, postfixMatch,
 
 	-- strictness
 	seqList, ($!),
@@ -53,15 +55,30 @@ module Util (
 	, bracket
 #endif
 
+	, global
+	, myGetProcessID
+
+#if __GLASGOW_HASKELL__ <= 408
+	, catchJust
+	, ioErrors
+	, throwTo
+#endif
+
     ) where
 
 #include "HsVersions.h"
 
 import List		( zipWith4 )
+import Maybe		( Maybe(..) )
 import Panic		( panic )
-import Unique		( Unique )
-import UniqFM		( eltsUFM, emptyUFM, addToUFM_C )
-
+import IOExts		( IORef, newIORef, unsafePerformIO )
+import FastTypes
+#if __GLASGOW_HASKELL__ <= 408
+import Exception	( catchIO, justIoErrors, raiseInThread )
+#endif
+#ifndef mingw32_TARGET_OS
+import Posix
+#endif
 infixr 9 `thenCmp`
 \end{code}
 
@@ -76,6 +93,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
@@ -95,6 +114,33 @@ mapEager f [] = returnEager []
 mapEager f (x:xs) = f x			`thenEager` \ y ->
 		    mapEager f xs	`thenEager` \ ys ->
 		    returnEager (y:ys)
+#endif
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{A for loop}
+%*									*
+%************************************************************************
+
+\begin{code}
+-- 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{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}
 
 %************************************************************************
@@ -149,13 +195,16 @@ zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 
 
 \begin{code}
-stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
--- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
+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*
 
-stretchZipEqual f [] [] = []
-stretchZipEqual f (x:xs) (y:ys) = case f x y of
-				    Just x' -> x' : stretchZipEqual f xs ys
-				    Nothing -> x  : stretchZipEqual f xs (y:ys)
+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}
 
 
@@ -228,20 +277,20 @@ 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 = panic ("Over-long elem in: " ++ msg)
+      | 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 = panic ("Over-long notElem in: " ++ msg)
+      | otherwise	 =  x /= y && notElem (i +# _ILIT(1)) x ys
 
 # endif {- DEBUG -}
 
@@ -249,115 +298,6 @@ isn'tIn msg x ys
 
 %************************************************************************
 %*									*
-\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}
-
-
-\begin{code}
-equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
-	-- NB: it's *very* important that if we have the input list [a,b,c],
-	-- where a,b,c all have the same unique, then we get back the list
-	-- 	[a,b,c]
-	-- not
-	--	[c,b,a]
-	-- Hence the use of foldr, plus the reversed-args tack_on below
-equivClassesByUniq get_uniq xs
-  = eltsUFM (foldr add emptyUFM xs)
-  where
-    add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
-    tack_on old new = new++old
-\end{code}
-
-%************************************************************************
-%*									*
 \subsection[Utils-sorting]{Sorting}
 %*									*
 %************************************************************************
@@ -369,6 +309,8 @@ equivClassesByUniq get_uniq 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
@@ -381,6 +323,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
@@ -447,6 +390,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)
@@ -471,6 +415,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}
 
 %************************************************************************
@@ -706,16 +651,15 @@ 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
-\end{code}
+prefixMatch :: Eq a => [a] -> [a] -> Bool
+prefixMatch [] _str = True
+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)
+\end{code}
 
 %************************************************************************
 %*									*
@@ -779,3 +723,27 @@ bracket before after thing = do
   return r
 #endif
 \end{code}
+
+Global variables:
+
+\begin{code}
+global :: a -> IORef a
+global a = unsafePerformIO (newIORef a)
+\end{code}
+
+Compatibility stuff:
+
+\begin{code}
+#if __GLASGOW_HASKELL__ <= 408
+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}