%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Util]{Highly random utility functions}
Eager, thenEager, returnEager, mapEager, appEager, runEager,
-- general list processing
- IF_NOT_GHC(forall COMMA exists COMMA)
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
- zipLazy,
+ zipLazy, stretchZipEqual,
mapAndUnzip, mapAndUnzip3,
- nOfThem, lengthExceeds, isSingleton,
- startsWith, endsWith, snocView,
+ nOfThem, lengthExceeds, isSingleton, only,
+ snocView,
isIn, isn'tIn,
-- association lists
assoc, assocUsing, assocDefault, assocDefaultUsing,
-- duplicate handling
- hasNoDups, equivClasses, runs, removeDups,
+ hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
transitiveClosure,
-- accumulating
- mapAccumL, mapAccumR, mapAccumB,
+ mapAccumL, mapAccumR, mapAccumB, foldl2, count,
-- comparisons
thenCmp, cmpList,
- FastString,
+
+ -- strictness
+ seqList, ($!),
-- pairs
IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith,
-
- -- tracing (abstract away from lib home)
- trace,
-
- -- error handling
- panic, panic#, assertPanic
-
+ unzipWith
) where
#include "HsVersions.h"
-import FastString ( FastString )
import List ( zipWith4 )
-import GlaExts ( trace )
+import Panic ( panic )
+import Unique ( Unique )
+import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
infixr 9 `thenCmp`
\end{code}
%* *
%************************************************************************
-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
-\end{code}
-
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?
zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
\end{code}
+
+\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
+
+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)
+\end{code}
+
+
\begin{code}
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
\begin{code}
nOfThem :: Int -> a -> [a]
-nOfThem n thing = take n (repeat thing)
+nOfThem n thing = replicate n thing
lengthExceeds :: [a] -> Int -> Bool
-
-[] `lengthExceeds` n = 0 > n
-(x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
+-- (lengthExceeds xs n) is True if length xs > n
+(x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
+[] `lengthExceeds` n = n < 0
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
-
-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}
\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}
(a'',b',ys) = mapAccumB f a' b 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}
+
+
%************************************************************************
%* *
\subsection[Utils-comparison]{Comparisons}
else GT
cmpString [] ys = LT
cmpString xs [] = GT
-
-cmpString _ _ = panic "cmpString"
\end{code}
-y
%************************************************************************
%* *
\subsection[Utils-pairs]{Pairs}
unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-errors]{Error handling}
-%* *
-%************************************************************************
-
\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)
+#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
-panic# :: String -> FAST_INT
-panic# s = case (panic s) of () -> ILIT(0)
+#if __HASKELL1__ <= 4
+($!) :: (Eval a) => (a -> b) -> a -> b
+f $! x = x `seq` f x
+#endif
+\end{code}
-assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)
+\begin{code}
+#if __GLASGOW_HASKELL__ < 402
+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)
+ after a
+#endif
\end{code}
projects / ghc-hetmet.git / blobdiff