[project @ 2000-06-29 13:08:59 by simonmar]

[ghc-hetmet.git] / ghc / compiler / utils / Util.lhs

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 5b4200b..2bb567d 100644 (file)
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -8,22 +8,27 @@
 #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,
 
+       -- for-loop
+       nTimes,
+
        -- association lists
        assoc, assocUsing, assocDefault, assocDefaultUsing,
 
        -- duplicate handling
-       hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
+       hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq,
 
        -- sorting
        IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
@@ -47,6 +52,12 @@ module Util (
        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
+
     ) where
 
 #include "HsVersions.h"
@@ -70,6 +81,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
@@ -89,10 +102,26 @@ 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[Utils-lists]{General list processing}
 %*                                                                     *
 %************************************************************************
@@ -143,13 +172,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}
 
 
@@ -332,6 +364,17 @@ removeDups cmp xs
   where
     collect_dups dups_so_far [x]         = (dups_so_far,      x)
     collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
+
+removeDupsEq :: Eq a => [a] -> ([a], [[a]])
+-- Same, but with only equality
+-- It's worst case quadratic, but we only use it on short lists
+removeDupsEq [] = ([], [])
+removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs)
+                                 where
+                                   (ys,zs) = removeDupsEq (filter (/= x) xs)
+removeDupsEq (x:xs) | otherwise   = (x:ys, zs)
+                                 where
+                                   (ys,zs) = removeDupsEq xs
 \end{code}
 
 
@@ -363,6 +406,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
@@ -375,6 +420,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
@@ -441,6 +487,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)
@@ -465,6 +512,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}
 
 %************************************************************************
@@ -768,7 +816,8 @@ f $! x  = x `seq` f x
 bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 bracket before after thing = do
   a <- before 
-  (thing a) `catch` (\err -> after a >>= fail err)
+  r <- (thing a) `catch` (\err -> after a >> fail err)
   after a
+  return r
 #endif
 \end{code}