#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, stretchZipEqual,
+ zipLazy, stretchZipWith,
mapAndUnzip, mapAndUnzip3,
- nOfThem, lengthExceeds, isSingleton,
- startsWith, endsWith, snocView,
+ nOfThem, lengthExceeds, isSingleton, only,
+ snocView,
isIn, isn'tIn,
- -- association lists
- assoc, assocUsing, assocDefault, assocDefaultUsing,
+ -- for-loop
+ nTimes,
- -- duplicate handling
- hasNoDups, equivClasses, runs, removeDups,
+ -- maybe-ish
+ unJust,
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
transitiveClosure,
-- accumulating
- mapAccumL, mapAccumR, mapAccumB,
+ mapAccumL, mapAccumR, mapAccumB,
+ foldl2, count,
-- comparisons
- thenCmp, cmpList,
- FastString,
+ 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 List ( zipWith4 )
-import GlaExts ( trace )
+import Maybe ( Maybe(..) )
+import Panic ( panic )
+import IOExts ( IORef, newIORef, unsafePerformIO )
+import FastTypes
+#if __GLASGOW_HASKELL__ <= 408
+import Exception ( catchIO, justIoErrors, raiseInThread )
+#endif
infixr 9 `thenCmp`
\end{code}
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
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
+-- 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}
+%* *
+%************************************************************************
-exists :: (a -> Bool) -> [a] -> Bool
-exists pred [] = False
-exists pred (x:xs) = pred x || exists pred xs
+\begin{code}
+unJust :: String -> Maybe a -> a
+unJust who (Just x) = x
+unJust who Nothing = panic ("unJust of Nothing, called by " ++ who)
\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?
\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)
+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}
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}
# 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 -}
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
%************************************************************************
\begin{code}
+#if NOT_USED
+
-- tail-recursive, etc., "quicker sort" [as per Meira thesis]
quicksort :: (a -> a -> Bool) -- Less-than predicate
-> [a] -- Input list
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
%************************************************************************
\begin{code}
+#if NOT_USED
mergesort :: (a -> a -> Ordering) -> [a] -> [a]
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}
%************************************************************************
(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}
+
+
%************************************************************************
%* *
\subsection[Utils-comparison]{Comparisons}
\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}
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}
projects / ghc-hetmet.git / blobdiff