#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)
transitiveClosure,
-- accumulating
- mapAccumL, mapAccumR, mapAccumB, foldl2, count,
+ mapAccumL, mapAccumR, mapAccumB,
+ foldl2, count,
-- comparisons
- thenCmp, cmpList,
+ 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
+
+ , global
+
+#if __GLASGOW_HASKELL__ <= 408
+ , catchJust
+ , ioErrors
+ , throwTo
+#endif
+
) where
+#include "../includes/config.h"
#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
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{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}
%************************************************************************
\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}
# 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}
-
-
-\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}
%* *
%************************************************************************
%************************************************************************
\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}
\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
+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}
-
%************************************************************************
%* *
\subsection[Utils-pairs]{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
+\end{code}
+
+Global variables:
-#if __HASKELL1__ <= 4
-($!) :: (Eval a) => (a -> b) -> a -> b
-f $! x = x `seq` f x
+\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
\end{code}
projects / ghc-hetmet.git / blobdiff